diff options
| author | Eugen Wissner <belka@caraus.de> | 2025-12-11 10:28:11 +0100 |
|---|---|---|
| committer | Eugen Wissner <belka@caraus.de> | 2025-12-11 10:28:11 +0100 |
| commit | 98329e0a3dd4f78b5d815ac3896272ec70904901 (patch) | |
| tree | 80f9c56cfe2ac20232358f236d32e84bd683be1b /Haskell-book/24/language-dot/src/Language/Dot/Pretty.hs | |
| parent | 3624c712d72d246f21d4e710cec7c11e052e0326 (diff) | |
| download | book-exercises-98329e0a3dd4f78b5d815ac3896272ec70904901.tar.gz | |
Add remaining haskell book exercises
Diffstat (limited to 'Haskell-book/24/language-dot/src/Language/Dot/Pretty.hs')
| -rw-r--r-- | Haskell-book/24/language-dot/src/Language/Dot/Pretty.hs | 135 |
1 files changed, 135 insertions, 0 deletions
diff --git a/Haskell-book/24/language-dot/src/Language/Dot/Pretty.hs b/Haskell-book/24/language-dot/src/Language/Dot/Pretty.hs new file mode 100644 index 0000000..84a4c0c --- /dev/null +++ b/Haskell-book/24/language-dot/src/Language/Dot/Pretty.hs @@ -0,0 +1,135 @@ +module Language.Dot.Pretty
+ ( prettyPrintDot
+ , renderDot
+ , PP(..)
+ )
+ where
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+import Numeric
+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) = ffloat 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 '/'
+
+ffloat :: Float -> Doc
+ffloat v = text (showFFloat Nothing v "")
|