packages feed

haphviz (empty) → 0.1.0.0

raw patch · 7 files changed

+494/−0 lines, 7 filesdep +basedep +mtldep +textsetup-changed

Dependencies added: base, mtl, text

Files

+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2015 Tom Sydney Kerckhove++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haphviz.cabal view
@@ -0,0 +1,31 @@+-- Initial haphviz.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                haphviz+version:             0.1.0.0+synopsis:            Graphviz code generation with Haskell+description:         Graphviz code generation with Haskell+author:              Tom Sydney Kerckhove+maintainer:          syd.kerckhove@gmail.com+copyright:           Tom Sydney Kerckhove 2015+category:            Text+build-type:          Simple+cabal-version:       >=1.10+License:             MIT+License-file:        LICENSE++source-repository head+  type:              git+  location:          https://github.com/NorfairKing/haphviz++library+  exposed-modules:     Text.Dot+  other-modules:       Text.Dot.Gen+                       Text.Dot.Render+                       Text.Dot.Types.Internal+  -- other-extensions:    +  build-depends:       base         >= 4.6   && <  4.9+                     , text         >= 1.2   && <  1.3+                     , mtl          >= 2.2   && <  2.3+  hs-source-dirs:      src+  default-language:    Haskell2010
+ src/Text/Dot.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.Dot (+      module Text.Dot.Gen+    -- * Graph rendering+    , renderGraph+    , renderToFile+    , renderToStdOut+    ) where++import           Text.Dot.Gen+import           Text.Dot.Render (renderGraph, renderToFile, renderToStdOut)+
+ src/Text/Dot/Gen.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.Dot.Gen (+      module Text.Dot.Gen+    -- * Graph Types+    , Dot+    , DotGraph+    , NodeId+    , Attribute+    , DecType+    , RankdirType+    ) where++import           Control.Monad.State     (StateT, execStateT, get, modify)+import           Control.Monad.Writer    (WriterT, execWriterT, tell)++import           Text.Dot.Types.Internal++import           Data.Monoid             (Monoid (..), (<>))++import           Data.Text               (Text)+import qualified Data.Text               as T++type DotGen = StateT State (WriterT Dot Identity)++type State = Int -- Next nameless node number++-- | Generate graph+graph :: GraphType+      -> GraphName -- ^ Graph name+      -> DotGen a  -- ^ Content+      -> DotGraph+graph gt gn func = Graph gt gn $ genDot func++graph_ :: GraphType+       -> DotGen a -- ^ Content+       -> DotGraph+graph_ gt func = graph gt "haphviz" func++-- | Generate Internal dot AST+genDot :: DotGen a -> Dot+genDot = genSubDot 0++genSubDot :: Int -> DotGen a -> Dot+genSubDot n func = runIdentity $ execWriterT $ execStateT func n++-- * Graph types++-- | Undirected graph+directed :: GraphType+directed = DirectedGraph++-- | Directed graph+undirected :: GraphType+undirected = UndirectedGraph++-- * Nodes+-- | Most general node declaration+genNode :: NodeId -> [Attribute] -> DotGen ()+genNode ni ats = tell $ Node ni ats++-- | Node with given name and attributes+namedNode :: Text -- ^ Name+          -> [Attribute] -> DotGen NodeId+namedNode t ats = do+    let ni = UserId t+    genNode ni ats+    return ni++-- | Nameless node with attributes+namelessNode :: [Attribute] -> DotGen NodeId+namelessNode ats = do+    ni <- newNode+    genNode ni ats+    return ni++-- | Node with a label but no other attributes+node :: Text -- ^ Label+     -> DotGen NodeId+node l = namelessNode [label =: l]++-- | Node with given node Id and label+node_ :: NodeId -- ^ given Node ID+      -> Text -- ^ Label+      -> DotGen ()+node_ ni l = genNode ni [label =: l]++-- Generate a new nameless node ID+newNode :: DotGen NodeId+newNode = do+    i <- get+    modify (+1)+    return $ Nameless i+++-- * Edges++-- | Most general edge declaration+genEdge :: NodeId -> NodeId -> [Attribute] -> DotGen ()+genEdge n1 n2 ats = tell $ Edge n1 n2 ats+++-- | Infix edge constructor. (No attributes)+(-->) :: NodeId -> NodeId -> DotGen ()+n1 --> n2 = genEdge n1 n2 []++-- * Attributes++-- | Infix operator for an attribute pair+(=:) :: AttributeName -> AttributeValue -> Attribute+(=:) = (,)++-- ** Attribute Names++label :: AttributeName+label = "label"++compound :: AttributeName+compound = "compound"++shape :: AttributeName+shape = "shape"++color :: AttributeName+color = "color"++dir :: AttributeName+dir = "dir"++width :: AttributeName+width = "width"++height :: AttributeName+height = "height"++-- ** Attribute values++true :: AttributeValue+true = "true"++false :: AttributeValue+false = "false"++none :: AttributeValue+none = "none"+++-- * Declarations++-- | General declaration of attributes+genDec :: DecType -> [Attribute] -> DotGen ()+genDec t ats = tell $ Declaration t ats++-- | Graph declaration+--+-- >>> graphDec [compound =: true]+-- > graph [compound=true];+graphDec :: [Attribute] -> DotGen ()+graphDec = genDec DecGraph++-- | Node declaration+--+-- >>> nodeDec [shape =: none]+-- > node [shape=none];+nodeDec :: [Attribute] -> DotGen ()+nodeDec = genDec DecNode++-- | Edge declaration+--+-- >>> edgeDec [color =: "red:blue"]+-- > edge [color="red:blue"];+edgeDec :: [Attribute] -> DotGen ()+edgeDec = genDec DecEdge+++-- * Subgraphs++-- | Subgraph+subgraph :: Text -> DotGen () -> DotGen GraphName+subgraph name content = do+    n <- get+    let c = genSubDot n content+    tell $ Subgraph name c+    return name++-- | Cluster+cluster :: Text -> DotGen () -> DotGen GraphName+cluster name = subgraph $ "cluster_" <> name++-- * Miscelaneous+-- ** Rankdir+rankdir :: RankdirType -> DotGen ()+rankdir = tell . Rankdir++leftRight :: RankdirType+leftRight = LR++topBottom :: RankdirType+topBottom = TB++-- ** Labels+-- | Label declaration for graphs or subgraphs+labelDec :: Text -> DotGen ()+labelDec = tell . Label++-- ** Ports+(.:) :: NodeId+     -> Text -- ^ Port+     -> NodeId+(UserId t) .: p = UserId $ t <> ":" <> p+(Nameless i) .: p = UserId $ T.pack (show i) <> ":" <> p
+ src/Text/Dot/Render.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.Dot.Render (+      renderGraph+    , renderToFile+    , renderToStdOut+    ) where++import           Control.Monad           (unless)+import           Data.Monoid+import           Data.Text               (Text)+import qualified Data.Text               as T+import qualified Data.Text.IO            as T++import           Control.Monad.Identity  (Identity (..))+import           Control.Monad.Reader    (ReaderT, ask, runReaderT)+import           Control.Monad.State     (StateT, execStateT, get, modify)+import           Control.Monad.Writer    (WriterT, execWriterT, tell)++import           Text.Dot.Types.Internal++type Render = ReaderT GraphType (StateT Int (WriterT Text Identity))++renderToFile :: FilePath -> DotGraph -> IO ()+renderToFile file g = T.writeFile file $ renderGraph g++renderToStdOut :: DotGraph -> IO ()+renderToStdOut = T.putStrLn . renderGraph++renderGraph :: DotGraph -> Text+renderGraph (Graph gtype name content) = mconcat+    [ "digraph"+    , " "+    , name+    , " "+    , "{"+    , "\n"+    , runIdentity $ execWriterT $ execStateT (runReaderT (renderDot content) gtype) 1+    , "}"+    ]+++renderDot :: Dot -> Render ()++renderDot (Node nid ats) = do+    renderId nid+    renderAttributes ats++renderDot (Edge from to ats) = do+    renderId from+    tell " "+    t <- ask+    tell $ case t of+        UndirectedGraph -> "--"+        DirectedGraph   -> "->"+    tell " "+    renderId to+    renderAttributes ats++renderDot (Declaration t ats) = do+    renderDecType t+    renderAttributes ats++renderDot (Subgraph name content) = do+    tell "subgraph"+    tell " "+    tell name+    tell " "+    tell "{"+    tell "\n"+    indented $ renderDot content+    indent+    tell "}"++renderDot (RawDot t) = tell t++renderDot (Rankdir t) = do+    tell "rankdir"+    tell " = "+    renderRankDirType t++renderDot (Label t) = do+    tell "label"+    tell " = "+    tell $ quoted t++renderDot (DotSeq d1 d2) = do+    ind d1+    renderDot d1+    nl d1+    ind d2+    renderDot d2+    nl d2+  where+    nl :: Dot -> Render ()+    nl (DotSeq _ _) = return ()+    nl DotEmpty = return ()+    nl _ = do+        tell ";"+        tell "\n"++    ind :: Dot -> Render ()+    ind (DotSeq _ _) = return ()+    ind DotEmpty = return ()+    ind _ = do+        level <- get+        tell $ T.pack $ replicate (level * 2) ' '+++renderDot DotEmpty = return ()++renderAttributes :: [Attribute] -> Render ()+renderAttributes ats = unless (null ats) $ do+    tell " "+    tell "["+    commaSeparated $ map renderAttribute ats+    tell "]"+  where+    commaSeparated [] = return ()+    commaSeparated [r] = r+    commaSeparated (r:rs) = do+        r+        tell ", "+        commaSeparated rs++renderAttribute :: Attribute -> Render ()+renderAttribute (name, value) = do+    tell name+    tell "="+    tell $ quoteHtml value++renderId :: NodeId -> Render ()+renderId (Nameless i) = tell $ T.pack $ show i+renderId (UserId t) = tell $ quoted t++renderDecType :: DecType -> Render ()+renderDecType DecGraph = tell "graph"+renderDecType DecNode  = tell "node"+renderDotType DecEdge  = tell "edge"++renderRankDirType :: RankdirType -> Render ()+renderRankDirType TB = tell "TB"+renderRankDirType LR = tell "LR"++indent :: Render ()+indent = do+    level <- get+    tell $ T.pack $ replicate (level * 2) ' '++indented :: Render () -> Render ()+indented func = do+    modify ((+) 1)+    func+    modify (flip (-) 1)++-- | Text processing utilities+quoted :: Text -> Text+quoted t = if needsQuoting t then "\"" <> t <> "\"" else t++quoteHtml :: Text -> Text+quoteHtml t = "<" <> t <> ">"++needsQuoting :: Text -> Bool+needsQuoting = T.any (== ' ')
+ src/Text/Dot/Types/Internal.hs view
@@ -0,0 +1,55 @@+module Text.Dot.Types.Internal (+      module Text.Dot.Types.Internal+    , Identity(..)+    , Monoid(..)+    ) where++import           Control.Monad          (unless)+import           Data.Monoid+import           Data.Text              (Text)+import qualified Data.Text              as T++import           Control.Monad.Identity (Identity (..))+import           Control.Monad.Reader   (ReaderT, ask, runReaderT)+import           Control.Monad.Writer   (WriterT, execWriterT, tell)+++type GraphName = Text+data GraphType = UndirectedGraph+               | DirectedGraph+    deriving (Show, Eq)++type AttributeName = Text+type AttributeValue = Text+type Attribute = (Text, Text)++data NodeId = UserId Text+            | Nameless Int+    deriving (Show, Eq)++data DecType = DecGraph+             | DecNode+             | DecEdge+    deriving (Show, Eq)++data DotGraph = Graph GraphType GraphName Dot+    deriving (Show, Eq)++data RankdirType = LR+                 | TB+    deriving (Show, Eq)++data Dot = Node NodeId [Attribute]+         | Edge NodeId NodeId [Attribute]+         | Declaration DecType [Attribute]+         | Subgraph Text Dot+         | RawDot Text+         | Label Text+         | Rankdir RankdirType+         | DotSeq Dot Dot+         | DotEmpty+    deriving (Show, Eq)++instance Monoid Dot where+    mappend d1 d2 = DotSeq d1 d2+    mempty = DotEmpty