Merge pull request #6 from runeksvendsen/streaming-unit-test

unit-test: also test stream-based query function

.github/workflows/cabal-in-nix-shell.yml

@@ -9,6 +9,7 @@ jobs:
     strategy:
       matrix:
         os: [ubuntu-22.04, ubuntu-20.04, macos-13, macos-12]
+      fail-fast: false
     runs-on: ${{ matrix.os }}
     steps:
       - name: Checkout

benchmark/lib/BenchmarkLib.hs

@@ -1,18 +1,18 @@
-module Main where
-
+module Main
+(main)
+where
 import Criterion.Main
 import qualified FunGraph
 import qualified FunGraph.Test
 import qualified Control.Monad.ST as ST
-import Data.Functor (void)
+import Data.Functor (void, (<&>))
 import Control.Monad ((<=<))
-
-testDataFileName :: FilePath
-testDataFileName = "data/all3.json"
+import qualified Data.List.NonEmpty as NE
+import qualified FunGraph.Test.Util
 
 main :: IO ()
 main = do
-  graphData <- readGraphData testDataFileName
+  graphData <- readGraphData FunGraph.Test.Util.testDataFileName
   mutGraph <- ST.stToIO $ FunGraph.buildGraphMut FunGraph.defaultBuildConfig graphData
   frozenGraph <- ST.stToIO $ buildGraphFreeze graphData
   defaultMain
@@ -22,16 +22,17 @@ main = do
       , bench "Thaw" $ nfAppIO (void . ST.stToIO . FunGraph.thaw) frozenGraph
       , bench "Thaw+freeze" $ nfAppIO (void . ST.stToIO . (FunGraph.freeze <=< FunGraph.thaw)) frozenGraph
       ]
-    , bgroup "Query"
-      [ bgroup "queryPaths" $
-          map (queryPaths mutGraph) FunGraph.Test.allTestCases
-      ]
+    , bgroup "Query" $
+        map (queryPaths mutGraph) FunGraph.Test.allTestCases
     ]
   where
     queryPaths mutGraph test =
-      let (maxCount, _) = FunGraph.Test.queryTest_args test
-      in bench (FunGraph.Test.queryTest_name test <> " maxCount=" <> show maxCount) $
-        nfAppIO (\g -> ST.stToIO $ FunGraph.runGraphAction g $ FunGraph.Test.queryTest_runQuery test) mutGraph
+      let args@(maxCount, _) = FunGraph.Test.queryTest_args test
+          nameWithMaxCount = FunGraph.Test.queryTest_name test <> " maxCount=" <> show maxCount
+      in bgroup nameWithMaxCount $ NE.toList $
+        FunGraph.Test.mkQueryFunctions False <&> \(queryFunctionName, queryFunction) ->
+          bench queryFunctionName $
+            nfAppIO (queryFunction args) mutGraph
 
     readGraphData fileName =
       either fail pure =<< FunGraph.fileReadDeclarationMap fileName

benchmark/web/BenchmarkWeb.hs

@@ -26,9 +26,6 @@ import Control.Monad (when)
 import Data.Maybe (isJust)
 import qualified Data.ByteString.Lazy as BSL
 
-testDataFileName :: FilePath
-testDataFileName = "data/all3.json"
-
 -- NOTE: If a benchmark times out then increase this limit
 searchConfig :: Server.Pages.Search.SearchConfig
 searchConfig = Server.Pages.Search.defaultSearchConfig
@@ -37,7 +34,7 @@ searchConfig = Server.Pages.Search.defaultSearchConfig
 
 main :: IO ()
 main =
-  Server.withHandlers logger searchConfig mempty testDataFileName $ \handlers ->
+  Server.withHandlers logger searchConfig mempty FunGraph.Test.Util.testDataFileName $ \handlers ->
     runWarpTestRandomPort (Server.app handlers) $ \port ->
       mkQueryFunction port >>= runTests
   where

default.nix

@@ -30,6 +30,7 @@ let
       servant-errors = servant-errors;
     };
 
+  # TODO: run 'test-web' executable as part of build and fail build on non-zero exit code
   function-graph = nixpkgs.pkgs.haskell.lib.doBenchmark (
     nixpkgs.pkgs.haskell.packages.${compiler}.callCabal2nix "function-graph" ./. args
   );

function-graph.cabal

