WIP: web: show result graph

Author: runeksvendsen

function-graph.cabal

@@ -32,6 +32,7 @@ library
                     , pretty-show
                     , stringsearch
                     , deepseq
+                    , graphviz
     hs-source-dirs:   src/lib
     default-language: Haskell2010
 

shell.nix

@@ -5,6 +5,7 @@ pkgs.mkShell {
     release-21-05.cabal-install
     pkgs.zlib
     pkgs.git
+    pkgs.graphviz
   ];
 
   shellHook = ''

src/lib/FunGraph.hs

@@ -5,15 +5,18 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE FlexibleContexts #-}
 module FunGraph
-  ( runQueryAll, runQueryAllST, runQueryTreeST, runQuery, runQueryTrace
+  ( -- * Queries
+    runQueryAll, runQueryTree, runQueryAllST, runQueryTreeST, runQuery, runQueryTrace
+    -- * Conversions
+  , queryResultTreeToPaths
   , spTreeToPaths, spTreePathsCount
   , renderComposedFunctions, renderComposedFunctionsStr, parseComposedFunctions
   , renderFunction, parseFunction, renderTypedFunction
+    -- * Types
   , Function(..), TypedFunction, UntypedFunction, PrettyTypedFunction, functionPackageNoVersion
   , FullyQualifiedType(..), textToFullyQualifiedType, fullyQualifiedTypeToText
-  , bsToStr
-  , module Export
   -- * Re-exports
+  , module Export
   , Json.FunctionType
   , DG.IDigraph, DG.Digraph
   , NE.NonEmpty
@@ -63,6 +66,7 @@ functionWeight (src, dst) function
     fnPkg = _function_package function
     (srcPkg, dstPkg) = (fqtPackage src, fqtPackage dst)
 
+-- | Run 'runQueryAllST'
 runQueryAll
   :: Int
   -> (FullyQualifiedType, FullyQualifiedType)
@@ -73,6 +77,17 @@ runQueryAll maxCount (src, dst) graph =
     g <- DG.thaw graph
     runQueryAllST (Dijkstra.runDijkstra g) maxCount (src, dst)
 
+-- | Run 'runQueryTreeST'
+runQueryTree
+  :: Int
+  -> (FullyQualifiedType, FullyQualifiedType)
+  -> DG.IDigraph FullyQualifiedType (NE.NonEmpty TypedFunction)
+  -> [([NE.NonEmpty TypedFunction], Double)]
+runQueryTree maxCount (src, dst) graph =
+  ST.runST $ do
+    g <- DG.thaw graph
+    runQueryTreeST (Dijkstra.runDijkstra g) maxCount (src, dst)
+
 -- | Passed to 'runQueryAllST' to run without tracing
 runQuery
   :: DG.Digraph s v meta

src/lib/FunGraph/Util.hs

@@ -7,6 +7,11 @@ module FunGraph.Util
   , showTypeSig
   , graphFromQueryResult
   , graphToDot
+  , graphToDotGraphviz
+  , graphVizRender
+  -- * Re-exports
+  , Data.GraphViz.Commands.GraphvizCommand(..)
+  , Data.GraphViz.Commands.GraphvizOutput(..)
   )
   where
 
@@ -21,6 +26,11 @@ import qualified Data.Text.Encoding as TE
 import qualified Data.Text.Lazy as LT
 import Control.Monad.ST (ST)
 import qualified Data.Set as Set
+import qualified Data.GraphViz.Types
+import qualified Data.GraphViz.Types.Generalised
+import qualified Data.GraphViz.Commands
+import qualified Data.Text.IO as TIO
+import qualified Data.Text as T
 
 -- | Convert sequence of adjacent edges to vertices moved through
 toPathTypes
@@ -64,6 +74,27 @@ graphToDot name =
     (bsToLT . _function_name . DG.eMeta)
     (bsToLT name)
 
+graphToDotGraphviz
+  :: BSC8.ByteString
+  -> DG.Digraph s FullyQualifiedType (NE.NonEmpty TypedFunction)
+  -> ST s (Data.GraphViz.Types.Generalised.DotGraph LT.Text)
+graphToDotGraphviz name =
+  fmap Data.GraphViz.Types.parseDotGraph . graphToDot name
+
+graphVizRender
+  :: Data.GraphViz.Commands.GraphvizCommand -- ^ Layout
+  -> Data.GraphViz.Commands.GraphvizOutput -- ^ Output format
+  -> Data.GraphViz.Types.Generalised.DotGraph LT.Text -- ^ Actual graph
+  -> IO T.Text
+graphVizRender graphvizCommand graphvizOutput g =
+  Data.GraphViz.Commands.graphvizWithHandle
+    graphvizCommand
+    g
+    graphvizOutput
+    extractFromHandle
+  where
+    extractFromHandle = TIO.hGetContents
+
 -- | Build a graph from the output of 'FunGraph.runQueryTreeST'
 graphFromQueryResult
   :: [([NE.NonEmpty TypedFunction], Double)]

src/server/Server/Pages/Search.hs

@@ -15,30 +15,52 @@ import qualified FunGraph
 import Data.List (intersperse)
 import qualified Data.Text.Encoding as TE
 import Data.Containers.ListUtils (nubOrd)
+import qualified FunGraph.Util as Util
+import qualified Control.Monad.ST as ST
+import Control.Monad.IO.Class (liftIO)
 
 page :: FunGraph.FrozenGraph -> T.Text -> T.Text -> Word -> Handler (Html ())
-page graph src dst maxCount = pure $ do
-  p_ $ "Hi there, you entered src=" <> mono (toHtml src) <> ", dst=" <> mono (toHtml dst)
-  table_ $ do
-    thead_ $
-      tr_ $ do
-        td_ "Function composition"
-        td_ "Dependencies"
-    tbody_ $
-      forM_ (map fst results) $ \result ->
+page graph src dst maxCount = do
+  resultGraph <- liftIO renderResultGraphIO
+  pure $ do
+    p_ $ "Hi there, you entered src=" <> mono (toHtml src) <> ", dst=" <> mono (toHtml dst)
+    table_ $ do
+      thead_ $
         tr_ $ do
-          td_ $ renderResult result
-          td_ $
-            mconcat $
-              intersperse ", " $
-                map (mono . toHtml . TE.decodeUtf8) $
-                  nubOrd $
-                    map FunGraph.functionPackageNoVersion result
+          td_ "Function composition"
+          td_ "Dependencies"
+      tbody_ $
+        forM_ (map fst results) $ \result ->
+          tr_ $ do
+            td_ $ renderResult result
+            td_ $
+              mconcat $
+                intersperse ", " $
+                  map (mono . toHtml . TE.decodeUtf8) $
+                    nubOrd $
+                      map FunGraph.functionPackageNoVersion result
+    h2_ "Result graph"
+    svg_ $ toHtml resultGraph
   where
+    srcDst =
+      (FunGraph.textToFullyQualifiedType src, FunGraph.textToFullyQualifiedType dst)
+
     results =
-      take (fromIntegral maxCount) $ FunGraph.runQueryAll
+      take (fromIntegral maxCount) $
+        FunGraph.queryResultTreeToPaths srcDst query
+
+    renderResultGraphIO =
+      ST.stToIO resultDotGraph
+        >>= Util.graphVizRender Util.Circo Util.Svg
+
+    resultDotGraph =
+      Util.graphFromQueryResult query
+        >>= Util.graphToDotGraphviz ""
+
+    query =
+      FunGraph.runQueryTree
         (fromIntegral maxCount)
-        (FunGraph.textToFullyQualifiedType src, FunGraph.textToFullyQualifiedType dst)
+        srcDst
         graph
 
     renderResult :: [FunGraph.TypedFunction] -> Html ()