erd 0.1.0.0 → 0.1.1.0
raw patch · 4 files changed
+541/−1 lines, 4 files
Files
- erd.cabal +2/−1
- src/Config.hs +135/−0
- src/ER.hs +193/−0
- src/Parse.hs +211/−0
erd.cabal view
@@ -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.*
+ src/Config.hs view
@@ -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>", stdin)+ , cout = ("<stdout>", 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 /= "<stdout>" 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
+ src/ER.hs view
@@ -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
+ src/Parse.hs view
@@ -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'+