@@ -106,6 +106,8 @@ library test
                     , wai
                     , async
                     , streaming
+                    , transformers
+                    , time
     hs-source-dirs:   src/test
     default-language: Haskell2010
 
@@ -208,4 +210,6 @@ executable test-web
     , async
     , streaming
     , html-parse
+    , ansi-terminal
+    , temporary
   default-language: Haskell2010

src/lib/FunGraph.hs

@@ -171,14 +171,15 @@ queryTreeTimeoutIOTrace
   :: ( v ~ FullyQualifiedType
      , meta ~ NE.NonEmpty TypedFunction
      )
-  => DG.Digraph RealWorld v meta
+  => (String -> ST RealWorld ()) -- ^ Trace function
+  -> DG.Digraph RealWorld v meta
   -> Data.Time.NominalDiffTime
   -> Int
   -> (v, v)
   -> ExceptT (GraphActionError v) IO
       (S.Stream (S.Of ([meta], Double)) IO (Maybe ()) )
-queryTreeTimeoutIOTrace g =
-  queryTreeTimeoutIO' g $ Dijkstra.runDijkstraTraceGeneric (>>= traceFunDebug)
+queryTreeTimeoutIOTrace traceFun g =
+  queryTreeTimeoutIO' g $ Dijkstra.runDijkstraTraceGeneric (>>= traceFunDebugGeneric traceFun)
 
 queryTreeTimeoutIO'
   :: forall v meta.
@@ -285,22 +286,23 @@ queryTreeGA maxCount (src, dst) =
         edgeWeightNE =
           minimum $ map (functionWeight (src, dst)) (NE.toList functions)
 
-traceFunDebug
-  :: Dijkstra.TraceEvent FullyQualifiedType (NE.NonEmpty TypedFunction) Double
+traceFunDebugGeneric
+  :: (String -> ST s ()) -- ^ Trace function
+  -> Dijkstra.TraceEvent FullyQualifiedType (NE.NonEmpty TypedFunction) Double
   -> ST s ()
-traceFunDebug = \case
-    Dijkstra.TraceEvent_Init srcVertex _ -> traceM . T.unpack $ T.unwords
+traceFunDebugGeneric traceFun = \case
+    Dijkstra.TraceEvent_Init srcVertex _ -> traceFun . T.unpack $ T.unwords
       [ "Starting Bellman-Ford for source vertex"
       , renderFullyQualifiedType (fst srcVertex)
       ]
 
     Dijkstra.TraceEvent_Push edge weight pathTo ->
-      maybe (pure ()) traceM (traceInterestingPush edge weight pathTo)
+      maybe (pure ()) traceFun (traceInterestingPush edge weight pathTo)
 
     Dijkstra.TraceEvent_Pop v weight pathTo ->
-      maybe (pure ()) traceM (traceInterestingPop v weight pathTo)
+      maybe (pure ()) traceFun (traceInterestingPop v weight pathTo)
 
-    Dijkstra.TraceEvent_FoundPath number weight path -> traceM $ unwords
+    Dijkstra.TraceEvent_FoundPath number weight path -> traceFun $ unwords
         [ "Found path no."
         , show number
         , "with length"
@@ -313,6 +315,11 @@ traceFunDebug = \case
           in unlines $ map (\fn -> "\t" <> renderComposedFunctionsStr fn <> " :: " <> renderTypeSig fn) allPaths
         ]
 
+    Dijkstra.TraceEvent_Done srcVertex -> traceFun . T.unpack $ T.unwords
+      [ "Terminating Bellman-Ford for source vertex"
+      , renderFullyQualifiedType (fst srcVertex)
+      ]
+
     _ -> pure ()
   where
     interestingVertices = Set.fromList $ map parsePprTyConSingleton
@@ -393,6 +400,12 @@ traceFunDebug = \case
           ]
         else Nothing
 
+traceFunDebug
+  :: Dijkstra.TraceEvent FullyQualifiedType (NE.NonEmpty TypedFunction) Double
+  -> ST s ()
+traceFunDebug =
+  traceFunDebugGeneric traceM
+
 data GraphActionError v
   = GraphActionError_NoSuchVertex v
       deriving (Eq, Show, Ord, Generic)

src/server/Server.hs

