From 98329e0a3dd4f78b5d815ac3896272ec70904901 Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Thu, 11 Dec 2025 10:28:11 +0100
Subject: Add remaining haskell book exercises

---
 .../24/language-dot/src/Language/Dot/Pretty.hs     | 135 +++++++++++++++++++++
 1 file changed, 135 insertions(+)
 create mode 100644 Haskell-book/24/language-dot/src/Language/Dot/Pretty.hs

(limited to 'Haskell-book/24/language-dot/src/Language/Dot/Pretty.hs')

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 "")
-- 
cgit v1.2.3