QDnqDKbQ

1module SqlParser where
2
3import Text.ParserCombinators.ReadP
4import Data.Char (isAlpha)
5--import Data.String.Utils
6import qualified Data.Text as T
7import Data.List
8import qualified Data.Set as Set
9import qualified Data.Map as M
10import Data.Maybe
11
12
13data FieldProperty = FpNotNull | FpPrimaryKey |
14    FpUnique | FpIndex | FpForeignKey
15    deriving (Eq, Ord, Show, Read, Bounded, Enum)
16
17data FieldRelation = OneToOne | OneToMany
18    deriving (Eq, Ord, Show, Read, Bounded, Enum)
19
20data SqlDb = PostgreSql | MySql | Sqlite | MariaDb
21    deriving (Eq, Ord, Show, Read, Bounded, Enum)
22
23data SqlForeign = SqlForeign {
24    schema, table, field, kind :: String
25  , relatedField :: String
26  , isUnique :: Bool
27    } --deriving (Show)
28
29instance Show SqlForeign where
30    show _ = "SqlForeign not available yet"
31
32data SqlField = SqlField {
33    name :: String
34  , fieldType :: String
35  , options :: Set.Set FieldProperty
36  , defaultValue :: String
37  , dbType :: SqlDb
38  , foreignTable :: SqlForeign
39    } deriving (Show)
40
41data SqlTable = SqlTable {
42    tableSchema, tableName :: String
43  , fields :: M.Map String SqlField
44  , referers :: M.Map String SqlForeign
45    } deriving (Show)
46
47strip :: String -> String
48strip = T.unpack . T.strip . T.pack
49
50chomp ::  ReadP String
51chomp =
52    munch (\x -> (isAlpha(x) || x == '_') && (x /= '(' || x /= ')'))
53
54tablenameP :: ReadP String
55tablenameP = do
56    string "create"
57    skipSpaces
58    string "table"
59    skipSpaces
60    optional (string "if")
61    skipSpaces
62    optional (string "not")
63    skipSpaces
64    optional (string "exists")
65    skipSpaces
66    tableName <- chomp
67    return tableName
68
69exprParser = do
70    expr1 <- munch (\c -> c /= ';')
71    satisfy (== ';')
72    return (strip expr1)
73
74skipOptional c = optional $ skipMany1 (char c)
75
76skipWord :: ReadP ()
77skipWord = do
78    chomp
79    skipOptional ' '
80    return ()
81
82chompTo c = do
83    expr <- munch (\chr -> chr == c)
84    return (strip expr)
85
86varcharParsing :: ReadP String
87varcharParsing = do
88    varying <- chompTo '('
89    get
90    val <- chompTo ')'
91    get
92    if "varying" `isInfixOf` varying
93       then return ("varchar(" ++ (strip val) ++ ")")
94       else
95           if val == ""
96              then return ("char(1)")
97              else return ("char(" ++ (strip val) ++ ")")
98
99
100vcValP :: ReadP String
101vcValP = do
102    get
103    val <- munch (\x -> x /= ')')
104    get
105    return ("varchar(" ++ (strip val) ++ ")")
106
107timeParsing :: String -> ReadP String
108timeParsing s = do
109    withword <- option "" chomp
110    case withword of
111         "with" -> do
112             skipOptional ' '
113             skipWord
114             skipWord
115             return (s ++ "tz")
116         "without" -> do
117             skipOptional ' '
118             skipWord
119             skipWord
120             return s
121         _ -> do
122             skipOptional ' '
123             return s
124
125fieldTypeParser :: ReadP String
126fieldTypeParser = do
127    skipOptional ' '
128    let isCompundType str =  ("character" `isPrefixOf` str) ||
129            ("time" `isPrefixOf` str)
130    fieldtypename <- option "" chomp
131    skipOptional ' '
132    if not $ isCompundType (strip fieldtypename)
133       then do
134           if fieldtypename == "varchar"
135              then vcValP
136              else return fieldtypename
137       else do
138           if fieldtypename `isPrefixOf` "character"
139              then varcharParsing
140              else (timeParsing fieldtypename)
141
142fieldOptParser :: ReadP (Set.Set FieldProperty, String)
143fieldOptParser = do
144    rest <- munch (\c -> c /= ',')
145    optional get
146    let optStr = ["null", "index", "key", "references", "unique"]
147    let insertOp x acc | x == "null"       = FpNotNull:acc
148                       | x == "index"      = FpIndex:acc
149                       | x == "key"        = FpPrimaryKey:acc
150                       | x == "unique"     = FpUnique:acc
151                       | x == "references" = FpForeignKey:acc
152                       | True              = acc
153    let opts = foldr (\a b -> if a `isInfixOf` rest
154                                 then (insertOp a b)
155                                 else b) [] optStr
156    return (Set.fromList opts, "")
157
158fieldParser :: ReadP SqlField
159--fieldParser :: ReadP (String, String)
160fieldParser = do
161    skipOptional ' '
162    skipOptional '('
163    skipOptional ' '
164    fieldname <- chompTo ' '
165    skipOptional ' '
166    typename <- fieldTypeParser
167    (opts, defval) <- fieldOptParser
168    return SqlField {
169        name = fieldname,
170        fieldType = typename,
171        options = opts,
172        defaultValue = defval,
173        dbType = PostgreSql,
174        foreignTable = SqlForeign{}
175        }
176
177tableParser :: ReadP SqlTable
178tableParser = do
179    tablename <- tablenameP
180    sqlfield <- fieldParser
181    --let field = M.insert (name sqlfield) sqlfield M.empty
182    return SqlTable {
183        tableSchema = "",
184        tableName = tablename,
185        fields = M.insert (name sqlfield) sqlfield M.empty,
186        referers = M.empty
187        }
188
189testIt x = do
190    readP_to_S tablenameP x
191
192parseExpr :: String -> [String]
193parseExpr s =
194    case readP_to_S exprParser s of
195         [] -> []
196         lst@((found, remaining): _) ->
197             map (strip . fst) lst
198
199{-
200    - example to run
201    - map parseTablename (parseExpr "create table if not exists my_table ()\
202        \ ; create table if my_table_again \
203        \ () ;")
204    - > ["my_table", "my_table_again"]
205-}
206parseTablename s =
207    case readP_to_S tablenameP s of
208         [] -> ""
209         lst@(_) -> (fst $ last lst)
210
211parseTable s =
212    case readP_to_S tableParser s of
213         [] -> Nothing
214         ((sqltable, _):_) -> Just sqltable
215
216formatter :: (Show a1, Show a2, Show a3) => (a1, a2, a3) -> String
217formatter info =
218    let (tbl, fldname, fldtype) = info in
219        "tabel: " ++ show tbl ++ ", field name: " ++ show fldname ++
220        ", field type: " ++ show fldtype
221
222formatterField field =
223    "\tField name: " ++ (name field) ++
224        "\n\t\ttype: " ++ (fieldType field) ++
225        "\n\t\toptions: " ++ (show $ options field)
226
227formatterSql sqltable =
228    "Table name: " ++ (tableName sqltable) ++ "\n" ++
229        (foldr (++) "" $ map (formatterField . snd) $ M.toList (fields sqltable))
230
231see prompt s = do
232    putStrLn (prompt ++ show s)
233
234testParseTable = do
235    let str1 = "create table if not exists my_table();"
236        str2 = "create table my_table(id int);"
237        str3 = "create table my_table(name varchar(20) primary key not null index);"
238    case parseTable str3 of
239         Nothing -> putStrLn "Nothing to show"
240         Just (info) -> do
241             see "example: " str3
242             putStrLn $ formatterSql info