language-dot 0.1.0 → 0.1.1
raw patch · 8 files changed
+225/−226 lines, 8 filesdep +language-dotsetup-changed
Dependencies added: language-dot
Files
- Setup.hs +0/−12
- Setup.lhs +3/−0
- language-dot.cabal +25/−22
- ppdot/Main.hs +72/−0
- src/Language/Dot/Pretty.hs +5/−0
- src/ppdot.hs +0/−72
- src/test.hs +0/−120
- test/Main.hs +120/−0
− Setup.hs
@@ -1,12 +0,0 @@-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 ()
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
language-dot.cabal view
@@ -1,5 +1,5 @@ name: language-dot-version: 0.1.0+version: 0.1.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.@@ -12,15 +12,13 @@ cabal-version: >= 1.8 build-type: Simple -extra-source-files:- src/test.hs- flag executable description: Build the `ppdot' executable. default: True library- hs-source-dirs: src+ hs-source-dirs:+ src exposed-modules: Language.Dot@@ -35,18 +33,8 @@ pretty == 1.* ghc-options: -Wall--test-suite test- type: exitcode-stdio-1.0- main-is: test.hs- hs-source-dirs: src- ghc-options: -Wall- cpp-options: -DTEST- build-depends:- base == 4.*,- mtl == 1.* || == 2.*,- parsec == 3.*,- pretty == 1.*+ if impl(ghc >= 6.8)+ ghc-options: -fwarn-tabs executable ppdot if flag(executable)@@ -54,16 +42,31 @@ else buildable: False - main-is: ppdot.hs- hs-source-dirs: src+ hs-source-dirs: ppdot++ main-is: Main.hs build-depends: base == 4.*, mtl == 1.* || == 2.*,- parsec == 3.*,- pretty == 1.*+ language-dot ghc-options: -Wall+ if impl(ghc >= 6.8)+ ghc-options: -fwarn-tabs +test-suite test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Language.Dot.Parser+ Language.Dot.Syntax+ hs-source-dirs: test, src+ ghc-options: -Wall+ cpp-options: -DTEST+ build-depends:+ base == 4.*,+ parsec == 3.*+ source-repository head type: git- location: git://github.com/bsl/language-dot.git+ location: https://github.com/bgamari/language-dot
+ ppdot/Main.hs view
@@ -0,0 +1,72 @@+module Main (main) where++import Control.Exception (IOException, try)+import Control.Monad.Error (ErrorT(..), MonadError(..))+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."+ , unwords ["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/Language/Dot/Pretty.hs view
@@ -1,9 +1,14 @@+{-# LANGUAGE CPP #-} module Language.Dot.Pretty ( prettyPrintDot , renderDot , PP(..) ) where++#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
− src/ppdot.hs
@@ -1,72 +0,0 @@-module Main (main) where--import Control.Exception (IOException, try)-import Control.Monad.Error (ErrorT(..), MonadError(..))-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."- , unwords ["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
@@ -1,120 +0,0 @@-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
+ test/Main.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