diff --git a/erd.cabal b/erd.cabal --- a/erd.cabal +++ b/erd.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: erd -version: 0.1.0.0 +version: 0.1.1.0 homepage: https://github.com/BurntSushi/erd license: PublicDomain license-file: UNLICENSE @@ -65,6 +65,7 @@ hs-source-dirs: src main-is: Main.hs ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind + other-modules: Config, ER, Parse build-depends: base == 4.6.* , graphviz == 2999.16.* diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,135 @@ +module Config + ( Config(..) + , configIO + ) +where + +import Data.Char (isSpace) +import Data.List (dropWhileEnd, intercalate) +import qualified Data.Map as M +import Data.Maybe (isNothing) +import qualified System.Console.GetOpt as O +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (Handle, IOMode(..), stdin, stdout, stderr, openFile) +import Text.Printf (HPrintfType, hPrintf, printf) + +import qualified Data.GraphViz.Commands as G + +-- | Config represents all information from command line flags. +data Config = + Config { cin :: (String, Handle) + , cout :: (String, Handle) + , outfmt :: Maybe G.GraphvizOutput + } + +defaultConfig :: Config +defaultConfig = + Config { cin = ("", stdin) + , cout = ("", stdout) + , outfmt = Nothing + } + +-- | Creates a new Config value from command line options. +-- If an output path is given and `--fmt` is omitted, then a format +-- will be inferred from the output path extension. +-- Failing all of that, PDF is used by default. +configIO :: IO Config +configIO = do + args <- getArgs + case O.getOpt O.Permute opts args of + (flags, [], []) -> do + conf <- foldl (\c app -> app c) (return defaultConfig) flags + let outpath = fst (cout conf) + return $ + if isNothing (outfmt conf) && outpath /= "" then + conf { outfmt = toGraphFmt $ takeExtension outpath } + else + conf + (_, _, errs@(_:_)) -> do + ef "Error(s) parsing flags:\n\t%s\n" $ + intercalate "\n\t" $ map strip errs + exitFailure + (_, _, []) -> do + ef "erd does not have any positional arguments.\n\n" + usageExit + +opts :: [O.OptDescr (IO Config -> IO Config)] +opts = + [ O.Option "i" ["input"] + (O.ReqArg (\fpath cIO -> do + c <- cIO + i <- openFile fpath ReadMode + return $ c { cin = (fpath, i) } + ) + "FILE") + ("When set, input will be read from the given file.\n" + ++ "Otherwise, stdin will be used.") + , O.Option "o" ["output"] + (O.ReqArg (\fpath cIO -> do + c <- cIO + o <- openFile fpath WriteMode + return $ c { cout = (fpath, o) } + ) + "FILE") + ("When set, output will be written to the given file.\n" + ++ "Otherwise, stdout will be used.\n" + ++ "If given and if --fmt is omitted, then the format will be\n" + ++ "guessed from the file extension.") + , O.Option "h" ["help"] + (O.NoArg $ const usageExit) + "Show this usage message." + , O.Option "f" ["fmt"] + (O.ReqArg (\fmt cIO -> do + c <- cIO + let mfmt = toGraphFmt fmt + case mfmt of + Nothing -> do + ef "'%s' is not a valid output format." fmt + exitFailure + Just gfmt -> + return $ c { outfmt = Just gfmt } + ) + "FMT") + (printf "Force the output format to one of:\n%s" + (intercalate ", " $ M.keys fmts)) + ] + +-- | A subset of formats supported from GraphViz. +fmts :: M.Map String (Maybe G.GraphvizOutput) +fmts = M.fromList + [ ("pdf", Just G.Pdf) + , ("svg", Just G.Svg) + , ("eps", Just G.Eps) + , ("bmp", Just G.Bmp) + , ("jpg", Just G.Jpeg) + , ("png", Just G.Png) + , ("gif", Just G.Gif) + , ("tiff", Just G.Tiff) + , ("dot", Just G.Canon) + , ("ps", Just G.Ps) + , ("ps2", Just G.Ps2) + , ("plain", Just G.Plain) + ] + +-- | takeExtension returns the last extension from a file path, or the +-- empty string if no extension was found. e.g., the extension of +-- "wat.pdf" is "pdf". +takeExtension :: String -> String +takeExtension s = if null rest then "" else reverse ext + where (ext, rest) = span (/= '.') $ reverse s + +toGraphFmt :: String -> Maybe G.GraphvizOutput +toGraphFmt ext = M.findWithDefault Nothing ext fmts + +usageExit :: IO a +usageExit = usage >> exitFailure + +usage :: IO a +usage = ef "%s\n" $ O.usageInfo "Usage: erd [flags]" opts + +ef :: HPrintfType r => String -> r +ef = hPrintf stderr + +strip :: String -> String +strip = dropWhile isSpace . dropWhileEnd isSpace diff --git a/src/ER.hs b/src/ER.hs new file mode 100644 --- /dev/null +++ b/src/ER.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE OverloadedStrings #-} +module ER + ( ER(..) + , Entity(..) + , Attribute(..) + , Options, mergeOpts, optionsTo + , Option(..), optionByName, optToFont, optToHtml, optToLabel + , Relation(..) , Cardinality(..), cardByName + , defaultTitleOpts, defaultEntityOpts, defaultHeaderOpts, defaultRelOpts + ) +where + +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import Data.Text.Lazy +import Data.Word (Word8) +import Text.Printf (printf) + +import Data.GraphViz.Parsing (ParseDot, parse, runParser) +import qualified Data.GraphViz.Attributes.HTML as H +import Data.GraphViz.Attributes.Colors (Color) + +-- | Represents a single schema. +data ER = ER { entities :: [Entity] + , rels :: [Relation] + , title :: Options + } + deriving Show + +-- | Represents a single entity in a schema. +data Entity = Entity { name :: Text + , attribs :: [Attribute] + , hoptions :: Options + , eoptions :: Options + } + deriving Show + +instance Eq Entity where + e1 == e2 = name e1 == name e2 + +instance Ord Entity where + e1 `compare` e2 = name e1 `compare` name e2 + +-- | Represents a single attribute in a particular entity. +data Attribute = Attribute { field :: Text + , pk :: Bool + , fk :: Bool + , aoptions :: Options + } + deriving Show + +instance Eq Attribute where + a1 == a2 = field a1 == field a2 + +instance Ord Attribute where + a1 `compare` a2 = field a1 `compare` field a2 + +-- | Represents any number of options for an item in an ER diagram. +-- An item may be the graph title, an entity, an entity header or a +-- relationship between entities. Keys are options as specified in ER files. +-- +-- Note that a set of options may include a label for any item. +type Options = M.Map String Option + +-- | Given two sets of options, merge the second into first, where elements +-- in the first take precedence. +mergeOpts :: Options -> Options -> Options +mergeOpts opts1 opts2 = opts1 `M.union` opts2 + +-- | Given a set of options and a selector function, return the list of +-- only those options which matched. Examples of the selector function are +-- `optToFont`, `optToHtml` and `optToLabel`. +optionsTo :: (Option -> Maybe a) -> Options -> [a] +optionsTo f = mapMaybe f . M.elems + +-- | A restricted subset of options in GraphViz that can be configured in +-- an ER file. +data Option = Label String + | BgColor Color + | Color Color + | FontFace Text + | FontSize Double + | Border Word8 + | BorderColor Color + | CellSpacing Word8 + | CellBorder Word8 + | CellPadding Word8 + deriving Show + +-- | Given an option name and a string representation of its value, +-- `optionByName` will attempt to parse the string as a value corresponding +-- to the option. If the option doesn't exist or there was a problem parsing +-- the value, an error is returned. +optionByName :: String -> String -> Either String Option +optionByName "label" = Right . Label +optionByName "color" = optionParse Color +optionByName "bgcolor" = optionParse BgColor +optionByName "size" = optionParse FontSize +optionByName "font" = optionParse FontFace +optionByName "border" = optionParse Border +optionByName "border-color" = optionParse BorderColor +optionByName "cellspacing" = optionParse CellSpacing +optionByName "cellborder" = optionParse CellBorder +optionByName "cellpadding" = optionParse CellPadding +optionByName unk = const (Left $ printf "Option '%s' does not exist." unk) + +-- | A wrapper around the GraphViz's parser for any particular option. +optionParse :: ParseDot a => (a -> Option) -> String -> Either String Option +optionParse con s = + case fst $ runParser parse quoted of + Left err -> Left (printf "%s (bad value '%s')" err s) + Right a -> Right (con a) + where quoted = "\"" `append` pack s `append` "\"" + +-- | Selects an option if and only if it corresponds to a font attribute. +optToFont :: Option -> Maybe H.Attribute +optToFont (Color c) = Just $ H.Color c +optToFont (FontFace s) = Just $ H.Face s +optToFont (FontSize d) = Just $ H.PointSize d +optToFont _ = Nothing + +-- | Selects an option if and only if it corresponds to an HTML attribute. +-- In particular, for tables or table cells. +optToHtml :: Option -> Maybe H.Attribute +optToHtml (BgColor c) = Just $ H.BGColor c +optToHtml (Border w) = Just $ H.Border w +optToHtml (BorderColor c) = Just $ H.Color c +optToHtml (CellSpacing w) = Just $ H.CellSpacing w +optToHtml (CellBorder w) = Just $ H.CellBorder w +optToHtml (CellPadding w) = Just $ H.CellPadding w +optToHtml _ = Nothing + +-- | Selects an option if and only if it corresponds to a label. +optToLabel :: Option -> Maybe Text +optToLabel (Label s) = Just $ pack s +optToLabel _ = Nothing + +-- | Represents a relationship between exactly two entities. After parsing, +-- each `rel` is guaranteed to correspond to an entity defined in the same +-- ER file. +-- +-- Each relationship has one of four cardinalities specified for both entities. +-- Those cardinalities are: 0 or 1, exactly 1, 0 or more and 1 or more. +data Relation = Relation { entity1, entity2 :: Text + , card1, card2 :: Cardinality + , roptions :: Options + } + deriving Show + +data Cardinality = ZeroOne + | One + | ZeroPlus + | OnePlus + +instance Show Cardinality where + show ZeroOne = "{0,1}" + show One = "1" + show ZeroPlus = "0..N" + show OnePlus ="1..N" + +-- | Maps a string representation to a particular relationship cardinality. +cardByName :: Char -> Maybe Cardinality +cardByName '?' = Just ZeroOne +cardByName '1' = Just One +cardByName '*' = Just ZeroPlus +cardByName '+' = Just OnePlus +cardByName _ = Nothing + +-- | Hard-coded default options for all graph titles. +defaultTitleOpts :: Options +defaultTitleOpts = M.fromList + [ ("size", FontSize 30) + ] + +-- | Hard-coded default options for all entity headers. +defaultHeaderOpts :: Options +defaultHeaderOpts = M.fromList + [ ("size", ER.FontSize 16) + ] + +-- | Hard-coded default options for all entities. +defaultEntityOpts :: Options +defaultEntityOpts = M.fromList + [ ("border", Border 0) + , ("cellborder", CellBorder 1) + , ("cellspacing", CellSpacing 0) + , ("cellpadding", CellPadding 4) + , ("font", FontFace "Helvetica") + ] + +-- | Hard-coded default options for all relationships. +defaultRelOpts :: Options +defaultRelOpts = M.empty diff --git a/src/Parse.hs b/src/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Parse.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE OverloadedStrings #-} +module Parse + ( loadER + ) +where + +import Prelude hiding (null) + +import Control.Monad (liftM2, when, void) +import Data.Char (isAlphaNum, isSpace) +import Data.List (find) +import qualified Data.Map as M +import Data.Maybe +import Data.Text.Lazy hiding (find, map, reverse) +import Data.Text.Lazy.IO +import System.IO (Handle) +import Text.Parsec +import Text.Parsec.Text.Lazy +import Text.Printf (printf) + +import ER + +data AST = E Entity + | A Attribute + | R Relation + deriving Show + +data GlobalOptions = GlobalOptions { gtoptions :: Options + , ghoptions :: Options + , geoptions :: Options + , groptions :: Options + } + deriving Show + +emptyGlobalOptions :: GlobalOptions +emptyGlobalOptions = GlobalOptions M.empty M.empty M.empty M.empty + +loadER :: String -> Handle -> IO (Either String ER) +loadER fpath f = do + s <- hGetContents f + case parse (do { (opts, ast) <- document; return $ toER opts ast}) fpath s of + Left err -> return $ Left $ show err + Right err@(Left _) -> return err + Right (Right er) -> return $ Right er + +-- | Converts a list of syntactic categories in an entity-relationship +-- description to an ER representation. If there was a problem with the +-- conversion, an error is reported. This includes checking that each +-- relationship contains only valid entity names. +-- +-- This preserves the ordering of the syntactic elements in the original +-- description. +toER :: GlobalOptions -> [AST] -> Either String ER +toER gopts = toER' (ER [] [] title) + where title = gtoptions gopts `mergeOpts` defaultTitleOpts + + toER' :: ER -> [AST] -> Either String ER + toER' er [] = Right (reversed er) >>= validRels + toER' (ER { entities = [] }) (A a:_) = + let name = show (field a) + in Left $ printf "Attribute '%s' comes before first entity." name + toER' er@(ER { entities = e':es }) (A a:xs) = do + let e = e' { attribs = a:attribs e' } + toER' (er { entities = e:es }) xs + toER' er@(ER { entities = es }) (E e:xs) = do + let opts = eoptions e + `mergeOpts` geoptions gopts + `mergeOpts` defaultEntityOpts + let hopts = eoptions e + `mergeOpts` ghoptions gopts + `mergeOpts` defaultHeaderOpts + toER' (er { entities = e { eoptions = opts, hoptions = hopts }:es}) xs + toER' er@(ER { rels = rs }) (R r:xs) = do + let opts = roptions r + `mergeOpts` groptions gopts + `mergeOpts` defaultRelOpts + toER' (er { rels = r { roptions = opts }:rs }) xs + + reversed :: ER -> ER + reversed er@(ER { entities = es, rels = rs }) = + let es' = map (\e -> e { attribs = reverse (attribs e) }) es + in er { entities = reverse es', rels = reverse rs } + + validRels :: ER -> Either String ER + validRels er = validRels' (rels er) er + + validRels' :: [Relation] -> ER -> Either String ER + validRels' [] er = return er + validRels' (r:_) er = do + let r1 = find (\e -> name e == entity1 r) (entities er) + let r2 = find (\e -> name e == entity2 r) (entities er) + let err getter = Left + $ printf "Unknown entity '%s' in relationship." + $ unpack $ getter r + when (isNothing r1) (err entity1) + when (isNothing r2) (err entity2) + return er + +document :: Parser (GlobalOptions, [AST]) +document = do skipMany (comment <|> blanks) + opts <- globalOptions emptyGlobalOptions + ast <- fmap catMaybes $ manyTill top eof + return (opts, ast) + where top = (entity "entity declaration") + <|> (try rel "relationship") -- must come before attr + <|> (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 } + +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 "" ident >>= \n -> + if null n then + return gopts + else do + 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}) + _ -> unexpected (printf ("Global option group '%s' is not valid. (Valid " + ++ "groups are title, header, entity, " + ++ "relationship.)") (unpack n)) + +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 + name <- liftM2 (:) letter (manyTill (letter <|> char '-') (char ':')) + "option name" + emptiness + value <- between (char '"') (char '"') (many $ noneOf "\"") + "option value" + case optionByName name value of + Left err -> fail err + Right o' -> emptiness >> return (name, o') + +comment :: Parser (Maybe AST) +comment = do + char '#' + manyTill anyChar $ try eol + return Nothing + +ident :: Parser Text +ident = do + spacesNoNew + let p = satisfy (\c -> c == '_' || isAlphaNum c) + "letter, digit or underscore" + n <- fmap pack (many1 p) + spacesNoNew + return n + +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' +