@@ -6,7 +6,7 @@ module Server
   ( main
   , app
   , withHandlers
-  , Server.Pages.Search.defaultSearchConfig
+  , Server.Pages.Search.defaultSearchConfig, Server.Pages.Search.SearchConfig(..)
   )
   where
 

src/server/Server/Pages/Search.hs

@@ -40,6 +40,7 @@ import qualified Streaming.Prelude as S
 import qualified Data.BalancedStream
 import Control.Monad (when)
 import qualified Data.Time.Clock
+import qualified Control.Monad.ST
 
 -- | Things we want to precompute when creating the handler
 data SearchEnv = SearchEnv
@@ -50,11 +51,14 @@ data SearchEnv = SearchEnv
 -- | TODO
 data SearchConfig = SearchConfig
   { searchConfigTimeout :: !Data.Time.Clock.NominalDiffTime
+  , searchConfigTrace :: !(Maybe (String -> Control.Monad.ST.ST Control.Monad.ST.RealWorld ()))
+  -- ^ Optionally print tracing information for each search query
   }
 
 defaultSearchConfig :: SearchConfig
 defaultSearchConfig = SearchConfig
   { searchConfigTimeout = 0.1
+  , searchConfigTrace = Nothing
   }
 
 createSearchEnv
@@ -223,9 +227,15 @@ page cfg (SearchEnv graph lookupVertex) srcTxt dstTxt maxCount' mNoGraph = do
         pure
         (lookupVertex txt)
 
+    queryTreeTimeoutIO =
+      maybe
+        FunGraph.queryTreeTimeoutIO
+        FunGraph.queryTreeTimeoutIOTrace
+        (searchConfigTrace cfg)
+
     query' srcDst =
       ET.runExceptT $
-          FunGraph.queryTreeTimeoutIO
+          queryTreeTimeoutIO
             graph
             timeout
             maxCount

src/test/FunGraph/Test.hs

