WPB-5667: Updating integration tests to better handle comments and haddock.

changelog.d/5-internal/WPB-5667

@@ -0,0 +1,3 @@
+Improved how tests are automatically extracted from the `integration` test suite.
+
+The test extractor parser has been improved to handle block comments, and to more strictly check for Haddock documentation for each test.

integration/Setup.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE LambdaCase #-}
 {-# OPTIONS_GHC -Wall #-}
 
@@ -12,18 +13,21 @@ import Data.Maybe
 import Data.Monoid
 import qualified Data.Set as Set
 import Data.String
-import Distribution.Simple hiding (Module (..))
+import Distribution.Simple hiding (Language (..), Module (..))
 import Distribution.Simple.BuildPaths
 import Distribution.Simple.LocalBuildInfo
 import Distribution.Types.BuildInfo
 import Distribution.Types.Library
+import Distribution.Types.PackageDescription
 import Distribution.Utils.Path
+import Language.Haskell.Exts (Comment (..), Decl (TypeSig), Language (..), Module (..), Name (..), ParseMode (..), SrcSpanInfo, associateHaddock, fromParseResult, parseFileWithComments)
+import qualified Language.Haskell.Exts as Exts
 import System.Directory
 import System.FilePath
 import Prelude
 
-collectTests :: [FilePath] -> IO [(String, String, String, String)]
-collectTests roots = do
+collectTests :: FilePath -> [FilePath] -> IO [(String, String, String, String)]
+collectTests pkgRoot roots =
   concat <$> traverse (findAllTests . (<> "/Test")) roots
   where
     findAllTests :: FilePath -> IO [(String, String, String, String)]
@@ -34,7 +38,7 @@ collectTests roots = do
     findModuleTests :: FilePath -> FilePath -> IO [(String, String, String, String)]
     findModuleTests root path = do
       let modl = "Test." <> toModule root path
-      tests <- collectTestsInModule path
+      tests <- collectTestsInModule pkgRoot path
       pure $ map (\(testName, summary, full) -> (modl, testName, summary, full)) tests
 
     toModule :: FilePath -> FilePath -> String
@@ -52,41 +56,102 @@ collectTests roots = do
           concat <$> traverse (findPaths . (d </>)) entries
         else pure [d]
 
-contexts :: [a] -> [([a], a)]
-contexts = go [] []
-  where
-    go _ctx res [] = res
-    go ctx res (x : xs) = go (x : ctx) ((ctx, x) : res) xs
-
 stripHaddock :: String -> String
 stripHaddock = \case
-  '-' : '-' : ' ' : '|' : ' ' : xs -> xs
-  '-' : '-' : ' ' : '|' : xs -> xs
-  '-' : '-' : ' ' : xs -> xs
-  '-' : '-' : xs -> xs
+  ' ' : '|' : ' ' : xs -> xs
+  ' ' : '|' : xs -> xs
+  ' ' : '^' : ' ' : xs -> xs
+  ' ' : '^' : xs -> xs
+  ' ' : xs -> xs
   xs -> xs
 
 collectDescription :: [String] -> (String, String)
-collectDescription revLines =
-  let comments = reverse (map stripHaddock (takeWhile isComment revLines))
-   in case uncons comments of
-        Nothing -> ("", "")
-        Just (summary, rest) -> (summary, unlines (dropWhile null rest))
+collectDescription ls =
+  case uncons $ stripHaddock <$> ls of
+    Nothing -> ("", "")
+    Just (summary, rest) -> (summary, unlines (dropWhile null rest))
 
-isComment :: String -> Bool
-isComment ('-' : '-' : _) = True
-isComment _ = False
-
-collectTestsInModule :: FilePath -> IO [(String, String, String)]
-collectTestsInModule fn = do
-  s <- readFile fn
-  let xs = contexts (lines s)
-  pure $ flip mapMaybe xs $ \(previousLines, line) -> do
-    case words line of
-      (name@('t' : 'e' : 's' : 't' : _) : "::" : _) -> do
-        let (summary, fullDesc) = collectDescription previousLines
-        pure (name, summary, fullDesc)
-      _ -> Nothing
+collectTestsInModule :: FilePath -> FilePath -> IO [(String, String, String)]
+collectTestsInModule pkgRoot fn = do
+  -- associateHaddock requires all comments that we want to stick onto a test
+  -- should be in the Haddock style, otherwise they won't make it through the parser.
+  res <-
+    associateHaddock . fromParseResult
+      <$> parseFileWithComments
+        -- Haskell2010 is the closest we have to getting haskell-src-exts to
+        -- playing nicely with GHC2021. One annoying feature it can't handle is
+        -- ImportQualifiedPost, so all of our tests have to use traditional
+        -- qualified import syntax.
+        (ParseMode fn Haskell2010 extensions False False Nothing False)
+        absolutePath
+  case res of
+    Module _ _ _ _ decs ->
+      pure $
+        decs >>= \case
+          TypeSig _ names _ -> mapMaybe testName names
+          _ -> []
+    _ -> error "XmlPage and XmlHybrid handling not set up. Please fix me!"
+  where
+    extractComment :: Comment -> String
+    extractComment (Comment _ _ s) = s
+    testName :: Name (SrcSpanInfo, [Comment]) -> Maybe (String, String, String)
+    testName name =
+      let (n', comments) =
+            case name of
+              Ident (_, cs) n -> (n, extractComment <$> cs)
+              Symbol (_, cs) n -> (n, extractComment <$> cs)
+       in if "test" `isPrefixOf` n'
+            then
+              let (summary, rest) = collectDescription comments
+               in pure (n', summary, rest)
+            else Nothing
+    absolutePath = pkgRoot </> fn
+    -- All of the haskell-src-exts supported extensions that we are using.
+    -- Several that are in the cabal file couldn't be directly copied over,
+    -- but they aren't causing trouble at the moment.
+    -- ImportQualifiedPost is an important one we use elsewhere in this repo
+    -- that we can't use in `integration` as haskell-src-exts doesn't support
+    -- it currently.
+    extensions =
+      [ Exts.EnableExtension Exts.BangPatterns,
+        Exts.EnableExtension Exts.BlockArguments,
+        Exts.EnableExtension Exts.ConstraintKinds,
+        Exts.EnableExtension Exts.DataKinds,
+        Exts.EnableExtension Exts.DefaultSignatures,
+        Exts.EnableExtension Exts.DeriveFunctor,
+        Exts.EnableExtension Exts.DeriveGeneric,
+        Exts.EnableExtension Exts.DeriveTraversable,
+        Exts.EnableExtension Exts.DerivingStrategies,
+        Exts.EnableExtension Exts.DerivingVia,
+        Exts.EnableExtension Exts.EmptyCase,
+        Exts.EnableExtension Exts.FlexibleContexts,
+        Exts.EnableExtension Exts.FlexibleInstances,
+        Exts.EnableExtension Exts.FunctionalDependencies,
+        Exts.EnableExtension Exts.GADTs,
+        Exts.EnableExtension Exts.GeneralizedNewtypeDeriving,
+        Exts.EnableExtension Exts.InstanceSigs,
+        Exts.EnableExtension Exts.KindSignatures,
+        Exts.EnableExtension Exts.LambdaCase,
+        Exts.EnableExtension Exts.MultiParamTypeClasses,
+        Exts.EnableExtension Exts.MultiWayIf,
+        Exts.EnableExtension Exts.NamedFieldPuns,
+        Exts.EnableExtension Exts.OverloadedLabels,
+        Exts.EnableExtension Exts.PackageImports,
+        Exts.EnableExtension Exts.PatternSynonyms,
+        Exts.EnableExtension Exts.PolyKinds,
+        Exts.EnableExtension Exts.QuasiQuotes,
+        Exts.EnableExtension Exts.RankNTypes,
+        Exts.EnableExtension Exts.RecordWildCards,
+        Exts.EnableExtension Exts.ScopedTypeVariables,
+        Exts.EnableExtension Exts.StandaloneDeriving,
+        Exts.EnableExtension Exts.TupleSections,
+        Exts.EnableExtension Exts.TypeApplications,
+        Exts.EnableExtension Exts.TypeFamilies,
+        Exts.EnableExtension Exts.TypeFamilyDependencies,
+        Exts.EnableExtension Exts.TypeOperators,
+        Exts.EnableExtension Exts.UndecidableInstances,
+        Exts.EnableExtension Exts.ViewPatterns
+      ]
 
 testHooks :: UserHooks -> UserHooks
 testHooks hooks =
@@ -104,7 +169,7 @@ testHooks hooks =
       for_ (Map.lookup cname (componentNameMap l)) $ \compBIs -> do
         for_ compBIs $ \compBI -> do
           let dest = autogenComponentModulesDir l compBI </> "RunAllTests.hs"
-          tests <- collectTests roots
+          tests <- collectTests (dataDir p) roots
           let modules = Set.toList (Set.fromList (map (\(m, _, _, _) -> m) tests))
           createDirectoryIfMissing True (takeDirectory dest)
           writeFile

integration/default.nix

@@ -28,6 +28,7 @@
 , extra
 , filepath
 , gitignoreSource
+, haskell-src-exts
 , hex
 , HsOpenSSL
 , http-client
@@ -80,7 +81,14 @@ mkDerivation {
   src = gitignoreSource ./.;
   isLibrary = true;
   isExecutable = true;
-  setupHaskellDepends = [ base Cabal containers directory filepath ];
+  setupHaskellDepends = [
+    base
+    Cabal
+    containers
+    directory
+    filepath
+    haskell-src-exts
+  ];
   libraryHaskellDepends = [
     aeson
     aeson-pretty

integration/integration.cabal

@@ -17,6 +17,7 @@ custom-setup
     , containers
     , directory
     , filepath
+    , haskell-src-exts
 
 common common-all
   default-language:   GHC2021
@@ -50,6 +51,7 @@ common common-all
     MultiWayIf
     NamedFieldPuns
     NoImplicitPrelude
+    NoImportQualifiedPost
     OverloadedLabels
     OverloadedRecordDot
     PackageImports

integration/test/API/Brig.hs

@@ -1,14 +1,14 @@
 module API.Brig where
 
 import API.Common
-import Data.Aeson qualified as Aeson
-import Data.ByteString.Base64 qualified as Base64
-import Data.CaseInsensitive qualified as CI
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Base64 as Base64
+import qualified Data.CaseInsensitive as CI
 import Data.Foldable
 import Data.Function
-import Data.Text qualified as T
-import Data.Text.Encoding qualified as T
-import Data.Vector qualified as V
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Vector as V
 import GHC.Stack
 import Testlib.Prelude
 

integration/test/API/BrigInternal.hs

@@ -1,7 +1,7 @@
 module API.BrigInternal where
 
 import API.Common
-import Data.Aeson qualified as Aeson
+import qualified Data.Aeson as Aeson
 import Data.Aeson.Types (Pair)
 import Data.Function
 import Data.Maybe

integration/test/API/Cargohold.hs

@@ -1,15 +1,15 @@
 module API.Cargohold where
 
-import Codec.MIME.Type qualified as MIME
-import Data.Aeson qualified as Aeson
+import qualified Codec.MIME.Type as MIME
+import qualified Data.Aeson as Aeson
 import Data.ByteString.Builder
-import Data.ByteString.Lazy qualified as LBS
-import Data.ByteString.Lazy.Char8 qualified as LBSC
-import Data.Text qualified as T
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.Char8 as LBSC
+import qualified Data.Text as T
 import Data.Text.Encoding
 import Data.Time.Clock
 import GHC.Stack
-import Network.HTTP.Client qualified as HTTP
+import qualified Network.HTTP.Client as HTTP
 import Testlib.Prelude
 
 type LByteString = LBS.ByteString

integration/test/API/Common.hs

@@ -3,7 +3,7 @@ module API.Common where
 import Control.Monad
 import Control.Monad.IO.Class
 import Data.Array ((!))
-import Data.Array qualified as Array
+import qualified Data.Array as Array
 import System.Random (randomRIO)
 import Testlib.Prelude
 

integration/test/API/Federator.hs

@@ -2,7 +2,7 @@ module API.Federator where
 
 import Data.Function
 import GHC.Stack
-import Network.HTTP.Client qualified as HTTP
+import qualified Network.HTTP.Client as HTTP
 import Testlib.Prelude
 
 getMetrics ::

integration/test/API/Galley.hs

@@ -6,15 +6,15 @@ module API.Galley where
 import API.Common
 import Control.Lens hiding ((.=))
 import Control.Monad.Reader
-import Data.Aeson qualified as Aeson
-import Data.Aeson.Types qualified as Aeson
-import Data.ByteString.Base64 qualified as B64
-import Data.ByteString.Base64.URL qualified as B64U
-import Data.ByteString.Char8 qualified as BS
-import Data.ByteString.Lazy qualified as LBS
-import Data.ProtoLens qualified as Proto
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Base64.URL as B64U
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ProtoLens as Proto
 import Data.ProtoLens.Labels ()
-import Data.UUID qualified as UUID
+import qualified Data.UUID as UUID
 import Numeric.Lens
 import Proto.Otr as Proto
 import Testlib.Prelude

integration/test/API/GalleyInternal.hs

@@ -1,8 +1,8 @@
 module API.GalleyInternal where
 
-import Data.Aeson qualified as Aeson
+import qualified Data.Aeson as Aeson
 import Data.String.Conversions (cs)
-import Data.Vector qualified as Vector
+import qualified Data.Vector as Vector
 import GHC.Stack
 import Testlib.Prelude
 

integration/test/MLS/Util.hs

@@ -11,22 +11,22 @@ import Control.Monad.Codensity
 import Control.Monad.Cont
 import Control.Monad.Reader
 import Control.Monad.Trans.Maybe
-import Data.Aeson qualified as A
-import Data.Aeson qualified as Aeson
-import Data.ByteString qualified as BS
-import Data.ByteString.Base64 qualified as Base64
-import Data.ByteString.Char8 qualified as B8
-import Data.ByteString.Char8 qualified as C8
+import qualified Data.Aeson as A
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base64 as Base64
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString.Char8 as C8
 import Data.Default
 import Data.Foldable
 import Data.Function
-import Data.Map qualified as Map
+import qualified Data.Map as Map
 import Data.Maybe
-import Data.Set qualified as Set
-import Data.Text.Encoding qualified as T
+import qualified Data.Set as Set
+import qualified Data.Text.Encoding as T
 import Data.Traversable
-import Data.UUID qualified as UUID
-import Data.UUID.V4 qualified as UUIDV4
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUIDV4
 import GHC.Stack
 import Notifications
 import System.Directory

integration/test/SetupHelpers.hs

@@ -9,7 +9,7 @@ import API.Common
 import API.Galley
 import Control.Monad.Reader
 import Data.Aeson hiding ((.=))
-import Data.Aeson.Types qualified as Aeson
+import qualified Data.Aeson.Types as Aeson
 import Data.Default
 import Data.Function
 import Data.UUID.V1 (nextUUID)

integration/test/Test/AccessUpdate.hs

@@ -27,7 +27,18 @@ import SetupHelpers
 import Testlib.Prelude
 import Testlib.ResourcePool
 
--- @SF.Federation @SF.Separation @TSFI.RESTfulAPI @S2
+-- These two commented out tests exist to test the Setup.hs code.
+-- Both of these tests should not appear in the output.
+
+-- testBar :: HasCallStack => App ()
+-- testBar = pure ()
+
+{-
+testBaz :: HasCallStack => App ()
+testBaz = pure ()
+-}
+
+-- | @SF.Federation @SF.Separation @TSFI.RESTfulAPI @S2
 --
 -- The test asserts that, among others, remote users are removed from a
 -- conversation when an access update occurs that disallows guests from