{-# LANGUAGE OverloadedStrings #-}
module Text.Parsec.Erd.Parser
( AST(..),
GlobalOptions(..),
document,
globalOptions,
entity,
rel,
attr,
comment
) where
import Erd.ER
import Control.Monad (liftM2, void, when)
import Data.Char (isAlphaNum, isControl, isSpace)
import qualified Data.Map as M
import Data.Maybe
import Data.Text.Lazy
import Text.Parsec
import Text.Parsec.Text.Lazy
import Text.Printf (printf)
data AST = E Entity
| A Attribute
| R Relation
deriving (Show, Eq)
data GlobalOptions = GlobalOptions { gtoptions :: Options
, ghoptions :: Options
, geoptions :: Options
, groptions :: Options
}
deriving (Show, Eq)
emptyGlobalOptions :: GlobalOptions
emptyGlobalOptions = GlobalOptions M.empty M.empty M.empty M.empty
document :: Parser (GlobalOptions, [AST])
document = do skipMany (comment <|> blanks)
opts <- globalOptions emptyGlobalOptions
ast <- catMaybes <$> manyTill top eof
return (opts, ast)
where top = (entity <?> "entity declaration")
<|> (try rel <?> "relationship")
<|> (try attr <?> "attribute")
<|> (comment <?> "comment")
<|> blanks
blanks = many1 (space <?> "whitespace") >> return Nothing
entity :: Parser (Maybe AST)
entity = do n <- between (char '[') (char ']') ident
spacesNoNew
opts <- options
eolComment
return $ Just $ E Entity { name = n, attribs = [],
hoptions = opts, eoptions = opts }
attr :: Parser (Maybe AST)
attr = do
keys <- many $ oneOf "*+ \t"
let (ispk, isfk) = ('*' `elem` keys, '+' `elem` keys)
n <- ident
opts <- options
eolComment
return
$ Just
$ A Attribute {field = n, pk = ispk, fk = isfk, aoptions = opts <> defaultAttrOpts}
rel :: Parser (Maybe AST)
rel = do
let ops = "?1*+"
e1 <- ident
op1 <- oneOf ops
_ <- string "--"
op2 <- oneOf ops
e2 <- ident
opts <- options
let getCard op =
case cardByName op of
Just t -> return t
Nothing -> unexpected (printf "Cardinality '%s' does not exist." op)
t1 <- getCard op1
t2 <- getCard op2
return $ Just $ R Relation { entity1 = e1, entity2 = e2
, card1 = t1, card2 = t2, roptions = opts }
globalOptions :: GlobalOptions -> Parser GlobalOptions
globalOptions gopts =
option gopts $ try $ do
n <- ident
opts <- options
case n of
"title" -> emptiness >> globalOptions (gopts { gtoptions = opts})
"header" -> emptiness >> globalOptions (gopts { ghoptions = opts})
"entity" -> emptiness >> globalOptions (gopts { geoptions = opts})
"relationship" -> emptiness >> globalOptions (gopts { groptions = opts})
_ -> fail "not a valid directive"
options :: Parser (M.Map String Option)
options =
option M.empty
$ fmap M.fromList
$ try
$ between (char '{' >> emptiness) (emptiness >> char '}')
$ opt `sepEndBy` (emptiness >> char ',' >> emptiness)
opt :: Parser (String, Option)
opt = do
optName <- liftM2 (:) letter (manyTill (letter <|> char '-') (char ':'))
<?> "option name"
emptiness
value <- between (char '"') (char '"') (many $ noneOf "\"")
<?> "option value"
case optionByName optName value of
Left err -> fail err
Right o' -> emptiness >> return (optName, o')
comment :: Parser (Maybe AST)
comment = do
_ <- char '#'
_ <- manyTill anyChar $ try eol
return Nothing
ident :: Parser Text
ident = do
spacesNoNew
n <- identQuoted <|> identNoSpace
spacesNoNew
return n
identQuoted :: Parser Text
identQuoted = do
quote <- oneOf "'\"`"
let p = satisfy (\c -> c /= quote && not (isControl c) )
<?> "any character except " ++ [quote] ++ " or control characters"
n <- fmap pack (many1 p)
_ <- char quote
return n
identNoSpace :: Parser Text
identNoSpace = do
let p = satisfy (\c -> c == '_' || isAlphaNum c)
<?> "letter, digit or underscore"
fmap pack (many1 p)
emptiness :: Parser ()
emptiness = skipMany (void (many1 space) <|> eolComment)
eolComment :: Parser ()
eolComment = spacesNoNew >> (eol <|> void comment)
spacesNoNew :: Parser ()
spacesNoNew = skipMany $ satisfy $ \c -> c /= '\n' && c /= '\r' && isSpace c
eol :: Parser ()
eol = eof <|> do
c <- oneOf "\n\r"
when (c == '\r') $ optional $ char '\n'