packages feed

erd 0.1.3.0 → 0.2.0.0

raw patch · 13 files changed

+1053/−652 lines, 13 filesdep +QuickCheckdep +hspecdep +raw-strings-qqdep ~basenew-uploader

Dependencies added: QuickCheck, hspec, raw-strings-qq, tasty, tasty-hunit

Dependency ranges changed: base

Files

+ app/Main.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Control.Applicative ((<|>))+import Control.Monad (forM_, guard)+import qualified Data.ByteString as SB+import Data.Maybe (fromMaybe)+import qualified Data.Text.Lazy as L+import System.Exit (exitFailure)+import System.IO (hClose, hPutStrLn, stderr)+import Text.Printf (printf)++import Data.GraphViz+import qualified Data.GraphViz.Attributes.Colors.X11 as C+import qualified Data.GraphViz.Attributes.Complete as A+import qualified Data.GraphViz.Attributes.HTML as H+import qualified Data.GraphViz.Types.Generalised as G+import Data.GraphViz.Types.Monadic+import Data.GraphViz.Commands (isGraphvizInstalled)++import qualified Erd.ER as ER++import Erd.Config+import Erd.ER+import Erd.Parse++main :: IO ()+main = do+  checkRequirements -- application may terminate here+  conf <- configIO+  er' <- uncurry loadER (cin conf)+  case er' of+    Left err -> do+      hPutStrLn stderr err+      exitFailure+    Right er -> let dotted = dotER conf er+                    toFile h = SB.hGetContents h >>= SB.hPut (snd $ cout conf)+                    fmt = fromMaybe Pdf (outfmt conf)+                 in graphvizWithHandle Dot dotted fmt toFile+  hClose (snd $ cin conf)+  hClose (snd $ cout conf)++-- | Converts an entire ER-diagram from an ER file into a GraphViz graph.+dotER :: Config -> ER -> G.DotGraph L.Text+dotER conf er = graph' $ do+  graphAttrs (graphTitle $ title er)+  graphAttrs [ A.RankDir A.FromLeft+             , A.Splines (edgeType conf)+             ]+  nodeAttrs [shape PlainText] -- recommended for HTML labels+  edgeAttrs [ A.Color [A.toWC $ A.toColor C.Gray50] -- easier to read labels+            , A.MinLen 2 -- give some breathing room+            , A.Style [A.SItem A.Dashed []] -- easier to read labels, maybe?+            ]+  forM_ (entities er) $ \e ->+    node (name e) [toLabel (htmlEntity e)]+  forM_ (rels er) $ \r -> do+    let opts = roptions r+    let rlab = A.HtmlLabel . H.Text . htmlFont opts . L.pack . show+    let (l1, l2) = (A.TailLabel $ rlab $ card1 r, A.HeadLabel $ rlab $ card2 r)+    let label = A.Label $ A.HtmlLabel $ H.Text $ withLabelFmt " %s " opts []+    edge (entity1 r) (entity2 r) [label, l1, l2]++-- | Converts a single entity to an HTML label.+htmlEntity :: Entity -> H.Label+htmlEntity e = H.Table H.HTable+                 { H.tableFontAttrs = Just $ optionsTo optToFont $ eoptions e+                 , H.tableAttrs = optionsTo optToHtml (eoptions e)+                 , H.tableRows = rows+                 }+  where rows = headerRow : map htmlAttr (attribs e)+        headerRow = H.Cells [H.LabelCell [] $ H.Text text]+        text = withLabelFmt " [%s]" (hoptions e) $ bold hname+        hname = htmlFont (hoptions e) (name e)+        bold s = [H.Format H.Bold s]++-- | Converts a single attribute to an HTML table row.+htmlAttr :: ER.Attribute -> H.Row+htmlAttr a = H.Cells [cell]+  where cell = H.LabelCell cellAttrs (H.Text $ withLabelFmt " [%s]" opts name)+        name = fkfmt $ pkfmt $ htmlFont opts (field a)+        pkfmt s = if pk a then [H.Format H.Underline s] else s+        fkfmt s = if fk a then [H.Format H.Italics s] else s+        cellAttrs = H.Align H.HLeft : optionsTo optToHtml opts+        opts = aoptions a++-- | Formats HTML text with a label. The format string given should be+-- in `Data.Text.printf` style. (Only font options are used from the options+-- given.)+withLabelFmt :: String -> Options -> H.Text -> H.Text+withLabelFmt fmt opts s =+  case optionsTo optToLabel opts of+    (x:_) -> s ++ htmlFont opts (L.pack $ printf fmt $ L.unpack x)+    _ -> s++-- | Formats an arbitrary string with the options given (using only font+-- attributes).+htmlFont :: Options -> L.Text -> H.Text+htmlFont opts s = [H.Font (optionsTo optToFont opts) [H.Str s]]++-- | Extracts and formats a graph title from the options given.+-- The options should be title options from an ER value.+-- If a title does not exist, an empty list is returned and `graphAttrs attrs`+-- should be a no-op.+graphTitle :: Options -> [A.Attribute]+graphTitle topts =+  let glabel = optionsTo optToLabel topts+  in if null glabel then [] else+       [ A.LabelJust A.JLeft+       , A.LabelLoc A.VTop+       , A.Label $ A.HtmlLabel $ H.Text $ htmlFont topts (head glabel)+       ]++checkRequirements :: IO ()+checkRequirements = (isGraphvizInstalled >>= guard) <|> quitWithoutGraphviz msg+  where+    msg = "GraphViz is not installed on your system.\n" +++          "Please install it first, https://github.com/BurntSushi/erd"
+ changelog.md view
@@ -0,0 +1,16 @@+0.2.0.0++* Adding test suite. (PR #46)++* Adding TravisCI script. (PR #46)++* Not falling to *bottom* when GraphViz does not exists on the host system. (PR #45)++* Supporting to build with *stack* and/or *cabal*. (PR #43, PR #18)++* Adding optional -e command-line argument to determine the type of edges+  between nodes/tables. (PR #13)++* Allow spaces in table identifiers, quoted with backticks. (PR #9)++0.1.3.0
erd.cabal view
@@ -1,8 +1,8 @@--- Initial erd.cabal generated by cabal init.  For further documentation, +-- Initial erd.cabal generated by cabal init.  For further documentation, -- see http://haskell.org/cabal/users-guide/  name:                erd-version:             0.1.3.0+version:             0.2.0.0 homepage:            https://github.com/BurntSushi/erd license:             PublicDomain license-file:        UNLICENSE@@ -13,15 +13,15 @@ cabal-version:       >=1.8 synopsis:   An entity-relationship diagram generator from a plain text description.-description:         -  erd transforms a plain text description of a relational database schema to a +description:+  erd transforms a plain text description of a relational database schema to a   graphical representation of that schema. It is intended that the graph make   use of common conventions when depicting entity-relationship diagrams,   including modeling the cardinality of relationships between entities.   .   A quick example that transforms an `er` file to a PDF:   .-  > $ curl 'https://raw.github.com/BurntSushi/erd/master/examples/simple.er' > simple.er+  > $ curl 'https://raw.githubusercontent.com/BurntSushi/erd/master/examples/simple.er' > simple.er   > $ cat simple.er   > # Entities are declared in '[' ... ']'. All attributes after the entity header   > # up until the end of the file (or the next entity declaration) correspond@@ -31,13 +31,13 @@   > height   > weight   > +birth_location_id-  > +  >   > [Location]   > *id   > city   > state   > country-  > +  >   > # Each relationship must be between exactly two entities, which need not   > # be distinct. Each entity in the relationship has exactly one of four   > # possible cardinalities:@@ -54,22 +54,54 @@   .   <<http://burntsushi.net/stuff/erd-example-simple.png>>   .-  See the <https://github.com/BurntSushi/erd#readme README.md> file for more +  See the <https://github.com/BurntSushi/erd#readme README.md> file for more   examples and instructions on how to write ER files. +extra-source-files:+    changelog.md+ source-repository head   type: git   location: git://github.com/BurntSushi/erd.git  executable erd-  hs-source-dirs: src+  hs-source-dirs: app, src+  other-modules:+      Erd.Config+      Erd.ER+      Erd.Parse+      Text.Parsec.Erd.Parser   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.7.*+      base >=4.5 && <5+      , graphviz == 2999.*+      , text == 1.*+      , parsec == 3.1.*+      , containers == 0.5.*+      , bytestring == 0.10.*++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind+  hs-source-dirs:+      test, src+  other-modules:+      Erd.Config+      Erd.ER+      Erd.Parse+      Text.Parsec.Erd.Parser+      Test.Text.Parsec.Erd.Parser+  build-depends:+      QuickCheck+    , hspec+    , base >=4.5 && <5     , graphviz == 2999.*     , text == 1.*     , parsec == 3.1.*     , containers == 0.5.*     , bytestring == 0.10.*+    , tasty >= 0.11+    , tasty-hunit >= 0.9+    , raw-strings-qq >= 1.1
− src/Config.hs 
@@ -1,135 +0,0 @@-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 ()-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 
@@ -1,193 +0,0 @@-{-# 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/Erd/Config.hs view
@@ -0,0 +1,164 @@+module Erd.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+import qualified Data.GraphViz.Attributes.Complete as A++-- | Config represents all information from command line flags.+data Config =+  Config { cin :: (String, Handle)+         , cout :: (String, Handle)+         , outfmt :: Maybe G.GraphvizOutput+         , edgeType :: A.EdgeType+         }++defaultConfig :: Config+defaultConfig =+  Config { cin = ("<stdin>", stdin)+         , cout = ("<stdout>", stdout)+         , outfmt = Nothing+         , edgeType = A.SplineEdges+         }++-- | 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))+  , O.Option "e" ["edge"]+      (O.ReqArg (\edge cIO -> do+                    c <- cIO+                    let edgeG = toEdgeG edge+                    case edgeG of+                      Nothing -> do+                        ef "'%s' is not a valid type of edge." edge+                        exitFailure+                      Just edgeType ->+                        return $ c { edgeType = edgeType }+                )+                "EDGE")+      (printf "Select one type of edge:\n%s"+              (intercalate ", " $ M.keys edges))+  ]++-- | 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)+  ]++edges :: M.Map String (Maybe A.EdgeType)+edges = M.fromList+  [ ("spline", Just A.SplineEdges)+  , ("ortho", Just A.Ortho)+  , ("noedge", Just A.NoEdges)+  , ("poly", Just A.PolyLine)+  , ("compound", Just A.CompoundEdge)+  ]++-- | 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++toEdgeG :: String -> Maybe A.EdgeType+toEdgeG edge = M.findWithDefault Nothing edge edges++usageExit :: IO a+usageExit = usage >> exitFailure++usage :: IO ()+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/Erd/ER.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE OverloadedStrings #-}+module Erd.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, Eq)++-- | Represents a single entity in a schema.+data Entity = Entity { name :: Text+                     , attribs :: [Attribute]+                     , hoptions :: Options+                     , eoptions :: Options+                     }+              deriving (Show, Eq)++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, Eq)++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, Eq)++-- | 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, Eq)++data Cardinality = ZeroOne+                 | One+                 | ZeroPlus+                 | OnePlus deriving (Eq)++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", 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/Erd/Parse.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}+module Erd.Parse+  ( loadER+  )+where++import Control.Monad (when)+import Data.List (find)+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.Printf (printf)+import Text.Parsec.Erd.Parser (AST(..), GlobalOptions(..), document)++import Erd.ER++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
− src/Main.hs 
@@ -1,105 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Main (main) where--import Control.Monad (forM_)-import qualified Data.ByteString as SB-import Data.Maybe (fromMaybe)-import qualified Data.Text.Lazy as L-import System.Exit (exitFailure)-import System.IO (hClose, hPutStrLn, stderr)-import Text.Printf (printf)--import Data.GraphViz-import qualified Data.GraphViz.Attributes.Colors.X11 as C-import qualified Data.GraphViz.Attributes.Complete as A-import qualified Data.GraphViz.Attributes.HTML as H-import qualified Data.GraphViz.Types.Generalised as G-import Data.GraphViz.Types.Monadic--import Config-import ER-import Parse--main :: IO ()-main = do-  conf <- configIO-  er' <- uncurry loadER (cin conf)-  case er' of-    Left err -> do-      hPutStrLn stderr err-      exitFailure-    Right er -> let dotted = dotER er-                    toFile h = SB.hGetContents h >>= SB.hPut (snd $ cout conf)-                    fmt = fromMaybe Pdf (outfmt conf)-                 in graphvizWithHandle Dot dotted fmt toFile-  hClose (snd $ cin conf)-  hClose (snd $ cout conf)---- | Converts an entire ER-diagram from an ER file into a GraphViz graph.-dotER :: ER -> G.DotGraph L.Text-dotER er = graph' $ do-  graphAttrs (graphTitle $ title er)-  graphAttrs [A.RankDir A.FromLeft]-  nodeAttrs [shape PlainText] -- recommended for HTML labels-  edgeAttrs [ A.Color [A.toWC $ A.toColor C.Gray50] -- easier to read labels-            , A.MinLen 2 -- give some breathing room-            , A.Style [A.SItem A.Dashed []] -- easier to read labels, maybe?-            ]-  forM_ (entities er) $ \e ->-    node (name e) [toLabel (htmlEntity e)]-  forM_ (rels er) $ \r -> do-    let opts = roptions r-    let rlab = A.HtmlLabel . H.Text . htmlFont opts . L.pack . show-    let (l1, l2) = (A.TailLabel $ rlab $ card1 r, A.HeadLabel $ rlab $ card2 r)-    let label = A.Label $ A.HtmlLabel $ H.Text $ withLabelFmt " %s " opts []-    edge (entity1 r) (entity2 r) [label, l1, l2]---- | Converts a single entity to an HTML label.-htmlEntity :: Entity -> H.Label-htmlEntity e = H.Table H.HTable-                 { H.tableFontAttrs = Just $ optionsTo optToFont $ eoptions e-                 , H.tableAttrs = optionsTo optToHtml (eoptions e)-                 , H.tableRows = rows-                 }-  where rows = headerRow : map htmlAttr (attribs e)-        headerRow = H.Cells [H.LabelCell [] $ H.Text text]-        text = withLabelFmt " [%s]" (hoptions e) $ bold hname-        hname = htmlFont (hoptions e) (name e)-        bold s = [H.Format H.Bold s]---- | Converts a single attribute to an HTML table row.-htmlAttr :: ER.Attribute -> H.Row-htmlAttr a = H.Cells [cell]-  where cell = H.LabelCell cellAttrs (H.Text $ withLabelFmt " [%s]" opts name)-        name = fkfmt $ pkfmt $ htmlFont opts (field a)-        pkfmt s = if pk a then [H.Format H.Underline s] else s-        fkfmt s = if fk a then [H.Format H.Italics s] else s-        cellAttrs = H.Align H.HLeft : optionsTo optToHtml opts-        opts = aoptions a---- | Formats HTML text with a label. The format string given should be--- in `Data.Text.printf` style. (Only font options are used from the options--- given.)-withLabelFmt :: String -> Options -> H.Text -> H.Text-withLabelFmt fmt opts s =-  case optionsTo optToLabel opts of-    (x:_) -> s ++ htmlFont opts (L.pack $ printf fmt $ L.unpack x)-    _ -> s---- | Formats an arbitrary string with the options given (using only font--- attributes).-htmlFont :: Options -> L.Text -> H.Text-htmlFont opts s = [H.Font (optionsTo optToFont opts) [H.Str s]]---- | Extracts and formats a graph title from the options given.--- The options should be title options from an ER value.--- If a title does not exist, an empty list is returned and `graphAttrs attrs`--- should be a no-op.-graphTitle :: Options -> [A.Attribute]-graphTitle topts =-  let glabel = optionsTo optToLabel topts-  in if null glabel then [] else-       [ A.LabelJust A.JLeft-       , A.LabelLoc A.VTop-       , A.Label $ A.HtmlLabel $ H.Text $ htmlFont topts (head glabel)-       ]
− src/Parse.hs 
@@ -1,208 +0,0 @@-{-# 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 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-  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'-
+ src/Text/Parsec/Erd/Parser.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.Parsec.Erd.Parser+  (+    AST(..),+    GlobalOptions(..),+    document,+    globalOptions,+    entity,+    rel,+    attr,+    comment,+  )+where++import Control.Monad (liftM2, when, void)+import Data.Char (isAlphaNum, isSpace, isControl)+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)++import Erd.ER++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") -- 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 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+  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+  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'+
+ test/Spec.hs view
@@ -0,0 +1,9 @@+module Main (main) where+import Test.Tasty+import Test.Text.Parsec.Erd.Parser (testEr)++main :: IO ()+main = defaultMain $ testGroup "Erd Tests"  tests++tests :: [TestTree]+tests = [testEr]
+ test/Test/Text/Parsec/Erd/Parser.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Test.Text.Parsec.Erd.Parser+  (testEr)+  where+import Test.Tasty+import Test.Tasty.HUnit+import Text.RawString.QQ (r)+import Data.Text  (Text)+import Data.Text.Lazy (fromStrict)+import Text.Parsec (parse)+import qualified Data.Map as M+import Data.Map (fromList)+import Erd.ER+import Text.Parsec.Erd.Parser (document, AST(..), GlobalOptions(..))+import Data.GraphViz.Attributes.Colors (Color(..))++parseDoc :: Text -> (GlobalOptions, [AST]) -> Assertion+parseDoc input expect= Right expect `shouldBe` parse document "" (fromStrict input) where+  shouldBe = assertEqual ""++testEr :: TestTree+testEr = testGroup "Parse Er" [+  testCase "Parse Simple case" $ parseDoc simpleText simpleResult,+  testCase "Parse nfldb case" $ parseDoc nfldbText nfldbResult+                              ]+++simpleText :: Text+simpleText = [r|+# Entities are declared in '[' ... ']'. All attributes after the entity header+# up until the end of the file (or the next entity declaration) correspond+# to this entity.+[Person]+*name+height+weight+`birth date`++birth_place_id++[`Birth Place`]+*id+`birth city`+'birth state'+"birth country"++# Each relationship must be between exactly two entities, which need not+# be distinct. Each entity in the relationship has exactly one of four+# possible cardinalities:+#+# Cardinality    Syntax+# 0 or 1         ?+# exactly 1      1+# 0 or more      *+# 1 or more      ++Person *--1 `Birth Place`+|]++simpleResult :: (GlobalOptions, [AST])+simpleResult = (opts, asts) where+  opts = GlobalOptions M.empty M.empty M.empty M.empty+  asts = [+    E (Entity {name = "Person", attribs = [], hoptions = fromList [], eoptions = fromList []}),+    A (Attribute {field = "name", pk = True, fk = False, aoptions = fromList []}),+    A (Attribute {field = "height", pk = False, fk = False, aoptions = fromList []}),+    A (Attribute {field = "weight", pk = False, fk = False, aoptions = fromList []}),+    A (Attribute {field = "birth date", pk = False, fk = False, aoptions = fromList []}),+    A (Attribute {field = "birth_place_id", pk = False, fk = True, aoptions = fromList []}),+    E (Entity {name = "Birth Place", attribs = [], hoptions = fromList [], eoptions = fromList []}),+    A (Attribute {field = "id", pk = True, fk = False, aoptions = fromList []}),+    A (Attribute {field = "birth city", pk = False, fk = False, aoptions = fromList []}),+    A (Attribute {field = "birth state", pk = False, fk = False, aoptions = fromList []}),+    A (Attribute {field = "birth country", pk = False, fk = False, aoptions = fromList []}),+    R (Relation {entity1 = "Person", entity2 = "Birth Place", card1 = ZeroPlus , card2 = One, roptions = fromList []})]++nfldbText :: Text+nfldbText = [r|+title {label: "nfldb Entity-Relationship diagram (condensed)", size: "20"}++# Nice colors from Erwiz:+# red #fcecec+# blue #ececfc+# green #d0e0d0+# yellow #fbfbdb+# orange #eee0a0++# Entities++[player] {bgcolor: "#d0e0d0"}+  *player_id {label: "varchar, not null"}+  full_name {label: "varchar, null"}+  team {label: "varchar, not null"}+  position {label: "player_pos, not null"}+  status {label: "player_status, not null"}++[team] {bgcolor: "#d0e0d0"}+  *team_id {label: "varchar, not null"}+  city {label: "varchar, not null"}+  name {label: "varchar, not null"}++[game] {bgcolor: "#ececfc"}+  *gsis_id {label: "gameid, not null"}+  start_time {label: "utctime, not null"}+  week {label: "usmallint, not null"}+  season_year {label: "usmallint, not null"}+  season_type {label: "season_phase, not null"}+  finished {label: "boolean, not null"}+  home_team {label: "varchar, not null"}+  home_score {label: "usmallint, not null"}+  away_team {label: "varchar, not null"}+  away_score {label: "usmallint, not null"}++[drive] {bgcolor: "#ececfc"}+  *+gsis_id {label: "gameid, not null"}+  *drive_id {label: "usmallint, not null"}+  start_field {label: "field_pos, null"}+  start_time {label: "game_time, not null"}+  end_field {label: "field_pos, null"}+  end_time {label: "game_time, not null"}+  pos_team {label: "varchar, not null"}+  pos_time {label: "pos_period, null"}++[play] {bgcolor: "#ececfc"}+  *+gsis_id {label: "gameid, not null"}+  *+drive_id {label: "usmallint, not null"}+  *play_id {label: "usmallint, not null"}+  time {label: "game_time, not null"}+  pos_team {label: "varchar, not null"}+  yardline {label: "field_pos, null"}+  down {label: "smallint, null"}+  yards_to_go {label: "smallint, null"}++[play_player] {bgcolor: "#ececfc"}+  *+gsis_id {label: "gameid, not null"}+  *+drive_id {label: "usmallint, not null"}+  *+play_id {label: "usmallint, not null"}+  *+player_id {label: "varchar, not null"}+  team {label: "varchar, not null"}++[meta] {bgcolor: "#fcecec"}+  version {label: "smallint, null"}+  season_type {label: "season_phase, null"}+  season_year {label: "usmallint, null"}+  week {label: "usmallint, null"}++# Relationships++player      *--1 team+game        *--1 team {label: "home"}+game        *--1 team {label: "away"}+drive       *--1 team+play        *--1 team+play_player *--1 team++game        1--* drive+game        1--* play+game        1--* play_player++drive       1--* play+drive       1--* play_player++play        1--* play_player++player      1--* play_player+|]+++data ChunckAST = CE [Entity] | CA [Attribute] | CR [Relation] deriving (Eq)+toAST :: ChunckAST -> [AST]+toAST (CE x) = map E x+toAST (CA x) = map A x+toAST (CR x) = map R x++nfldbResult :: (GlobalOptions, [AST])+nfldbResult = (opts, asts) where+  opts = GlobalOptions {gtoptions = fromList [("label",Label "nfldb Entity-Relationship diagram (condensed)"),("size",FontSize 20.0)], ghoptions = fromList [], geoptions = fromList [], groptions = fromList []}+  asts = concatMap toAST $ entities:(attributes ++ [relations])+  entities = CE [+    Entity {name = "player", attribs = [],+      hoptions = fromList [("bgcolor",BgColor (RGB {red = 208, green = 224, blue = 208}))],+      eoptions = fromList [("bgcolor",BgColor (RGB {red = 208, green = 224, blue = 208}))]+           }+    ]+  attributes = [+    CA [+        Attribute {field = "player_id", pk = True, fk = False, aoptions = fromList [("label",Label "varchar, not null")]},+        Attribute {field = "full_name", pk = False, fk = False, aoptions = fromList [("label",Label "varchar, null")]},+        Attribute {field = "team", pk = False, fk = False, aoptions = fromList [("label",Label "varchar, not null")]},+        Attribute {field = "position", pk = False, fk = False, aoptions = fromList [("label",Label "player_pos, not null")]},+        Attribute {field = "status", pk = False, fk = False, aoptions = fromList [("label",Label "player_status, not null")]}+      ],+    CE [+        Entity {name = "team", attribs = [], hoptions = fromList [("bgcolor",BgColor (RGB {red = 208, green = 224, blue = 208}))], eoptions = fromList [("bgcolor",BgColor (RGB {red = 208, green = 224, blue = 208}))]}+      ],+    CA [+        Attribute {field = "team_id", pk = True, fk = False, aoptions = fromList [("label",Label "varchar, not null")]},+        Attribute {field = "city", pk = False, fk = False, aoptions = fromList [("label",Label "varchar, not null")]},+        Attribute {field = "name", pk = False, fk = False, aoptions = fromList [("label",Label "varchar, not null")]}+      ],+    CE [+        Entity {name = "game", attribs = [], hoptions = fromList [("bgcolor",BgColor (RGB {red = 236, green = 236, blue = 252}))], eoptions = fromList [("bgcolor",BgColor (RGB {red = 236, green = 236, blue = 252}))]}+      ],+    CA [+        Attribute {field = "gsis_id", pk = True, fk = False, aoptions = fromList [("label",Label "gameid, not null")]},+        Attribute {field = "start_time", pk = False, fk = False, aoptions = fromList [("label",Label "utctime, not null")]},+        Attribute {field = "week", pk = False, fk = False, aoptions = fromList [("label",Label "usmallint, not null")]},+        Attribute {field = "season_year", pk = False, fk = False, aoptions = fromList [("label",Label "usmallint, not null")]},+        Attribute {field = "season_type", pk = False, fk = False, aoptions = fromList [("label",Label "season_phase, not null")]},+        Attribute {field = "finished", pk = False, fk = False, aoptions = fromList [("label",Label "boolean, not null")]},+        Attribute {field = "home_team", pk = False, fk = False, aoptions = fromList [("label",Label "varchar, not null")]},+        Attribute {field = "home_score", pk = False, fk = False, aoptions = fromList [("label",Label "usmallint, not null")]},+        Attribute {field = "away_team", pk = False, fk = False, aoptions = fromList [("label",Label "varchar, not null")]},+        Attribute {field = "away_score", pk = False, fk = False, aoptions = fromList [("label",Label "usmallint, not null")]}+      ],+    CE [+        Entity {name = "drive", attribs = [], hoptions = fromList [("bgcolor",BgColor (RGB {red = 236, green = 236, blue = 252}))], eoptions = fromList [("bgcolor",BgColor (RGB {red = 236, green = 236, blue = 252}))]}+      ],+    CA [+        Attribute {field = "gsis_id", pk = True, fk = True, aoptions = fromList [("label",Label "gameid, not null")]},+        Attribute {field = "drive_id", pk = True, fk = False, aoptions = fromList [("label",Label "usmallint, not null")]},+        Attribute {field = "start_field", pk = False, fk = False, aoptions = fromList [("label",Label "field_pos, null")]},+        Attribute {field = "start_time", pk = False, fk = False, aoptions = fromList [("label",Label "game_time, not null")]},+        Attribute {field = "end_field", pk = False, fk = False, aoptions = fromList [("label",Label "field_pos, null")]},+        Attribute {field = "end_time", pk = False, fk = False, aoptions = fromList [("label",Label "game_time, not null")]},+        Attribute {field = "pos_team", pk = False, fk = False, aoptions = fromList [("label",Label "varchar, not null")]},+        Attribute {field = "pos_time", pk = False, fk = False, aoptions = fromList [("label",Label "pos_period, null")]}+      ],+    CE [+        Entity {name = "play", attribs = [], hoptions = fromList [("bgcolor",BgColor (RGB {red = 236, green = 236, blue = 252}))], eoptions = fromList [("bgcolor",BgColor (RGB {red = 236, green = 236, blue = 252}))]}+      ],+    CA [+        Attribute {field = "gsis_id", pk = True, fk = True, aoptions = fromList [("label",Label "gameid, not null")]},+        Attribute {field = "drive_id", pk = True, fk = True, aoptions = fromList [("label",Label "usmallint, not null")]},+        Attribute {field = "play_id", pk = True, fk = False, aoptions = fromList [("label",Label "usmallint, not null")]},+        Attribute {field = "time", pk = False, fk = False, aoptions = fromList [("label",Label "game_time, not null")]},+        Attribute {field = "pos_team", pk = False, fk = False, aoptions = fromList [("label",Label "varchar, not null")]},+        Attribute {field = "yardline", pk = False, fk = False, aoptions = fromList [("label",Label "field_pos, null")]},+        Attribute {field = "down", pk = False, fk = False, aoptions = fromList [("label",Label "smallint, null")]},+        Attribute {field = "yards_to_go", pk = False, fk = False, aoptions = fromList [("label",Label "smallint, null")]}+      ],+    CE [+        Entity {name = "play_player", attribs = [], hoptions = fromList [("bgcolor",BgColor (RGB {red = 236, green = 236, blue = 252}))], eoptions = fromList [("bgcolor",BgColor (RGB {red = 236, green = 236, blue = 252}))]}+      ],+    CA [+        Attribute {field = "gsis_id", pk = True, fk = True, aoptions = fromList [("label",Label "gameid, not null")]},+        Attribute {field = "drive_id", pk = True, fk = True, aoptions = fromList [("label",Label "usmallint, not null")]},+        Attribute {field = "play_id", pk = True, fk = True, aoptions = fromList [("label",Label "usmallint, not null")]},+        Attribute {field = "player_id", pk = True, fk = True, aoptions = fromList [("label",Label "varchar, not null")]},+        Attribute {field = "team", pk = False, fk = False, aoptions = fromList [("label",Label "varchar, not null")]}+     ],+     CE [+        Entity {name = "meta", attribs = [], hoptions = fromList [("bgcolor",BgColor (RGB {red = 252, green = 236, blue = 236}))], eoptions = fromList [("bgcolor",BgColor (RGB {red = 252, green = 236, blue = 236}))]}+       ],+    CA [+        Attribute {field = "version", pk = False, fk = False, aoptions = fromList [("label",Label "smallint, null")]},+        Attribute {field = "season_type", pk = False, fk = False, aoptions = fromList [("label",Label "season_phase, null")]},+        Attribute {field = "season_year", pk = False, fk = False, aoptions = fromList [("label",Label "usmallint, null")]},+        Attribute {field = "week", pk = False, fk = False, aoptions = fromList [("label",Label "usmallint, null")]}+      ]+    ]+  relations = CR [+     Relation {entity1 = "player", entity2 = "team", card1 = ZeroPlus, card2 = One, roptions = fromList []},+     Relation {entity1 = "game", entity2 = "team", card1 = ZeroPlus, card2 = One, roptions = fromList [("label",Label "home")]},+     Relation {entity1 = "game", entity2 = "team", card1 = ZeroPlus, card2 = One, roptions = fromList [("label",Label "away")]},+     Relation {entity1 = "drive", entity2 = "team", card1 = ZeroPlus, card2 = One, roptions = fromList []},+     Relation {entity1 = "play", entity2 = "team", card1 = ZeroPlus, card2 = One, roptions = fromList []},+     Relation {entity1 = "play_player", entity2 = "team", card1 = ZeroPlus, card2 = One, roptions = fromList []},+     Relation {entity1 = "game", entity2 = "drive", card1 = One, card2 = ZeroPlus, roptions = fromList []},+     Relation {entity1 = "game", entity2 = "play", card1 = One, card2 = ZeroPlus, roptions = fromList []},+     Relation {entity1 = "game", entity2 = "play_player", card1 = One, card2 = ZeroPlus, roptions = fromList []},+     Relation {entity1 = "drive", entity2 = "play", card1 = One, card2 = ZeroPlus, roptions = fromList []},+     Relation {entity1 = "drive", entity2 = "play_player", card1 = One, card2 = ZeroPlus, roptions = fromList []},+     Relation {entity1 = "play", entity2 = "play_player", card1 = One, card2 = ZeroPlus, roptions = fromList []},+     Relation {entity1 = "player", entity2 = "play_player", card1 = One, card2 = ZeroPlus, roptions = fromList []}+               ]