gdritter repos electric-boogaloo / 1423735
The tiny electric-boogaloo tool Getty Ritter 8 years ago
5 changed file(s) with 207 addition(s) and 0 deletion(s). Collapse all Expand all
+4
-0
.gitignore less more
1 *~
2 dist
3 dist-newstyle
4 cabal.sandbox.config
+12
-0
LICENSE less more
1 Copyright (c) 2016, Getty Ritter
2 All rights reserved.
3
4 Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
5
6 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
7
8 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
9
10 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
11
12 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+68
-0
README.md less more
1 This is a program that understands a shorthand for the kinds
2 of SQL that I usually write, specifically targeting SQLite.
3 It's hacky and bad and could use a lot of work, but it works
4 fine enough for me.
5
6 The input language is of the form
7
8 ~~~
9 -- line comments
10 table1
11 field1 : type1
12 field2 : type2
13
14 table2
15 field3 : type3
16 field4 : type4
17 ~~~
18
19 Fields can be indented any number of spaces. A new table is
20 started by an indentifier at the beginning of a line.
21
22 Types are either one of these built-in types:
23
24 ~~~
25 null int integer real text blob date
26 ~~~
27
28 or the name of a table declared in the source file.
29
30 All tables get an implicit `id` column of the form
31
32 ~~~
33 id INTEGER PRIMARY KEY ASC
34 ~~~
35
36 and types which reference other tables are implicitly translated
37 into integers with foreign key constraints on the other table.
38 (This also means that it'll reject tables with an explicit
39 `id` column.)
40 For example, the following `electric-boogaloo` definition:
41
42 ~~~
43 books
44 title: text
45 author_name: authors
46 published: date
47
48 authors
49 name: text
50 gender: blob
51 ~~~
52
53 Produces the following SQLite table declarations:
54
55 ~~~.sql
56 CREATE TABLE books
57 ( id INTEGER PRIMARY KEY ASC
58 , title TEXT
59 , author_name INTEGER
60 , published DATE
61 , FOREIGN KEY(author_name) REFERENCES authors(id)
62 );
63 CREATE TABLE authors
64 ( id INTEGER PRIMARY KEY ASC
65 , name TEXT
66 , gender BLOB
67 );
68 ~~~
+21
-0
electric-boogaloo.cabal less more
1 name: electric-boogaloo
2 version: 0.1.0.0
3 -- synopsis:
4 -- description
5 license: BSD3
6 license-file: LICENSE
7 author: Getty Ritter <gettyritter@gmail.com>
8 maintainer: Getty Ritter <gettyritter@gmail.com>
9 copyright: ©2016 Getty Ritter
10 category: Database
11 build-type: Simple
12 cabal-version: >= 1.12
13
14 executable electric-boogaloo
15 hs-source-dirs: src
16 main-is: Main.hs
17 default-extensions: OverloadedStrings,
18 ScopedTypeVariables
19 ghc-options: -Wall
20 build-depends: base >=4.7 && <4.9, text
21 default-language: Haskell2010
+102
-0
src/Main.hs less more
1 module Main where
2
3 import Data.Char (isSpace, isAlphaNum)
4 import Data.Text (Text)
5 import qualified Data.Text as T
6 import qualified Data.Text.IO as T
7
8 data Decl = Decl
9 { dName :: Text
10 , dFields :: [Field]
11 } deriving (Eq, Show)
12
13 data Field = Field
14 { fName :: Text
15 , fType :: Text
16 } deriving (Eq, Show)
17
18 uncomment :: Text -> Text
19 uncomment = fst . T.breakOn "--"
20
21 isValid :: Text -> Bool
22 isValid = T.all (\ x -> isAlphaNum x || x == '_')
23
24 parse :: Text -> Either String [Decl]
25 parse = go [] . map uncomment . T.lines
26 where go ds [] = return ds
27 go ds (l:ls)
28 | T.length (T.takeWhile isSpace l) > 0 =
29 let (n, t) = T.break (== ':') (T.strip l)
30 f = Field { fName = T.strip n
31 , fType = T.strip (T.drop 1 t)
32 }
33 in case ds of
34 (d:ds') -> go (d { dFields = f : dFields d } : ds') ls
35 [] -> Left "indented line outside of table decl"
36 | T.all isSpace l =
37 go ds ls
38 | otherwise =
39 let d = Decl { dName = T.strip l
40 , dFields = []
41 }
42 in go (d:ds) ls
43
44 builtins :: [Text]
45 builtins = [ "null", "int", "integer", "real", "text", "blob", "date" ]
46
47 check :: [Decl] -> Either String ()
48 check ds =
49 let tables = map dName ds
50 types = builtins ++ tables
51 chk Field { fName = f, fType = t }
52 | not (isValid f) =
53 Left $ "Invalid field name: '" ++ T.unpack f ++ "'"
54 | f == "id" = Left "Field 'id' conflicts with built-in id"
55 | t `elem` types = return ()
56 | otherwise = Left ("Unknown type: " ++ T.unpack t)
57 in do
58 mapM_ (\ Decl { dName = n } ->
59 if not (isValid n)
60 then Left $ "Invalid table name: '" ++ T.unpack n ++ "'"
61 else return ()
62 ) ds
63 mapM_ (mapM_ chk . dFields) ds
64
65 typeName :: Text -> Text
66 typeName t
67 | t `elem` builtins = T.toUpper t
68 | otherwise = "INTEGER"
69
70 pprint :: Decl -> IO ()
71 pprint Decl { dName = n, dFields = fs } = do
72 T.putStr "CREATE TABLE "
73 T.putStrLn n
74 T.putStrLn " ( id INTEGER PRIMARY KEY ASC"
75 mapM_ printField fs
76 mapM_ printForeign fs
77 T.putStrLn " );"
78 where printField Field { fName = f, fType = t } = do
79 T.putStr " , "
80 T.putStr f
81 T.putStr " "
82 T.putStrLn (typeName t)
83 printForeign Field { fName = f, fType = t }
84 | t `elem` builtins = return ()
85 | otherwise = do
86 T.putStr " , FOREIGN KEY("
87 T.putStr f
88 T.putStr ") REFERENCES "
89 T.putStr t
90 T.putStrLn "(id)"
91
92 rev :: [Decl] -> [Decl]
93 rev ds = reverse [ d { dFields = reverse (dFields d) } | d <- ds ]
94
95 main :: IO ()
96 main = do
97 cs <- T.getContents
98 case parse cs of
99 Left err -> putStrLn err
100 Right ds -> case check ds of
101 Left err -> putStrLn err
102 Right () -> mapM_ pprint (rev ds)