dot (empty) → 0.2.0

raw patch · 6 files changed

+337/−0 lines, 6 filesdep +basedep +impure-containersdep +textsetup-changed

Dependencies added: base, impure-containers, text

Files

LICENSE +30/−0
Setup.hs +2/−0
dot.cabal +29/−0
src/Data/Graph/Immutable/Dot.hs +54/−0
src/Dot/Text.hs +136/−0
src/Dot/Types.hs +86/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Andrew Martin (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Andrew Martin nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ dot.cabal view

@@ -0,0 +1,29 @@+name:                dot+version:             0.2.0+synopsis:            Data types and encoding for graphviz dot files+description:         Please see README.md+homepage:            https://github.com/andrewthad/dot#readme+license:             BSD3+license-file:        LICENSE+author:              Andrew Martin+maintainer:          andrew.thaddeus@gmail.com+copyright:           2016 Andrew Martin+category:            web+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:+    Dot.Types+    Dot.Text+    Data.Graph.Immutable.Dot+  build-depends:+      base >= 4.7 && < 5+    , text+    , impure-containers >= 0.3 && < 0.4+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/andrewthad/dot

+ src/Data/Graph/Immutable/Dot.hs view

@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Graph.Immutable.Dot+  ( toDotGraph+  , toLabeledDotGraph+  ) where++import Data.Graph.Types+import Dot.Types+import Control.Applicative+import Data.Text (Text)+import qualified Data.Graph.Immutable as Graph+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LText+import qualified Data.Text.Lazy.Builder as Builder+import qualified Data.Text.Lazy.Builder.Int as Builder++-- | This is a fairly general way to build a dot file from a graph.+toDotGraph :: Directionality -> (v -> [Attribute]) -> (v -> v -> e -> [Attribute]) -> Graph g e v -> DotGraph+toDotGraph directionality vertexAttrs edgeAttrs g =+  DotGraph strictness directionality Nothing $ []+    ++ vertexDeclarations+    ++ edgeDeclarations+  where+  vertexDeclarations = getConst $ flip Graph.traverseVertices_ g $ \vertex v ->+    Const [StatementNode $ NodeStatement (vertexToNodeId vertex) (vertexAttrs v)]+  edgeDeclarations = getConst $ flip Graph.traverseEdges_ g $ \vertexFrom vertexTo vFrom vTo e ->+    Const [StatementEdge $ EdgeStatement+             (ListTwo+               (EdgeNode (vertexToNodeId vertexFrom))+               (EdgeNode (vertexToNodeId vertexTo))+               []+             )+             (edgeAttrs vFrom vTo e)+          ]+  strictness = case directionality of+    Undirected -> NonStrict+    Directed -> Strict++-- | This is a more convenient variant of 'toDotGraph' that just labels+-- all of the nodes and edges. It does not color or style anything.+toLabeledDotGraph :: Directionality -> (v -> Text) -> (e -> Text) -> Graph g e v -> DotGraph+toLabeledDotGraph dir vertexLabel edgeLabel =+  toDotGraph dir (textToLabel . vertexLabel) (const $ const $ textToLabel . edgeLabel)++textToLabel :: Text -> [Attribute]+textToLabel name = [Attribute "label" (Id name)]++vertexToNodeId :: Vertex g -> NodeId+vertexToNodeId = id+  . flip NodeId Nothing . Id+  . LText.toStrict . Builder.toLazyText+  . mappend "a" . Builder.decimal . Graph.vertexInt+

+ src/Dot/Text.hs view

@@ -0,0 +1,136 @@+{-# LANGUAGE OverloadedStrings #-}++module Dot.Text+  ( encode+  , encodeLazy+  , builder+  ) where++import Data.Text (Text)+import Data.Text.Lazy.Builder (Builder)+import qualified Data.Text.Lazy.Builder as Builder+import qualified Data.Text.Lazy as LText+import Data.Monoid+import Dot.Types++levelSpaces :: Int+levelSpaces = 2++indentationBuilder :: Builder+indentationBuilder = "  "++encode :: DotGraph -> Text+encode = LText.toStrict . encodeLazy++encodeLazy :: DotGraph -> LText.Text+encodeLazy = Builder.toLazyText . builder++builder :: DotGraph -> Builder+builder (DotGraph strictness directionality mid statements) = mempty+  <> encodeStrictness strictness+  <> encodeGraphDirectionality directionality+  <> encodeMaybeId mid+  <> "{\n"+  <> foldr (\statement builder -> encodeStatement directionality indentationBuilder statement <> builder) mempty statements+  <> "}"++encodeId :: Id -> Builder+encodeId (Id theId) = Builder.fromText theId++encodeNodeId :: NodeId -> Builder+encodeNodeId (NodeId theId mport) =+  encodeId theId <> maybe mempty encodePort mport++encodePort :: Port -> Builder+encodePort (Port theId mcompass) =+  ":" <> encodeId theId <> maybe mempty encodeCompass mcompass++encodeCompass :: CardinalDirection -> Builder+encodeCompass x = case x of+  North -> "n"+  East -> "e"+  South -> "s"+  West -> "w"+  Northeast -> "ne"+  Northwest -> "nw"+  Southeast -> "se"+  Southwest -> "sw"++encodeMaybeId :: Maybe Id -> Builder+encodeMaybeId x = case x of+  Just theId -> encodeId theId <> " "+  Nothing -> mempty++encodeStrictness :: Strictness -> Builder+encodeStrictness x = case x of+  Strict -> "strict "+  NonStrict -> mempty++encodeElement :: Element -> Builder+encodeElement x = case x of+  Graph -> "graph "+  Node -> "node "+  Edge -> "edge "++encodeSubgraph :: Subgraph -> Builder+encodeSubgraph = error "encodeSubgraph: have not written this function yet"++encodeStatement :: Directionality -> Builder -> Statement -> Builder+encodeStatement directionality indentation x = case x of+  StatementAttribute (AttributeStatement element attrs) -> indentation+    <> encodeElement element+    <> encodeAttributes attrs+  StatementNode (NodeStatement theNodeId attrs) -> indentation+    <> encodeNodeId theNodeId+    <> encodeAttributes attrs+  StatementSubgraph subgraph -> encodeSubgraph subgraph+  StatementEdge (EdgeStatement elements attrs) -> indentation+    <> encodeEdgeElements directionality elements+    <> encodeAttributes attrs+  StatementEquality a b -> indentation+    <> encodeId a <> " = " <> encodeId b <> "\n"+  where nextIndentation = indentationBuilder <> indentation++encodeEdgeOp :: Directionality -> Builder+encodeEdgeOp x = case x of+  Undirected -> " -- "+  Directed -> " -> "++encodeEdgeElements :: Directionality -> ListTwo EdgeElement -> Builder+encodeEdgeElements edgeOp (ListTwo a b xs) =+  encodeEdgeElement a <> edgeOpBuilder <> encodeEdgeElement b+  <> foldr (\e builder -> edgeOpBuilder <> encodeEdgeElement e <> builder) mempty xs+  where edgeOpBuilder = encodeEdgeOp edgeOp++encodeEdgeElement :: EdgeElement -> Builder+encodeEdgeElement x = case x of+  EdgeSubgraph subgraph -> encodeSubgraph subgraph+  EdgeNode theNodeId -> encodeNodeId theNodeId++encodeAttributes :: [Attribute] -> Builder+encodeAttributes (x : xs) = " ["+  <> foldr (\attr builder -> encodeAttribute attr <> "," <> builder) (encodeAttribute x) xs+  <> "];\n"+encodeAttributes [] = " [];\n"++encodeAttribute :: Attribute -> Builder+encodeAttribute (Attribute attrId valId) = encodeId attrId <> "=" <> encodeId valId++encodeGraphDirectionality :: Directionality -> Builder+encodeGraphDirectionality x = case x of+  Directed -> "digraph "+  Undirected -> "graph "+++example :: DotGraph+example = DotGraph Strict Directed (Just "foobar")+  [ StatementNode $ NodeStatement "a1"+    [ Attribute "color" "blue"+    , Attribute "shape" "box"+    ]+  , StatementNode $ NodeStatement "a2" []+  , StatementEdge $ EdgeStatement (ListTwo "a1" "a2" ["a3"])+    [ Attribute "color" "red"+    ]+  ]+

+ src/Dot/Types.hs view

@@ -0,0 +1,86 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Dot.Types where++import Data.Text (Text)+import Data.Text.Lazy.Builder (Builder)+import Data.String (IsString(fromString))++data Strictness = Strict | NonStrict+  deriving (Show,Read)++data Directionality = Directed | Undirected+  deriving (Show,Read)++data CardinalDirection+  = North+  | East+  | South+  | West+  | Northeast+  | Northwest+  | Southeast+  | Southwest+  deriving (Show,Read)++data Element = Graph | Node | Edge+  deriving (Show,Read)++data EdgeElement = EdgeSubgraph Subgraph | EdgeNode NodeId+  deriving (Show,Read)++instance IsString EdgeElement where+  fromString str = EdgeNode (fromString str)++newtype Id = Id Text+  deriving (Show,Read,IsString)++data NodeId = NodeId Id (Maybe Port)+  deriving (Show,Read)++instance IsString NodeId where+  fromString str = NodeId (fromString str) Nothing++-- | Stole this from semigroups. Remove it once GHC 8.0 gains+--   widespread adoption.+data NonEmpty a = a :| [a]++data ListTwo a = ListTwo+  { listTwoFirst :: a+  , listTwoSecond :: a+  , listTwoOther :: [a]+  } deriving (Show,Read)++data Port = Port+  { portId :: Id+  , portCompass :: Maybe CardinalDirection+  } deriving (Show,Read)++data DotGraph = DotGraph Strictness Directionality (Maybe Id) [Statement]+  deriving (Show,Read)++data Statement+  = StatementAttribute AttributeStatement+  | StatementNode NodeStatement+  | StatementEdge EdgeStatement+  | StatementSubgraph Subgraph+  | StatementEquality Id Id+  deriving (Show,Read)++data AttributeStatement = AttributeStatement Element [Attribute]+  deriving (Show,Read)++data Attribute = Attribute Id Id+  deriving (Show,Read)++data NodeStatement = NodeStatement NodeId [Attribute]+  deriving (Show,Read)++data EdgeStatement = EdgeStatement (ListTwo EdgeElement) [Attribute]+  deriving (Show,Read)++data Subgraph = Subgraph+  { subgraphId :: Maybe Id+  , subgraphStatements :: [Statement]+  } deriving (Show,Read)+