(Broken) Exploration of `Text.ParserCombinators.ReadP` package used to parse SQL create table syntax.

hsql_parser.hs

module SqlParser where

import Text.ParserCombinators.ReadP
import Data.Char (isAlpha)
--import Data.String.Utils
import qualified Data.Text as T
import Data.List
import qualified Data.Set as Set
import qualified Data.Map as M
import Data.Maybe


data FieldProperty = FpNotNull | FpPrimaryKey |
    FpUnique | FpIndex | FpForeignKey
    deriving (Eq, Ord, Show, Read, Bounded, Enum)

data FieldRelation = OneToOne | OneToMany
    deriving (Eq, Ord, Show, Read, Bounded, Enum)

data SqlDb = PostgreSql | MySql | Sqlite | MariaDb
    deriving (Eq, Ord, Show, Read, Bounded, Enum)

data SqlForeign = SqlForeign {
    schema, table, field, kind :: String
  , relatedField :: String
  , isUnique :: Bool
    } --deriving (Show)

instance Show SqlForeign where
    show _ = "SqlForeign not available yet"

data SqlField = SqlField {
    name :: String
  , fieldType :: String
  , options :: Set.Set FieldProperty
  , defaultValue :: String
  , dbType :: SqlDb
  , foreignTable :: SqlForeign
    } deriving (Show)

data SqlTable = SqlTable {
    tableSchema, tableName :: String
  , fields :: M.Map String SqlField
  , referers :: M.Map String SqlForeign
    } deriving (Show)

strip :: String -> String
strip = T.unpack . T.strip . T.pack

chomp ::  ReadP String
chomp =
    munch (\x -> (isAlpha(x) || x == '_') && (x /= '(' || x /= ')'))

tablenameP :: ReadP String
tablenameP = do
    string "create"
    skipSpaces
    string "table"
    skipSpaces
    optional (string "if")
    skipSpaces
    optional (string "not")
    skipSpaces
    optional (string "exists")
    skipSpaces
    tableName <- chomp
    return (strip tableName)

exprParser = do
    expr1 <- munch (\c -> c /= ';')
    satisfy (== ';')
    return (strip expr1)

skipOptional c = optional $ skipMany1 (char c)

skipWord :: ReadP ()
skipWord = do
    chomp
    skipOptional ' '
    return ()

chompTo c = do
    expr <- munch (\chr -> chr /= c)
    return (strip expr)

varcharParsing :: ReadP String
varcharParsing = do
    skipSpaces
    varying <- chompTo '('
    get
    skipSpaces
    val <- chompTo ')'
    get
    if "varying" `isInfixOf` (strip varying)
       then return ("varchar(" ++ (strip val) ++ ")")
       else
           if val == ""
              then return ("char(1)")
              else return ("char(" ++ (strip val) ++ ")")


vcValP :: ReadP String
vcValP = do
    get
    val <- munch (\x -> x /= ')')
    get
    return ("varchar(" ++ (strip val) ++ ")")

timeParsing :: String -> ReadP String
timeParsing s = do
    withword <- option "" chomp
    case withword of
         "with" -> do
             skipOptional ' '
             skipWord
             skipWord
             return (s ++ "tz")
         "without" -> do
             skipOptional ' '
             skipWord
             skipWord
             return s
         _ -> do
             skipOptional ' '
             return s

fieldTypeParser :: ReadP String
fieldTypeParser = do
    skipSpaces
    let isCompundType str =  ("character" `isPrefixOf` str) ||
            ("time" `isPrefixOf` str)
    fieldtypename <- chomp
    skipSpaces
    if not $ isCompundType (strip fieldtypename)
       then do
           if fieldtypename == "varchar"
              then vcValP
              else return fieldtypename
       else do
           if fieldtypename `isPrefixOf` "character"
              then varcharParsing
              else (timeParsing fieldtypename)

fieldOptParser :: ReadP (Set.Set FieldProperty, String)
fieldOptParser = do
    rest <- munch (\c -> c /= ',')
    optional get
    let optStr = ["null", "index", "key", "references", "unique"]
    let insertOp x acc | x == "null"       = FpNotNull:acc
                       | x == "index"      = FpIndex:acc
                       | x == "key"        = FpPrimaryKey:acc
                       | x == "unique"     = FpUnique:acc
                       | x == "references" = FpForeignKey:acc
                       | True              = acc
    let opts = foldr (\a b -> if a `isInfixOf` rest
                                 then (insertOp a b)
                                 else b) [] optStr
    return (Set.fromList opts, "")

fieldParser :: ReadP SqlField
--fieldParser :: ReadP (String, String)
fieldParser = do
    {-
    skipOptional ' '
    skipOptional '('
    skipOptional ' '
    fieldname <- chompTo ' '
    skipOptional ' '
    typename <- fieldTypeParser
    -}
    skipSpaces
    char '('
    skipSpaces
    fieldname <- chomp
    typename <- fieldTypeParser
    (opts, defval) <- fieldOptParser
        
    return SqlField {
        name = fieldname,
        fieldType = typename,
        options = opts,
        defaultValue = defval,
        dbType = PostgreSql,
        foreignTable = SqlForeign{}
        }

tableParser :: ReadP SqlTable
tableParser = do
    tablename <- tablenameP
    sqlfield <- fieldParser
    --let field = M.insert (name sqlfield) sqlfield M.empty
    return SqlTable {
        tableSchema = "",
        tableName = tablename,
        fields = M.insert (name sqlfield) sqlfield M.empty,
        referers = M.empty
        }

testIt x = do
    readP_to_S tablenameP x

parseExpr :: String -> [String]
parseExpr s =
    case readP_to_S exprParser s of
         [] -> []
         lst@((found, remaining): _) ->
             map (strip . fst) lst

{-
    - example to run
    - map parseTablename (parseExpr "create table if not exists my_table ()\
        \ ; create table if my_table_again \
        \ () ;")
    - > ["my_table", "my_table_again"]
-}
parseTablename s =
    case readP_to_S tablenameP s of
         [] -> ""
         lst@(_) -> (fst $ last lst)

parseTable s =
    case readP_to_S tableParser s of
         [] -> Nothing
         ((sqltable, _):_) -> Just sqltable

formatter :: (Show a1, Show a2, Show a3) => (a1, a2, a3) -> String
formatter info =
    let (tbl, fldname, fldtype) = info in
        "tabel: " ++ show tbl ++ ", field name: " ++ show fldname ++
        ", field type: " ++ show fldtype

formatterField field =
    "\tField name: " ++ (name field) ++
        "\n\t\ttype: " ++ (fieldType field) ++
        "\n\t\toptions: " ++ (show $ options field)

formatterSql sqltable =
    "Table name: " ++ (tableName sqltable) ++ "\n" ++
        (foldr (++) "" $ map (formatterField . snd) $ M.toList (fields sqltable))

see prompt s = do
    putStrLn (prompt ++ show s)

testParseTable = do
    let str1 = "create table if not exists my_table();"
        str2 = "create table my_table(id int);"
        str3 = "create table my_table(name varchar(20) primary key not null index);"
    case parseTable str3 of
         Nothing -> putStrLn "Nothing to show"
         Just (info) -> do
             see "example: " str3
             putStrLn $ formatterSql info