@@ -6,9 +6,14 @@
 {-# HLINT ignore "Use camelCase" #-}
 {-# HLINT ignore "Use fmap" #-}
 module FunGraph.Test
-( allTestCases
-, QueryTest(..), queryTest_runQuery
+( -- * Test cases
+  allTestCases
+, QueryTest(..), Args
+  -- * Helper types
 , PPFunctions(..)
+, QueryResults
+  -- * Query functions
+, mkQueryFunctions
 )
 where
 
@@ -22,26 +27,28 @@ import Control.DeepSeq (NFData)
 import GHC.Generics (Generic)
 import Data.Bifunctor (first)
 import qualified Data.Text as T
+import qualified Control.Monad.Trans.Except as Except
+import qualified Streaming.Prelude as S
+import qualified Control.Monad.ST as ST
+import qualified Data.Time
+import qualified Streaming as S
 
 data QueryTest = QueryTest
     { queryTest_name :: String
-    , queryTest_runQueryFun
-        :: forall s v meta.
-           (v ~ FunGraph.FullyQualifiedType, meta ~ NE.NonEmpty FunGraph.TypedFunction)
-        => Args
-        -> FunGraph.GraphAction s v meta [(PPFunctions, Double)]
     , queryTest_args :: Args
     , queryTest_expectedResult :: Set.Set PPFunctions
     }
 
 type Args = (Int, (FunGraph.FullyQualifiedType, FunGraph.FullyQualifiedType)) -- ^ (maxCount, (src, dst))
 
--- | Apply 'queryTest_runQueryFun' to 'queryTest_args'
-queryTest_runQuery
-  :: QueryTest
+-- | Test 'FunGraph.queryTreeAndPathsGA'
+queryTreeAndPathsGAListTest
+  :: Args
   -> FunGraph.GraphAction s FunGraph.FullyQualifiedType (NE.NonEmpty FunGraph.TypedFunction) [(PPFunctions, Double)]
-queryTest_runQuery qt =
-  queryTest_runQueryFun qt (queryTest_args qt)
+queryTreeAndPathsGAListTest args =
+  mapQueryResult . snd <$> uncurry FunGraph.queryTreeAndPathsGA args
+  where
+    mapQueryResult = map (first $ PPFunctions . map void)
 
 mkTestCase
   :: Int
@@ -51,14 +58,10 @@ mkTestCase
 mkTestCase maxCount (from, to) expectedList =
     QueryTest
         { queryTest_name = unwords [snd from, "to", snd to]
-        , queryTest_runQueryFun = \args ->
-            mapQueryResult . snd <$> uncurry FunGraph.queryTreeAndPathsGA args
         , queryTest_args = (maxCount, (fst from, fst to))
         , queryTest_expectedResult = Set.fromList $ fns expectedList
         }
   where
-    mapQueryResult = map (first $ PPFunctions . map void)
-
     fns :: [T.Text] -> [PPFunctions]
     fns = map (PPFunctions . NE.toList . fn)
 
@@ -68,6 +71,51 @@ mkTestCase maxCount (from, to) expectedList =
       id
       (FunGraph.parseComposedFunctions bs)
 
+-- | Test 'FunGraph.queryTreeTimeoutIO'
+queryTreeAndPathsGAStreamTest
+  :: ( v ~ FunGraph.FullyQualifiedType
+     )
+  => Data.Time.NominalDiffTime -- ^ timeout
+  -> Args
+  -> FunGraph.Digraph ST.RealWorld FunGraph.FullyQualifiedType (NE.NonEmpty FunGraph.TypedFunction)
+  -> IO (Either (FunGraph.GraphActionError v) [(PPFunctions, Double)])
+queryTreeAndPathsGAStreamTest timeout (maxCount, srcDst) graph =
+  Except.runExceptT $
+    S.lift . S.toList_ =<< streamExcept
+  where
+    streamExcept =
+      S.concat . S.map toPPFunctions <$> queryTreeAndPathsGAStream
+
+    queryTreeAndPathsGAStream =
+      S.map (\tree -> (tree, FunGraph.queryResultTreeToPaths maxCount srcDst [tree]))
+        <$> FunGraph.queryTreeTimeoutIO graph timeout maxCount srcDst
+
+    toPPFunctions
+      :: (([NE.NonEmpty FunGraph.TypedFunction], Double), [([FunGraph.TypedFunction], Double)])
+      -> [(PPFunctions, Double)]
+    toPPFunctions = map (first $ PPFunctions . map void) . snd
+
+type QueryResults =
+  Either (FunGraph.GraphActionError FunGraph.FullyQualifiedType) [(FunGraph.Test.PPFunctions, Double)]
+
+-- | The query functions we want to test
+mkQueryFunctions
+  :: Bool -- ^ enable tracing?
+  -> NE.NonEmpty (String, Args -> FunGraph.Graph ST.RealWorld -> IO QueryResults)
+mkQueryFunctions shouldTrace = NE.fromList
+  [ ("Stream", FunGraph.Test.queryTreeAndPathsGAStreamTest 1000)
+  , ("List", queryTestList)
+  ]
+  where
+    queryTestList
+      :: FunGraph.Test.Args
+      -> FunGraph.Graph ST.RealWorld
+      -> IO QueryResults
+    queryTestList args graph =
+      let runQueryFunction =
+            if shouldTrace then FunGraph.runGraphActionTrace else FunGraph.runGraphAction
+      in ST.stToIO $ runQueryFunction graph $ FunGraph.Test.queryTreeAndPathsGAListTest args
+
 allTestCases :: [QueryTest]
 allTestCases =
   [ case1
@@ -105,7 +153,7 @@ case3 =
 
 case4 :: QueryTest
 case4 =
-  mkTestCase 100
+  mkTestCase 45
     (strictByteString, lazyText)
     [ "text-2.0.2:Data.Text.Lazy.pack . bytestring-0.11.4.0:Data.ByteString.Char8.unpack"
     , "text-2.0.2:Data.Text.Lazy.fromStrict . text-2.0.2:Data.Text.Encoding.decodeASCII"

src/test/FunGraph/Test/Util.hs

@@ -10,6 +10,7 @@ module FunGraph.Test.Util
 , runWarpTestRandomPort
 , isSupersetOf
 , StreamIOHtml
+, testDataFileName
 )
 where
 
@@ -40,6 +41,9 @@ import Server.HtmlStream (HtmlStream, toStream)
 import Test.Hspec.Expectations.Pretty (shouldBe)
 import Lucid.Base (Html)
 
+testDataFileName :: FilePath
+testDataFileName = "data/all3.json"
+
 isSupersetOf :: (Show a, Ord a) => Set.Set a -> Set.Set a -> IO ()
 isSupersetOf actual expected =
   actual `shouldBe` Set.union actual expected