src/Graph/DOT.hs

   1 module Graph.DOT where
   2
   3 -- import Numeric.Probability
   4 import Control.Applicative (Applicative (..))
   5 import Control.Monad (Monad (..), foldM_, forM_, mapM_, when, zipWithM_)
   6 import Control.Monad.Trans.Class qualified as MT
   7 import Control.Monad.Trans.Reader qualified as MT
   8 import Control.Monad.Trans.Writer.CPS qualified as MT
   9 import Data.Bool (otherwise, (&&))
  10 import Data.ByteString.Builder qualified as BS
  11 import Data.ByteString.Short qualified as BSh
  12 import Data.Eq (Eq (..))
  13 import Data.Foldable (foldMap', toList)
  14 import Data.Function (id, on, ($), (&), (.))
  15 import Data.Functor ((<&>))
  16 import Data.Int (Int)
  17 import Data.List qualified as List
  18 import Data.Map.Strict qualified as Map
  19 import Data.Maybe (Maybe (..), fromMaybe)
  20 import Data.Monoid (Monoid (..))
  21 import Data.Ord (Ord (..))
  22 import Data.Semigroup (Min (..), Semigroup (..))
  23 import Data.Set (Set)
  24 import Data.Set qualified as Set
  25 import Data.String (IsString (..), String)
  26 import Data.Text.Lazy qualified as LazyText
  27 import Data.Text.Lazy.Encoding qualified as LazyText
  28 import Data.Text.Short (ShortText)
  29 import Data.Text.Short qualified as ShortText
  30 import Data.Tree qualified as Tree
  31 import Debug.Pretty.Simple (pTraceShow)
  32 import GHC.Real (floor)
  33 import GHC.Stack (HasCallStack)
  34 import Numeric (showFFloat)
  35 import Text.Pretty.Simple (pShow)
  36 import Text.Printf (printf)
  37 import Text.Show (Show (..))
  38 import Prelude
  39
  40 type DOT m = MT.ReaderT BSh.ShortByteString (MT.WriterT BS.Builder m) ()
  41
  42 indexFrom1M_ :: Applicative m => [a] -> (a -> Int -> m b) -> m ()
  43 indexFrom1M_ xs f = zipWithM_ f xs [1 :: Int ..]
  44
  45 runDOT :: Monad m => DOT m -> m BS.Builder
  46 runDOT = MT.execWriterT . (`MT.runReaderT` {-indent-} "")
  47
  48 dotBlock :: Monad m => DOT m -> DOT m
  49 dotBlock s = do
  50   dotLine "{"
  51   () <- MT.withReaderT ("  " <>) s
  52   dotLine "}"
  53
  54 dotLine :: Monad m => BS.Builder -> DOT m
  55 dotLine s = do
  56   indent <- MT.ask
  57   MT.lift $ MT.tell $ BS.shortByteString indent <> s <> "\n"
  58
  59 dotComments :: Monad m => [BS.Builder] -> DOT m
  60 dotComments cs = do
  61   dotLine "/*"
  62   forM_ cs dotLine
  63   dotLine "*/"
  64
  65 dotEdges :: Monad m => [BS.Builder] -> [(BS.Builder, Value)] -> DOT m
  66 dotEdges names as = dotLine $ mconcat (List.intersperse " -> " names) <> builderAttrs as
  67
  68 data Value
  69   = ValueString String
  70   | ValueHTML BS.Builder
  71 instance IsString Value where
  72   fromString = ValueString
  73
  74 dotNode :: Monad m => BS.Builder -> [(BS.Builder, Value)] -> DOT m
  75 dotNode name as = dotLine $ name <> builderAttrs as
  76
  77 builderAttrs :: [(BS.Builder, Value)] -> BS.Builder
  78 builderAttrs as
  79   | List.null as = ""
  80   | otherwise = "[" <> mconcat (List.intersperse "," attrs) <> "]"
  81   where
  82     attrs =
  83       [ k <> "=" <> vBS
  84       | (k, v) <- as
  85       , BS.toLazyByteString k /= ""
  86       , let vBS = case v of
  87               ValueString s -> s & builderQuotedString
  88               ValueHTML s -> BS.charUtf8 '<' <> s <> BS.charUtf8 '>'
  89       ]
  90
  91 builderQuotedShortText :: ShortText -> BS.Builder
  92 builderQuotedShortText = builderQuotedString . ShortText.unpack
  93
  94 builderQuotedString :: String -> BS.Builder
  95 builderQuotedString cs = BS.charUtf8 '"' <> foldMap' escape cs <> BS.charUtf8 '"'
  96   where
  97     escape '\\' = BS.charUtf8 '\\' <> BS.charUtf8 '\\'
  98     escape '\"' = BS.charUtf8 '\\' <> BS.charUtf8 '\"'
  99     escape c = BS.charUtf8 c