language-dot (empty) → 0.0.1
raw patch · 8 files changed
+980/−0 lines, 8 filesdep +basedep +mtldep +parsecbuild-type:Customsetup-changed
Dependencies added: base, mtl, parsec, pretty
Files
- Setup.hs +12/−0
- language-dot.cabal +57/−0
- src/Language/Dot.hs +10/−0
- src/Language/Dot/Parser.hs +485/−0
- src/Language/Dot/Pretty.hs +131/−0
- src/Language/Dot/Syntax.hs +92/−0
- src/ppdot.hs +73/−0
- src/test.hs +120/−0
+ Setup.hs view
@@ -0,0 +1,12 @@+module Main where++import Distribution.Simple (defaultMainWithHooks, simpleUserHooks, runTests)+import System.Process (system)++main :: IO ()+main =+ defaultMainWithHooks $ simpleUserHooks { runTests = runTests' }+ where+ runTests' _ _ _ _ = do+ system "runhaskell -DTEST -i./src src/test.hs"+ return ()
+ language-dot.cabal view
@@ -0,0 +1,57 @@+name: language-dot+version: 0.0.1+category: Language+synopsis: A library for the analysis and creation of Graphviz DOT files+description: A library for the analysis and creation of Graphviz DOT files.+author: Brian Lewis <brian@lorf.org>+maintainer: Brian Lewis <brian@lorf.org>+license: PublicDomain++cabal-version: >= 1.6+build-type: Custom++extra-source-files:+ src/test.hs++flag executable+ description: Build the `ppdot' executable.+ default: True++library+ hs-source-dirs:+ src++ exposed-modules:+ Language.Dot+ Language.Dot.Parser+ Language.Dot.Pretty+ Language.Dot.Syntax++ build-depends:+ base == 4.*,+ mtl == 1.*,+ parsec == 3.*,+ pretty == 1.*++ ghc-options: -Wall+ if impl(ghc >= 6.8)+ ghc-options: -fwarn-tabs++executable ppdot+ if flag(executable)+ buildable: True+ else+ buildable: False++ hs-source-dirs:+ src++ main-is: ppdot.hs++ ghc-options: -Wall+ if impl(ghc >= 6.8)+ ghc-options: -fwarn-tabs++source-repository head+ type: git+ location: git://github.com/bsl/language-dot.git
+ src/Language/Dot.hs view
@@ -0,0 +1,10 @@+module Language.Dot+ ( module Language.Dot.Parser+ , module Language.Dot.Pretty+ , module Language.Dot.Syntax+ )+ where++import Language.Dot.Parser+import Language.Dot.Pretty+import Language.Dot.Syntax
+ src/Language/Dot/Parser.hs view
@@ -0,0 +1,485 @@+{-# LANGUAGE CPP #-}++module Language.Dot.Parser+ ( parseDot+#ifdef TEST+ , parsePort+ , parseCompass+ , parseAttribute+ , parseId+#endif+ )+ where++import Control.Applicative ((<$>), (<*>), (<*), (*>))+import Control.Monad (when)+import Data.Char (digitToInt, toLower)+import Data.List (foldl')+import Data.Maybe (fromJust, fromMaybe, isJust)+import Numeric (readFloat)++import Text.Parsec+import Text.Parsec.Char+import Text.Parsec.Combinator+import Text.Parsec.Language+import Text.Parsec.String+import Text.Parsec.Token++import Language.Dot.Syntax++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parseDot :: String -> String -> Either ParseError Graph+parseDot source =+ parse (whiteSpace' >> parseGraph) source . preprocess++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++preprocess :: String -> String+preprocess =+ unlines . map commentPoundLines . lines+ where+ commentPoundLines [] = []+ commentPoundLines line@(c:_) = if c == '#' then "// " ++ line else line++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parseGraph :: Parser Graph+parseGraph =+ ( Graph <$>+ parseGraphStrictness+ <*> parseGraphDirectedness+ <*> optionMaybe parseId+ <*> parseStatementList+ )+ <?> "graph"++parseGraphStrictness :: Parser GraphStrictness+parseGraphStrictness =+ ((reserved' "strict" >> return StrictGraph) <|> return UnstrictGraph)+ <?> "graph strictness"++parseGraphDirectedness :: Parser GraphDirectedness+parseGraphDirectedness =+ ( (reserved' "graph" >> return UndirectedGraph)+ <|> (reserved' "digraph" >> return DirectedGraph)+ )+ <?> "graph directedness"++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parseStatementList :: Parser [Statement]+parseStatementList =+ braces' (parseStatement `endBy` optional semi')+ <?> "statement list"++parseStatement :: Parser Statement+parseStatement =+ ( try parseEdgeStatement+ <|> try parseAttributeStatement+ <|> try parseAssignmentStatement+ <|> try parseSubgraphStatement+ <|> parseNodeStatement+ )+ <?> "statement"++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parseNodeStatement :: Parser Statement+parseNodeStatement =+ ( NodeStatement <$>+ parseNodeId <*> parseAttributeList+ )+ <?> "node statement"++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parseEdgeStatement :: Parser Statement+parseEdgeStatement =+ ( EdgeStatement <$>+ parseEntityList <*> parseAttributeList+ )+ <?> "edge statement"++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parseAttributeStatement :: Parser Statement+parseAttributeStatement =+ ( AttributeStatement <$>+ parseAttributeStatementType <*> parseAttributeList+ )+ <?> "attribute statement"++parseAttributeStatementType :: Parser AttributeStatementType+parseAttributeStatementType =+ ( (reserved' "graph" >> return GraphAttributeStatement)+ <|> (reserved' "node" >> return NodeAttributeStatement)+ <|> (reserved' "edge" >> return EdgeAttributeStatement)+ )+ <?> "attribute statement type"++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parseAssignmentStatement :: Parser Statement+parseAssignmentStatement =+ ( AssignmentStatement <$>+ parseId <*> (reservedOp' "=" *> parseId)+ )+ <?> "assignment statement"++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parseSubgraphStatement :: Parser Statement+parseSubgraphStatement =+ ( SubgraphStatement <$>+ parseSubgraph+ )+ <?> "subgraph statement"++parseSubgraph :: Parser Subgraph+parseSubgraph =+ ( try parseNewSubgraph+ <|> parseSubgraphRef+ )+ <?> "subgraph"++parseNewSubgraph :: Parser Subgraph+parseNewSubgraph =+ ( NewSubgraph <$>+ (optional (reserved' "subgraph") *> optionMaybe parseId) <*> parseStatementList+ )+ <?> "new subgraph"++parseSubgraphRef :: Parser Subgraph+parseSubgraphRef =+ ( SubgraphRef <$>+ (reserved' "subgraph" *> parseId)+ )+ <?> "subgraph ref"++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parseEntityList :: Parser [Entity]+parseEntityList =+ ( (:) <$>+ parseEntity True <*> many1 (parseEntity False)+ )+ <?> "entity list"++parseEntity :: Bool -> Parser Entity+parseEntity first =+ ( try (parseENodeId first)+ <|> parseESubgraph first+ )+ <?> "entity"++parseENodeId :: Bool -> Parser Entity+parseENodeId first =+ ( ENodeId <$>+ (if first then return NoEdge else parseEdgeType) <*> parseNodeId+ )+ <?> "entity node id"++parseESubgraph :: Bool -> Parser Entity+parseESubgraph first =+ ( ESubgraph <$>+ (if first then return NoEdge else parseEdgeType) <*> parseSubgraph+ )+ <?> "entity subgraph"++parseEdgeType :: Parser EdgeType+parseEdgeType =+ ( try (reservedOp' "->" >> return DirectedEdge)+ <|> (reservedOp' "--" >> return UndirectedEdge)+ )+ <?> "edge operator"++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parseNodeId :: Parser NodeId+parseNodeId =+ ( NodeId <$>+ parseId <*> optionMaybe parsePort+ )+ <?> "node id"++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parsePort :: Parser Port+parsePort =+ ( try parsePortC+ <|> parsePortI+ )+ <?> "port"++parsePortC :: Parser Port+parsePortC =+ ( PortC <$>+ (colon' *> parseCompass)+ )+ <?> "port (compass variant)"++parsePortI :: Parser Port+parsePortI =+ ( PortI <$>+ (colon' *> parseId) <*> optionMaybe (colon' *> parseCompass)+ )+ <?> "port (id variant)"++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parseCompass :: Parser Compass+parseCompass =+ (fmap convert identifier' >>= maybe err return)+ <?> "compass"+ where+ err = parserFail "invalid compass value"+ convert =+ flip lookup table . stringToLower+ where+ table =+ [ ("n", CompassN), ("e", CompassE), ("s", CompassS), ("w", CompassW)+ , ("ne", CompassNE), ("nw", CompassNW), ("se", CompassSE), ("sw", CompassSW)+ ]++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parseAttributeList :: Parser [Attribute]+parseAttributeList =+ (brackets' (parseAttribute `sepBy` optional comma') <|> return [])+ <?> "attribute list"++parseAttribute :: Parser Attribute+parseAttribute =+ ( do+ id0 <- parseId+ id1 <- optionMaybe (reservedOp' "=" >> parseId)+ return $ maybe (AttributeSetTrue id0) (AttributeSetValue id0) id1+ )+ <?> "attribute"++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parseId :: Parser Id+parseId =+ ( try parseNameId+ <|> try parseStringId+ <|> try parseFloatId+ <|> try parseIntegerId+ <|> parseXmlId+ )+ <?> "id"++parseNameId :: Parser Id+parseNameId =+ ( NameId <$>+ identifier'+ )+ <?> "name"++parseStringId :: Parser Id+parseStringId =+ ( StringId <$>+ lexeme' (char '"' *> manyTill stringChar (char '"'))+ )+ <?> "string literal"+ where+ stringChar =+ (try (string "\\\"" >> return '"') <|> noneOf "\"")+ <?> "string character"++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++-- | DOT allows floating point numbers having no whole part like @.123@, but+-- Parsec 'float' does not accept them.+parseFloatId :: Parser Id+parseFloatId =+ lexeme'+ ( do s <- parseSign+ l <- fmap (fromMaybe 0) (optionMaybe parseNatural)+ char '.'+ r <- many1 digit+ maybe err return (make s (show l ++ "." ++ r))+ )+ <?> "float"+ where+ err = parserFail "invalid float value"+ make s f =+ case readFloat f of+ [(v,"")] -> (Just . FloatId . s) v+ _ -> Nothing++parseSign :: (Num a) => Parser (a -> a)+parseSign =+ ( (char '-' >> return negate)+ <|> (char '+' >> return id)+ <|> return id+ )+ <?> "sign"++-- | Non-'lexeme' variant of 'natural' for parsing the natural part of a float.+parseNatural :: Parser Integer+parseNatural =+ ( (char '0' >> return 0)+ <|> (convert <$> many1 digit)+ )+ <?> "natural"+ where+ convert = foldl' (\acc d -> 10 * acc + fromIntegral (digitToInt d)) 0++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parseIntegerId :: Parser Id+parseIntegerId =+ ( IntegerId <$>+ integer'+ )+ <?> "integer"++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parseXmlId :: Parser Id+parseXmlId =+ ( XmlId <$>+ angles' parseXml+ )+ <?> "XML id"++parseXml :: Parser Xml+parseXml =+ ( try parseXmlEmptyTag+ <|> try parseXmlTag+ <|> parseXmlText+ )+ <?> "XML"++parseXmlEmptyTag :: Parser Xml+parseXmlEmptyTag =+ ( XmlEmptyTag <$>+ (char '<' *> parseXmlName) <*> (parseXmlAttributes <* (char '/' >> char '>'))+ )+ <?> "XML empty tag"++parseXmlTag :: Parser Xml+parseXmlTag =+ ( do (name, attributes) <- parseXmlTagOpen+ elements <- manyTill parseXml (lookAhead (try (parseXmlTagClose (Just name))))+ parseXmlTagClose (Just name)+ return $ XmlTag name attributes elements+ )+ <?> "XML tag"++parseXmlTagOpen :: Parser (XmlName, [XmlAttribute])+parseXmlTagOpen =+ ( (,) <$>+ (char '<' *> parseXmlName) <*> (parseXmlAttributes <* char '>')+ )+ <?> "XML opening tag"++parseXmlTagClose :: Maybe XmlName -> Parser ()+parseXmlTagClose mn0 =+ ( do char '<'+ char '/'+ n1 <- parseXmlName+ char '>'+ when (isJust mn0 && fromJust mn0 /= n1) parserZero+ )+ <?> "XML closing tag " ++ "(" ++ which ++ ")"+ where+ which =+ case mn0 of+ Just (XmlName n) -> "for " ++ show n+ Nothing -> "any"++parseXmlText :: Parser Xml+parseXmlText =+ ( XmlText <$>+ anyChar `manyTill` lookAhead ( try (parseXmlEmptyTag >> return ())+ <|> try (parseXmlTag >> return ())+ <|> parseXmlTagClose Nothing+ )+ )+ <?> "XML text"++parseXmlAttributes :: Parser [XmlAttribute]+parseXmlAttributes =+ many parseXmlAttribute+ <?> "XML attribute list"++parseXmlAttribute :: Parser XmlAttribute+parseXmlAttribute =+ ( XmlAttribute <$>+ (parseXmlName <* reservedOp' "=") <*> parseXmlAttributeValue+ )+ <?> "XML attribute"++parseXmlAttributeValue :: Parser XmlAttributeValue+parseXmlAttributeValue =+ ( XmlAttributeValue <$>+ stringLiteral'+ )+ <?> "XML attribute value"++parseXmlName :: Parser XmlName+parseXmlName =+ ( XmlName <$>+ ((:) <$> c0 <*> (many c1 <* whiteSpace'))+ )+ <?> "XML name"+ where+ c0 = letter <|> cs+ c1 = alphaNum <|> cs+ cs = oneOf "-.:_"++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++angles' :: Parser a -> Parser a+braces' :: Parser a -> Parser a+brackets' :: Parser a -> Parser a+colon' :: Parser String+comma' :: Parser String+identifier' :: Parser String+integer' :: Parser Integer+lexeme' :: Parser a -> Parser a+reserved' :: String -> Parser ()+reservedOp' :: String -> Parser ()+semi' :: Parser String+stringLiteral' :: Parser String+whiteSpace' :: Parser ()++angles' = angles lexer+braces' = braces lexer+brackets' = brackets lexer+colon' = colon lexer+comma' = comma lexer+identifier' = identifier lexer+integer' = integer lexer+lexeme' = lexeme lexer+reserved' = reserved lexer+reservedOp' = reservedOp lexer+semi' = semi lexer+stringLiteral' = stringLiteral lexer+whiteSpace' = whiteSpace lexer++lexer :: TokenParser ()+lexer =+ makeTokenParser dotDef+ where+ dotDef = emptyDef+ { commentStart = "/*"+ , commentEnd = "*/"+ , commentLine = "//"+ , nestedComments = True+ , identStart = letter <|> char '_'+ , identLetter = alphaNum <|> char '_'+ , opStart = oneOf "-="+ , opLetter = oneOf ""+ , reservedOpNames = ["->", "--", "="]+ , reservedNames = ["digraph", "edge", "graph", "node", "strict", "subgraph"]+ , caseSensitive = False+ }++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++stringToLower :: String -> String+stringToLower = map toLower
+ src/Language/Dot/Pretty.hs view
@@ -0,0 +1,131 @@+module Language.Dot.Pretty+ ( prettyPrintDot+ , renderDot+ , PP(..)+ )+ where++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++import Text.PrettyPrint++import Language.Dot.Syntax++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++prettyPrintDot :: Graph -> Doc+prettyPrintDot = pp++renderDot :: Graph -> String+renderDot = render . pp++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++class PP a where+ pp :: a -> Doc++instance (PP a) => PP (Maybe a) where+ pp (Just v) = pp v+ pp Nothing = empty++instance PP Graph where+ pp (Graph s d mi ss) = pp s <+> pp d <+> pp mi <+> lbrace $+$ indent (vcat' ss) $+$ rbrace++instance PP GraphStrictness where+ pp StrictGraph = text "strict"+ pp UnstrictGraph = empty++instance PP GraphDirectedness where+ pp DirectedGraph = text "digraph"+ pp UndirectedGraph = text "graph"++instance PP Id where+ pp (NameId v) = text v+ pp (StringId v) = doubleQuotes (text v)+ pp (IntegerId v) = integer v+ pp (FloatId v) = float v+ pp (XmlId v) = langle <> pp v <> rangle++instance PP Statement where+ pp (NodeStatement ni as) = pp ni <+> if not (null as) then brackets (hsep' as) else empty+ pp (EdgeStatement es as) = hsep' es <+> if not (null as) then brackets (hsep' as) else empty+ pp (AttributeStatement t as) = pp t <+> brackets (hsep' as)+ pp (AssignmentStatement i0 i1) = pp i0 <> equals <> pp i1+ pp (SubgraphStatement s) = pp s++instance PP AttributeStatementType where+ pp GraphAttributeStatement = text "graph"+ pp NodeAttributeStatement = text "node"+ pp EdgeAttributeStatement = text "edge"++instance PP Attribute where+ pp (AttributeSetTrue i) = pp i+ pp (AttributeSetValue i0 i1) = pp i0 <> equals <> pp i1++instance PP NodeId where+ pp (NodeId i mp) = pp i <> pp mp++instance PP Port where+ pp (PortI i mc) = colon <> pp i <> maybe empty ((colon <>) . pp) mc+ pp (PortC c) = colon <> pp c++instance PP Compass where+ pp CompassN = text "n"+ pp CompassE = text "e"+ pp CompassS = text "s"+ pp CompassW = text "w"+ pp CompassNE = text "ne"+ pp CompassNW = text "nw"+ pp CompassSE = text "se"+ pp CompassSW = text "sw"++instance PP Subgraph where+ pp (NewSubgraph mi ss) = text "subgraph" <+> pp mi <+> lbrace $+$ indent (vcat' ss) $+$ rbrace+ pp (SubgraphRef i) = text "subgraph" <+> pp i++instance PP Entity where+ pp (ENodeId et ni) = pp et <+> pp ni+ pp (ESubgraph et sg) = pp et <+> pp sg++instance PP EdgeType where+ pp NoEdge = empty+ pp DirectedEdge = text "->"+ pp UndirectedEdge = text "--"++instance PP Xml where+ pp (XmlEmptyTag n as) = langle <> pp n <+> hsep' as <> slash <> rangle+ pp (XmlTag n as xs) = langle <> pp n <+> hsep' as <> rangle <> hcat' xs <> langle <> slash <> pp n <> rangle+ pp (XmlText t) = text t++instance PP XmlName where+ pp (XmlName n) = text n++instance PP XmlAttribute where+ pp (XmlAttribute n v) = pp n <> equals <> pp v++instance PP XmlAttributeValue where+ pp (XmlAttributeValue v) = doubleQuotes (text v)++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++indent :: Doc -> Doc+indent = nest 2++hcat' :: (PP a) => [a] -> Doc+hcat' = hcat . map pp++hsep' :: (PP a) => [a] -> Doc+hsep' = hsep . map pp++vcat' :: (PP a) => [a] -> Doc+vcat' = vcat . map pp++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++langle :: Doc+rangle :: Doc+slash :: Doc++langle = char '<'+rangle = char '>'+slash = char '/'
+ src/Language/Dot/Syntax.hs view
@@ -0,0 +1,92 @@+-- | DOT AST. See <http://www.graphviz.org/doc/info/lang.html>.++module Language.Dot.Syntax where++data Graph+ = Graph GraphStrictness GraphDirectedness (Maybe Id) [Statement]+ deriving (Eq, Show)++data GraphStrictness+ = StrictGraph+ | UnstrictGraph+ deriving (Eq, Show)++data GraphDirectedness+ = DirectedGraph+ | UndirectedGraph+ deriving (Eq, Show)++data Id+ = NameId String+ | StringId String+ | IntegerId Integer+ | FloatId Float+ | XmlId Xml+ deriving (Eq, Show)++data Statement+ = NodeStatement NodeId [Attribute]+ | EdgeStatement [Entity] [Attribute]+ | AttributeStatement AttributeStatementType [Attribute]+ | AssignmentStatement Id Id+ | SubgraphStatement Subgraph+ deriving (Eq, Show)++data AttributeStatementType+ = GraphAttributeStatement+ | NodeAttributeStatement+ | EdgeAttributeStatement+ deriving (Eq, Show)++data Attribute+ = AttributeSetTrue Id+ | AttributeSetValue Id Id+ deriving (Eq, Show)++data NodeId+ = NodeId Id (Maybe Port)+ deriving (Eq, Show)++data Port+ = PortI Id (Maybe Compass)+ | PortC Compass+ deriving (Eq, Show)++data Compass+ = CompassN | CompassE | CompassS | CompassW+ | CompassNE | CompassNW | CompassSE | CompassSW+ deriving (Eq, Show)++data Subgraph+ = NewSubgraph (Maybe Id) [Statement]+ | SubgraphRef Id+ deriving (Eq, Show)++data Entity+ = ENodeId EdgeType NodeId+ | ESubgraph EdgeType Subgraph+ deriving (Eq, Show)++data EdgeType+ = NoEdge+ | DirectedEdge+ | UndirectedEdge+ deriving (Eq, Show)++data Xml+ = XmlEmptyTag XmlName [XmlAttribute]+ | XmlTag XmlName [XmlAttribute] [Xml]+ | XmlText String+ deriving (Eq, Show)++data XmlName+ = XmlName String+ deriving (Eq, Show)++data XmlAttribute+ = XmlAttribute XmlName XmlAttributeValue+ deriving (Eq, Show)++data XmlAttributeValue+ = XmlAttributeValue String+ deriving (Eq, Show)
+ src/ppdot.hs view
@@ -0,0 +1,73 @@+module Main (main) where++import Control.Exception (IOException, try)+import Control.Monad.Error (ErrorT(..), MonadError(..))+import Data.List (intercalate)+import System.Environment (getArgs, getProgName)+import System.Exit (exitFailure, exitSuccess)+import System.IO (hPutStrLn, stderr)++import Language.Dot (parseDot, renderDot)++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++main :: IO ()+main =+ getArgs >>= run++run :: [String] -> IO ()+run args =+ case args of+ [fp] -> renderDotFile fp+ [] -> displayUsage >> exitSuccess+ _ -> displayUsage >> exitFailure++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++renderDotFile :: FilePath -> IO ()+renderDotFile fp =+ runErrorT (renderDotFileET fp) >>= either exitError putStrLn++renderDotFileET :: FilePath -> ErrorT String IO String+renderDotFileET fp = do+ contents <- readFile fp `liftCatch` show+ graph <- parseDot fp contents `liftEither` show+ return $ renderDot graph++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++displayUsage :: IO ()+displayUsage = do+ programName <- getProgName+ ePutStrLns+ [ programName ++ ": Pretty-print a Graphviz DOT file."+ , intercalate " " ["Usage:", programName, "FILE"]+ ]++exitError :: String -> IO ()+exitError e = do+ displayUsage+ ePutStrLn ""+ let el = lines e+ if length el == 1+ then ePutStrLn ("ERROR: " ++ e)+ else ePutStrLns ("ERROR:" : indent el)+ exitFailure+ where+ indent = map (" "++)++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++liftCatch :: IO a -> (IOException -> e) -> ErrorT e IO a+liftCatch a f = ErrorT $ fmap (either (Left . f) Right) (try a)++liftEither :: (MonadError e m) => Either l r -> (l -> e) -> m r+liftEither e f = either (throwError . f) return e++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++ePutStrLn :: String -> IO ()+ePutStrLn = hPutStrLn stderr++ePutStrLns :: [String] -> IO ()+ePutStrLns = mapM_ (hPutStrLn stderr)
+ src/test.hs view
@@ -0,0 +1,120 @@+module Main (main) where++import Control.Monad (unless)+import Data.Char (toLower, toUpper)++import Text.Parsec+import Text.Parsec.String++import Language.Dot.Parser+import Language.Dot.Syntax++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++main :: IO ()+main = do+ testParser "parsePort" parsePort parsePortTests+ testParser "parseCompass" parseCompass parseCompassTests+ testParser "parseAttribute" parseAttribute parseAttributeTests+ testParser "parseId" parseId parseIdTests++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parsePortTests :: [(String, Port)]+parsePortTests =+ [ ( ":\"x\"" , PortI (StringId "x" ) Nothing )+ , ( ":\"\\t\\\"\":nw" , PortI (StringId "\\t\"" ) (Just CompassNW) )+ , ( ":-.0004" , PortI (FloatId (-0.0004) ) Nothing )+ , ( ":-1.23:sE" , PortI (FloatId (-1.23) ) (Just CompassSE) )+ , ( ":123" , PortI (IntegerId 123 ) Nothing )+ , ( ":123:NE" , PortI (IntegerId 123 ) (Just CompassNE) )+ , ( ":__2xYz" , PortI (NameId "__2xYz" ) Nothing )+ , ( ":__2xYz:S" , PortI (NameId "__2xYz" ) (Just CompassS) )+ , ( ":n" , PortC CompassN )+ , ( ":SE" , PortC CompassSE )+ ]++parseCompassTests :: [(String, Compass)]+parseCompassTests =+ concat+ [ [ (t, CompassN) | t <- allCaps "n" ]+ , [ (t, CompassE) | t <- allCaps "e" ]+ , [ (t, CompassS) | t <- allCaps "s" ]+ , [ (t, CompassW) | t <- allCaps "w" ]+ , [ (t, CompassNE) | t <- allCaps "ne" ]+ , [ (t, CompassNW) | t <- allCaps "nw" ]+ , [ (t, CompassSE) | t <- allCaps "se" ]+ , [ (t, CompassSW) | t <- allCaps "sw" ]+ ]++parseAttributeTests :: [(String, Attribute)]+parseAttributeTests =+ [ ( "a" , AttributeSetTrue (NameId "a") )+ , ( "a=b" , AttributeSetValue (NameId "a") (NameId "b") )+ , ( "-.003\t=\r\n _xYz123_" , AttributeSetValue (FloatId (-0.003)) (NameId "_xYz123_") )+ , ( "\"\\t\\\"\" =-123" , AttributeSetValue (StringId "\\t\"") (IntegerId (-123)) )+ ]++parseIdTests :: [(String, Id)]+parseIdTests =+ [ ( "a" , NameId "a" )+ , ( "A1" , NameId "A1" )+ , ( "_2X" , NameId "_2X" )+ , ( "\"\"" , StringId "" )+ , ( "\"\\t\\r\\n\"" , StringId "\\t\\r\\n" )+ , ( ".0" , FloatId 0.0 )+ , ( ".123" , FloatId 0.123 )+ , ( "+.999" , FloatId 0.999 )+ , ( "-.001" , FloatId (-0.001) )+ , ( "+.001" , FloatId 0.001 )+ , ( "0.0" , FloatId 0.0 )+ , ( "1.2" , FloatId 1.2 )+ , ( "123.456" , FloatId 123.456 )+ , ( "0" , IntegerId 0 )+ , ( "+0" , IntegerId 0 )+ , ( "-0" , IntegerId 0 )+ , ( "123" , IntegerId 123 )+ , ( "-123" , IntegerId (-123) )+ ]++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++testParser :: (Eq a, Show a) => String -> Parser a -> [(String, a)] -> IO ()+testParser name parser tests =+ help tests [] (0 :: Int) (0 :: Int)+ where+ help [] es np nf = do+ putStrLn $ name ++ ": " ++ show np ++ " passed, " ++ show nf ++ " failed"+ mapM_ (putStrLn . (" "++)) (reverse es)+ unless (null es) (putStrLn "")+ help ((i,o):ts) es np nf =+ case parse' parser i of+ Left _ -> help ts (makeFailureMessage name i o : es) np (succ nf)+ Right v ->+ if v /= o+ then help ts (makeFailureMessage' name i o v : es) np (succ nf)+ else help ts es (succ np) nf++makeFailureMessage :: (Show a) => String -> String -> a -> String+makeFailureMessage name i o =+ "(" ++ name ++ " " ++ show i ++ ")" +++ " should have returned " ++ "(" ++ show o ++ ")"++makeFailureMessage' :: (Show a) => String -> String -> a -> a -> String+makeFailureMessage' name i o v =+ "(" ++ name ++ " " ++ show i ++ ")" +++ " returned " ++ "(" ++ show v ++ ")" +++ ", expected " ++ "(" ++ show o ++ ")"++-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --++parse' :: Parser a -> String -> Either ParseError a+parse' p = parse p ""++allCaps :: String -> [String]+allCaps [] = [[]]+allCaps (c:cs) =+ concatMap (\t -> [l:t, u:t]) (allCaps cs)+ where+ l = toLower c+ u = toUpper c