Fix loopy-import test

Account for the fact we can now import ngrams terms containing loops.

test/Test/API/UpdateList.hs

@@ -611,8 +611,8 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
             liftIO $ exportedNgrams `shouldBe` exportedNgrams2
 
       -- We test that if we try to import terms which, when merged with the existing,
-      -- would cause a loop, GGTX is capable of rejecting the request.
-      it "refuses to import terms which will lead to a loop" $ \(SpecContext testEnv port app _) -> do
+      -- would cause a loop but GGTX is capable of breaking them, serving the request.
+      it "allows importing terms which will lead to a loop (because it can break them)" $ \(SpecContext testEnv port app _) -> do
         cId <- newCorpusForUser testEnv "alice"
         let log_cfg = (test_config testEnv) ^. gc_logging
         withApplication app $ do
@@ -685,14 +685,14 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
                                       }
             ji <- checkEither $ liftIO $ runClientM (add_form_to_list token listId params) clientEnv
             ji' <- pollUntilWorkFinished log_cfg port ji
-            -- Unfortunately we don't have a better way then to match on the stringified exception, sigh.
             case _scst_events ji' of
               Just [ScraperEvent{..}]
                 | Just msg <- _scev_message
-                -> liftIO $ msg `shouldSatisfy` \txt -> "Loop detected in terms: foo -> bar -> foo" `T.isInfixOf` txt
+                , "Loop detected in terms: foo -> bar -> foo" `T.isInfixOf` msg
+                -> fail (T.unpack msg)
                 | otherwise
-                -> fail "No suitable message in ScraperEvent."
-              _ -> fail "Expected job to fail, but it didn't"
+                -> pure () -- no loop!
+              _ -> pure () -- no loop!
 
 createDocsList :: FilePath
                -> TestEnv

test/Test/Instances.hs

@@ -13,6 +13,7 @@ Portability : POSIX
 
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Test.Instances where
 
@@ -772,9 +773,12 @@ genCorpusWithMatchingElement = do
         el  <- over ne_children (breakLoop trm) . makeItRoot <$> (resize depth arbitrary)
         pure (trm, el { _ne_ngrams = trm })
   -- Let's build the map first, so that duplicates will be overwritten.
-  fullMap <- (Map.fromList <$> vectorOf depth mkEntry) `suchThat` (\x -> isRight (buildForest (BreakLoop LBA_just_do_it) x)) -- exclude loops
-  let (hd NE.:| _) = NE.fromList $ Map.elems fullMap
-  pure $ AcyclicTableMap fullMap hd
+  fullMapE <- buildForest (BreakLoop LBA_just_do_it) . Map.fromList <$> vectorOf depth mkEntry
+  case fullMapE of
+    Left e -> panicTrace (show e)
+    Right (destroyForest -> fullMap) -> do
+      let (hd NE.:| _) = NE.fromList $ map snd fullMap
+      pure $ AcyclicTableMap (Map.fromList fullMap) hd
   where
     breakLoop :: NgramsTerm -> MSet NgramsTerm -> MSet NgramsTerm
     breakLoop t = mSetFromSet . Set.delete t . mSetToSet