hssqlppp-0.1.0: HsSqlSystem.lhs
#! /usr/bin/env runghc
Copyright 2009 Jake Wheat
Command line access to a bunch of utility functions.
run
./HsSqlSystem.lhs -?
to get a list of commands and purpose and usage info
> {-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
> import System.Console.CmdArgs
> import System.IO
> import System.Directory
> import Data.List
> import Control.Monad.Error
> import Data.Char
> --import Control.Applicative
> import Test.Framework (defaultMainWithArgs)
> import Database.HsSqlPpp.Tests.ParserTests
> import Database.HsSqlPpp.Tests.TypeCheckTests
> import Database.HsSqlPpp.Tests.ExtensionTests
> import Database.HsSqlPpp.Tests.ParameterizedStatementTests
> import Database.HsSqlPpp.Ast.Environment
> import Database.HsSqlPpp.Ast.Ast
> import Database.HsSqlPpp.Commands.CommandComponents as C
> data HsSqlSystem = Lex {files :: [String]}
> | Parse {files :: [String]}
> | ParseExpression {files :: [String]}
> | Pppp {files :: [String]}
> | Ppp {files :: [String]}
> | TypeCheck {database :: String
> ,files :: [String]}
> | TypeCheckExpression {database :: String
> ,files :: [String]}
> | AllAnnotations {database :: String
> ,files :: [String]}
> | AnnotateSource {database :: String
> ,file :: String}
> | PPCatalog {database :: String
> ,files :: [String]}
> | Clear {database :: String}
> | Load {database :: String
> ,files :: [String]}
> | ClearLoad {database :: String
> ,files :: [String]}
> | DBCatalog {database :: String}
> | LoadPsql {database :: String
> ,files :: [String]}
> | PgDump {database :: String}
> | TestBattery {database :: String
> ,files :: [String]}
> | Test {extra :: [String]}
> | GenWrap {database :: String
> ,file :: String}
> | BuildDocs
> deriving (Show, Data, Typeable)
> main :: IO ()
> main = do
> cmd <- cmdArgs "HsSqlSystem, Copyright Jake Wheat 2009"
> [lexA, parseA, ppppA, pppA,
> parseExpressionA, typeCheckExpressionA,
> typeCheckA,allAnnotationsA,
> annotateSourceA, ppCatalogA,
> clearA, loadA, clearLoadA, catalogA, loadPsqlA,
> pgDumpA, testBatteryA,
> testA,buildDocsA, genWrapA]
> case cmd of
> Lex fns -> lexFiles fns
> Parse fns -> showAst fns
> Pppp fns -> testPppp fns
> Ppp fns -> showAst fns
> ParseExpression fns -> parseExpression fns
> TypeCheck db fns -> typeCheck2 db fns
> TypeCheckExpression db fns -> typeCheckExpression db fns
> AllAnnotations db fns -> typeCheck2 db fns
> AnnotateSource db fn -> annotateSourceF db fn
> PPCatalog db fns -> ppCatalog db fns
> Clear db -> cleardb db
> Load db fns -> loadSql db fns
> ClearLoad db fns -> clearAndLoadSql db fns
> DBCatalog db -> readCat db
> LoadPsql db fns -> loadSqlPsql db fns
> PgDump db -> pgDump1 db
> TestBattery db fns -> runTestBattery db fns
> Test as -> runTests as
> BuildDocs -> buildDocs
> GenWrap db f -> genWrap db f
would like to have the database argument be a common arg, don't know
how to do this
> lexA, parseA, ppppA, pppA, annotateSourceA, clearA, loadA,
> clearLoadA, catalogA, loadPsqlA, pgDumpA, testBatteryA,
> typeCheckA, testA, parseExpressionA, typeCheckExpressionA,
> buildDocsA, allAnnotationsA, ppCatalogA, genWrapA :: Mode HsSqlSystem
===============================================================================
> lexA = mode Lex {files = def &= typ "FILES" & args}
> &= text "lex the files given and output the tokens on separate lines"
> lexFiles :: [FilePath] -> IO ()
> lexFiles fns = wrapET $
> forM_ fns (\f ->
> message ("lexing " ++ f) >>
> readInput f >>= lexSql f >>= printList)
================================================================================
> parseA = mode $ Parse {files = def &= typ "FILES" & args}
> &= text "Parse files and output the asts"
> showAst :: [String] -> IO ()
> showAst = wrapET . mapM_ (\f ->
> message ("-- ast of " ++ f) >>
> readInput f >>= parseSql1 f >>= stripAnn >>= ppSh >>= message)
================================================================================
> ppppA = mode $ Pppp {files = def &= typ "FILES" & args}
> &= text "Routine to parse sql from a file, pretty print it then parse it \
> \again and check the post pretty printing ast is the same as the \
> \initial ast"
> testPppp :: [String] -> IO ()
> testPppp = wrapET . mapM_ (\f -> do
> ast1 <- readInput f >>= parseSql1 f >>= stripAnn
> ast2 <- ppSql ast1 >>= parseSql1 "" >>= stripAnn
> if ast1 /= ast2
> then do
> message "asts are different\n-- original"
> ppSh ast1 >>= message
> message "-- ppp'd"
> ppSh ast2 >>= message
> else message "success")
================================================================================
> pppA = mode $ Ppp {files = def &= typ "FILES" & args}
> &= text "Parse then pretty print some sql so you can check the result \
> \hasn't mangled the sql."
> ppp :: String -> IO()
> ppp f = wrapET $ message ("--ppp " ++ f) >>
> readInput f >>= parseSql1 f >>= ppSql >>= message
================================================================================
> parseExpressionA = mode $ ParseExpression {files = def &= typ "FILES" & args}
> &= text "Parse files each containing one expression \
> \and output the asts"
> parseExpression :: [String] -> IO ()
> parseExpression = wrapET . mapM_ (\f ->
> message ("-- ast of " ++ f) >>
> readInput f >>= parseExpression1 f >>= stripAnn
> >>= ppSh >>= message)
================================================================================
> annotateSourceA = mode $ AnnotateSource {database = def
> ,file = def &= typ "FILE"}
> &= text "reads a file, parses, type checks, then outputs info on \
> \each statement interspersed with the original source code"
> annotateSourceF :: String -> FilePath -> IO ()
> annotateSourceF db f =
> wrapET $ do
> message ("--annotated source of " ++ f)
> src <- readInput f
> cat <- readCatalog db
> parseSql1 f src >>= typeCheckC cat >>= lsnd >>=
> ppAnnOrig False src >>= message
================================================================================
> ppCatalogA = mode $ PPCatalog {database = def
> ,files = def &= typ "FILES" & args}
> &= text "reads each file, parses, type checks, then outputs the \
> \changes to the catalog that the sql makes"
> ppCatalog :: String -> [FilePath] -> IO ()
> ppCatalog db fns = wrapET $ do
> scat <- readCatalog db
> (ncat, _) <- mapM (\f -> readInput f >>=
> parseSql1 f) fns >>=
> lconcat >>= typeCheckC scat
> compareCatalogs scat emptyEnvironment ncat >>=
> ppCatDiff >>= message
================================================================================
> typeCheckA = mode $ TypeCheck {database = def
> ,files = def &= typ "FILES" & args}
> &= text "reads each file, parses, type checks, then outputs any type errors"
> typeCheck2 :: String -> [FilePath] -> IO ()
> typeCheck2 db fns = wrapET $
> readCatalog db >>= \cat ->
> mapM (\f -> readInput f >>= parseSql1 f) fns >>= lconcat >>=
> typeCheckC cat >>= lsnd >>= getTEs >>= ppTypeErrors >>= putStrLnList
================================================================================
> allAnnotationsA = mode $ AllAnnotations {database = def
> ,files = def &= typ "FILES" & args}
> &= text "reads each file, parses, type checks, then pretty prints the \
> \ast with all annotations except the source positions"
> allAnnotations :: String -> [FilePath] -> IO ()
> allAnnotations db fns = wrapET $
> readCatalog db >>= \cat ->
> mapM (\f -> readInput f >>= parseSql1 f) fns >>= lconcat >>=
> typeCheckC cat >>= lsnd >>= ppSh >>= message
================================================================================
> typeCheckExpressionA = mode $ TypeCheckExpression {database = def
> ,files = def &= typ "FILES" & args}
> &= text "reads each file, parses as expression, \
> \ type checks, then outputs the type or any type errors"
> typeCheckExpression :: String -> [FilePath] -> IO ()
> typeCheckExpression db fns = wrapET $ do
> aasts <- readCatalog db >>= \cat ->
> forM fns (\f -> readInput f >>= parseExpression1 f
> >>= typeCheckExpressionC cat)
> tes <- mapM getTEs aasts
> mapM_ (\x -> ppTypeErrors x >>= putStrLnList) $ filter (not . null) tes
> mapM_ (\a -> liftM (show . head) (getTopLevelTypes a) >>= message) aasts
================================================================================
= small hack utility to help with testing
TODO: use the correct username in this command
TODO: do something more correct
> clearA = mode $ Clear {database = def}
> &= text "hacky util to clear a database"
> cleardb :: String -> IO ()
> cleardb = wrapET . clearDB
================================================================================
= load sql file
> loadA = mode $ Load {database = def
> ,files = def &= typ "FILES" & args}
> &= text "This takes one or more files with sql source text, \
> \parses them then loads them into the database given."
> loadSql :: String -> [String] -> IO ()
> loadSql db fns = wrapET $
> liftIO (hSetBuffering stdout NoBuffering) >>
> mapM (\f -> readInput f >>= parseSql1 f) fns >>= lconcat >>=
> runExtensions >>= loadAst db ""
================================================================================
> loadPsqlA = mode $ LoadPsql {database = def
> ,files = def &= typ "FILES" & args}
> &= text "loads sql into a database using psql."
> loadSqlPsql :: String -> [String] -> IO ()
> loadSqlPsql db = wrapET .
> --srcs <- mapM readInput fns
> --mapM_ (\s -> loadSqlUsingPsql db s >>= message) (map snd srcs)
> mapM_ (\s -> loadSqlUsingPsqlFromFile db s >>= message)
================================================================================
> pgDumpA = mode $ PgDump {database = def}
> &= text "run pg dump, used for testing."
> pgDump1 :: String -> IO ()
> pgDump1 db = wrapET $ pgDump db >>= message
================================================================================
might try to work out a way of running multiple commands in one invoc
of this exe, then this command will disappear
> clearLoadA = mode $ ClearLoad {database = def
> ,files = def &= typ "FILES" & args}
> &= text "cleardb then loadsql"
> clearAndLoadSql :: String -> [String] -> IO ()
> clearAndLoadSql db fns = cleardb db >> loadSql db fns
================================================================================
This reads an catalog from a database and writes it out using show.
> catalogA = mode $ DBCatalog {database = def}
> &= text "read the catalog for the given db and dumps it in source \
> \format, used to create the catalog value for template1"
> readCat :: String -> IO ()
> readCat dbName = wrapET $ do
> cat <- readCatalog dbName
> message preamble
> ppSh cat >>= prefixLines >>= message
> where
> preamble = "\n\
> \Copyright 2009 Jake Wheat\n\
> \\n\
> \This file contains\n\
> \\n\
> \> {-# OPTIONS_HADDOCK hide #-}\n\
> \\n\
> \> module Database.HsSqlPpp.AstInternals.Environment.DefaultTemplate1Environment\n\
> \> (defaultTemplate1Environment\n\
> \> ) where\n\
> \\n\
> \> import Database.HsSqlPpp.AstInternals.Environment.EnvironmentInternal\n\
> \> import Database.HsSqlPpp.AstInternals.TypeType\n\
> \\n\
> \> defaultTemplate1Environment :: Environment\n\
> \> defaultTemplate1Environment =\n\
> \> (\\l -> case l of\n\
> \> Left x -> error $ show x\n\
> \> Right e -> e) $\n\
> \> updateEnvironment defaultEnvironment\n"
> prefixLines :: (Monad m, Error e) => String -> ErrorT e m String
> prefixLines = return . unlines . map ("> " ++) . lines
================================================================================
run test battery: run a bunch of tests including consistency on the
database and sql files given
The idea is to typecheck the sql, load it into pg and dump it via psql
and via database loader, can then compare asts, catalogs, etc. in a
lot of different ways
currently:
parse and type check sql, save the catalog
load the sql into the db using psql, compare the catalog read from pg
with the catalog from typechecking
dump the sql and typecheck the dump, compare the catalog from this
check with the catalog from the original typecheck
todo: compare asts from initial parse with parsed dump - this is going
to be a lot of work to get passing since the statements are
re-ordered, and sometimes changed/ split up by pg
also: load the sql using the extension system and database loader,
then compare pg catalog with initial catalog, and dump and compare ast
with original ast
want to run a similar set of tests starting with the dump sql:
get ast,cat from dump sql, load using psql and using databaseloader
and check cats and subsequent dump asts.
getting the dump ast comparing with the original ast:
step one: convert tests in parser test to also roundtrip through
database, see parsertests for details
step two: write an ast conversion routine: assume that the pgdump ast
is like the ast fed into pg but with a few statements split into
components (e.g. create table with serial is split into create
sequence and create table), and then the statements are reordered, so
write a routine to mirror this - will then have
(anyast -> rearrange and reorder) == (anyast -> pg->pgdump)
> testBatteryA = mode $ TestBattery {database = def
> ,files = def &= typ "FILES" & args}
> &= text "runs a load of consistency tests on the sql passed"
> runTestBattery :: String -> [FilePath] -> IO ()
> runTestBattery dbName fns = wrapET $ do
> clearDB dbName
> startingCat <- readCatalog dbName
> (originalCat :: Environment,
> originalAast :: StatementList) <-
> mapM (\f -> readInput f >>= parseSql1 f) fns >>= lconcat >>=
> runExtensions >>= typeCheckC startingCat
> headerMessage "type errors from initial parse:\n"
> getTEs originalAast >>= ppTypeErrors >>= putStrLnList
> mapM_ (\s -> loadSqlUsingPsqlFromFile dbName s >>= message) fns
> properCat <- readCatalog dbName
> headerMessage "catalog differences from initial parse and vanilla load:\n"
> compareCatalogs startingCat originalCat properCat >>=
> ppCatDiff >>= message
> (dumpCat,dumpAast) <-
> pgDump dbName >>= parseSql1 "dump" >>= typeCheckC startingCat
> headerMessage "type errors from dump:\n"
> getTEs dumpAast >>= ppTypeErrors >>= putStrLnList
> headerMessage "catalog differences from initial parse and rechecked pg dump:\n"
> compareCatalogs startingCat originalCat dumpCat >>=
> ppCatDiff >>= message
> message "complete!"
> where
> headerMessage = message . ("-----------------------------\n" ++)
================================================================================
> testA = mode $ Test {extra = def &= typ "ANY" & args & unknownFlags}
> &= text "run automated tests, uses test.framework can pass arguments \
> \to this e.g. HsSqlSystem test -t parserTests"
> runTests :: [String] -> IO ()
> runTests as =
> flip defaultMainWithArgs as $
> parserTests ++
> typeCheckTests ++
> --parameterizedStatementTests ++
> [extensionTests]
================================================================================
options: nothing -> create/overwrite folders and files
clean -> delete generated files
create target folder if doesn't exist
> buildDocsA = mode $ BuildDocs
> &= text "build the documention in the docs/ folder"
> buildDocs :: IO ()
> buildDocs = wrapET $ do
> liftIO $ createDirectoryIfMissing False "docs/build"
> inputFiles <- sources
> let sts = zip (map ("docs/" ++) inputFiles) $
> flip map inputFiles
> (\f -> "docs/build/" ++ f ++ ".html")
> forM_ sts $ \(s,t) ->
> readInput s >>= pandoc >>= C.writeFile t
> where
> sources = liftM (filter (isSuffixOf ".txt"))
> (liftIO (getDirectoryContents "docs"))
================================================================================
> genWrapA = mode $ GenWrap {database = def
> ,file = def &= typ "FILE"}
> &= text "experimental code to generate typesafe haskell wrapper \
> \for db access"
> genWrap :: String -> String -> IO ()
> genWrap db f =
> wrapET doit
> where
> doit :: (MonadIO m) => ErrorT AllErrors m ()
> doit = wrapperGen1 db f >>= message
================================================================================
TODOS
command to display all annotation inline in sql source
better catalog diff, e.g. if two tables differ in one column just show
that difference
see if can improve ppshow to use slightly less newlines
command to show which bits of preexisting catalog are used
command to list which views/functions/etc. aren't used anywhere
replace a bunch of commands with composible set:
parse(expression), ppp, typecheck(expression), allannots
->
parse (expression option)
type check
annotation filter + options
output: ast, sql, annotations + options
think of a better name for this command than hssqlsystem
want better options system:
first set of options get passed around in reader? monad:
database name, username, password for pg
useextensions
annotation control? - when showing values, which annotations to also output?
these have defaults, can change defaults in ~/.config/hssqlsystem or something,
and can be overridden using --dbname=...,etc. command line args (make
these work like psql? then have environment variables also)
second set of options is for input and output:
read from file(s), stdin, or from string literal command line arg, e.g.
HsSqlSystem expressionType --src="3 + 5"
output to file(s) or stdout
review command names and arguments:
find a better naming convention: some commands produce haskell values as text,
some produce non haskell compatible text e.g. lexfile
some run tests and produce a success/fail result, maybe a list of issues
run multiple commands in one invocation?
check errors passed to user are understandable
command line commands to add:
showAast
ppCatalog - read from db and print in human readable rather
than as haskell value
showexpressionast
showexpressionaast
typecheckexpression
pppexpression
showCatalogUpdates - run over some sql files, outputs the catalog changes
made by this sql
ppCatalogUpdates
graphviz stuff: dependency graph: pass a view name or function and it
draws a graph of all the views, tables and functions which are used by
that view or function
run an extension by name over some sql source to view differences: add
integration with external diff viewers, so can see before and after,
maybe option to either view pp'd sql, annotated pp'd sql, ast, aast,
etc. - can also use this for pppsql and pppexpression to view how the
pretty printer mangles things, and for testing, etc.
logging/verbosity:
want a way to log to stderr/stdout/ files with different verbosity
settings
command line arguments:
options:
--database=xxx
?
--extensions
--username
--password
?other connection info
annotation control?
command name
other command arguments:
- on its own is read from stdin
--input='xxx' add literal input rather than from file/stdin