Update ExternsDiff.checkUsage, add tests

Author: wclr

src/Language/PureScript/Make/ExternsDiff.hs

@@ -241,21 +241,22 @@ checkDiffs (P.Module _ _ _ decls exports) diffs
 -- Goes though the module and try to find any usage of the refs.
 -- Takes a set of refs to search in module's declarations, if found returns True.
 checkUsage :: Set (Maybe ModuleName, Ref) -> [P.Declaration] -> Bool
-checkUsage searches decls = foldMap findUsage decls /= mempty
+checkUsage searches decls = anyUsages
   where
-    findUsage decl =
-      let (extr, _, _, _, _) = P.everythingWithScope goDecl goExpr goBinder mempty mempty
-       in extr mempty decl
+    -- Two traversals: one to pick up usages of types, one for the rest.
+    Any anyUsages =
+      foldMap checkUsageInTypes decls
+        <> foldMap checkOtherUsages decls
 
-    toSearched = (,) <$> P.getQual <*> P.disqualify
+    -- To check data constructors we remove an origin type from it (see `checkCtor`).
+    searches' = S.map (map stripCtorType) searches
 
     -- To check data constructors we remove an origin type from it.
     emptyName = P.ProperName ""
     stripCtorType (ConstructorRef _ n) = ConstructorRef emptyName n
     stripCtorType x = x
 
-    searches' = S.map (map stripCtorType) searches
-    check = Any . flip S.member searches' . toSearched
+    check q = Any $ S.member (P.getQual q, P.disqualify q) searches'
 
     checkType = check . map TypeRef
     checkTypeOp = check . map TypeOpRef
@@ -264,31 +265,21 @@ checkUsage searches decls = foldMap findUsage decls /= mempty
     checkCtor = check . map (ConstructorRef emptyName)
     checkClass = check . map TypeClassRef
 
-    onTypes = P.everythingOnTypes (<>) $ \case
-      P.TypeConstructor _ n -> checkType n
-      P.TypeOp _ n -> checkTypeOp n
-      P.ConstrainedType _ c _ -> checkClass (P.constraintClass c)
-      _ -> mempty
-
-    foldCtor f (P.DataConstructorDeclaration _ _ vars) =
-      foldMap (f . snd) vars
+    -- A nested traversal: pick up types in the module then traverse the structure of the types
+    (checkUsageInTypes, _, _, _, _) =
+      P.accumTypes $ P.everythingOnTypes (<>) $ \case
+        P.TypeConstructor _ n -> checkType n
+        P.TypeOp _ n -> checkTypeOp n
+        P.ConstrainedType _ c _ -> checkClass (P.constraintClass c)
+        _ -> mempty
 
-    constraintTypes =
-      foldMap (\c -> P.constraintArgs c <> P.constraintKindArgs c)
+    checkOtherUsages =
+      let (extr, _, _, _, _) = P.everythingWithScope goDecl goExpr goBinder mempty mempty
+       in extr mempty
 
     goDecl _ = \case
-      P.TypeDeclaration t -> onTypes (P.tydeclType t)
-      P.DataDeclaration _ _ _ _ ctors -> foldMap (foldCtor onTypes) ctors
-      P.TypeSynonymDeclaration _ _ _ t -> onTypes t
-      P.KindDeclaration _ _ _ t -> onTypes t
-      P.FixityDeclaration _ (Right (P.TypeFixity _ tn _)) ->
-        checkType tn
-      P.FixityDeclaration _ (Left (P.ValueFixity _ (P.Qualified by val) _)) ->
-        either (checkValue . P.Qualified by) (checkCtor . P.Qualified by) val
-      P.TypeClassDeclaration _ _ _ cs _ _ ->
-        foldMap onTypes (constraintTypes cs)
-      P.TypeInstanceDeclaration _ _ _ _ _ cs tc sts _ ->
-        foldMap onTypes (constraintTypes cs <> sts) <> checkClass tc
+      P.TypeInstanceDeclaration _ _ _ _ _ _ tc _ _ ->
+        checkClass tc
       _ -> mempty
 
     isLocal scope ident = P.LocalIdent ident `S.member` scope
@@ -298,7 +289,6 @@ checkUsage searches decls = foldMap findUsage decls /= mempty
         | otherwise -> checkValue n
       P.Constructor _ n -> checkCtor n
       P.Op _ n -> checkValueOp n
-      P.TypedValue _ _ t -> onTypes t
       _ -> mempty
 
     goBinder _ binder = case binder of

tests/TestMake.hs

@@ -9,7 +9,7 @@ import Language.PureScript qualified as P
 import Language.PureScript.CST qualified as CST
 
 import Control.Concurrent (threadDelay)
-import Control.Monad (guard, void, forM_)
+import Control.Monad (guard, void, forM_, when)
 import Control.Exception (tryJust)
 import Control.Monad.IO.Class (liftIO)
 import Control.Concurrent.MVar (readMVar, newMVar, modifyMVar_)
@@ -19,11 +19,13 @@ import Data.Text qualified as T
 import Data.Set (Set)
 import Data.Set qualified as Set
 import Data.Map qualified as M
+import Data.Version (showVersion)
 
+import Paths_purescript qualified as Paths
 import System.FilePath ((</>))
 import System.Directory (createDirectory, removeDirectoryRecursive, removeFile, setModificationTime)
 import System.IO.Error (isDoesNotExistError)
-import System.IO.UTF8 (readUTF8FilesT, writeUTF8FileT)
+import System.IO.UTF8 (readUTF8FilesT, readUTF8FileT, writeUTF8FileT)
 
 import Test.Hspec (Spec, before_, it, shouldReturn)
 
@@ -55,6 +57,9 @@ spec = do
 
           forM_ (zip [0..] modules) $ \(idx, (mn, content, _)) -> do
             writeFile (modulePath mn) (timestamp idx) content
+            -- Write a fake foreign module to bypass compiler's check.
+            when (T.isInfixOf "\nforeign import" content) $
+              writeFile (foreignJsPath mn) (timestamp idx) content
 
           compile paths `shouldReturn` moduleNames names
 
@@ -189,15 +194,15 @@ spec = do
     it "recompiles if docs are requested but not up to date" $ do
       let mPath = sourcesDir </> "Module.purs"
 
-          moduleContent1 = "module Module where\nx :: Int\nx = 1"
-          moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1"
+          mContent1 = "module Module where\nx :: Int\nx = 1"
+          mContent2 = mContent1 <> "\ny :: Int\ny = 1"
 
           optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.Docs] }
           go opts = compileWithOptions opts [mPath] >>= assertSuccess
 
-      writeFile mPath timestampA moduleContent1
+      writeFile mPath timestampA mContent1
       go optsWithDocs `shouldReturn` moduleNames ["Module"]
-      writeFile mPath timestampB moduleContent2
+      writeFile mPath timestampB mContent2
       -- See Note [Sleeping to avoid flaky tests]
       threadDelay oneSecond
       go P.defaultOptions `shouldReturn` moduleNames ["Module"]
@@ -207,21 +212,42 @@ spec = do
 
     it "recompiles if CoreFn is requested but not up to date" $ do
       let mPath = sourcesDir </> "Module.purs"
-          moduleContent1 = "module Module where\nx :: Int\nx = 1"
-          moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1"
+          mContent1 = "module Module where\nx :: Int\nx = 1"
+          mContent2 = mContent1 <> "\ny :: Int\ny = 1"
           optsCoreFnOnly = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.CoreFn }
           go opts = compileWithOptions opts [mPath] >>= assertSuccess
 
-      writeFile mPath timestampA moduleContent1
+      writeFile mPath timestampA mContent1
       go optsCoreFnOnly `shouldReturn` moduleNames ["Module"]
-      writeFile mPath timestampB moduleContent2
+      writeFile mPath timestampB mContent2
       -- See Note [Sleeping to avoid flaky tests]
       threadDelay oneSecond
       go P.defaultOptions `shouldReturn` moduleNames ["Module"]
       -- Since the existing CoreFn.json is now outdated, the module should be
       -- recompiled.
       go optsCoreFnOnly `shouldReturn` moduleNames ["Module"]
 
+    it "recompiles if cache-db version differs from the current" $ do
+      let mPath = sourcesDir </> "Module.purs"
+          mContent = "module Module where\nfoo :: Int\nfoo = 1\n"
+
+      writeFile mPath timestampA mContent
+      compile [mPath] `shouldReturn` moduleNames ["Module"]
+
+      -- Replace version with illegal in cache-db file.
+      let cacheDbFilePath = P.cacheDbFile modulesDir
+          versionText ver = "\"version\":\"" <> ver <> "\""
+
+      cacheContent <- readUTF8FileT cacheDbFilePath
+
+      let currentVer = T.pack (showVersion Paths.version)
+      let newContent =
+            T.replace (versionText currentVer) (versionText "0.0.0") cacheContent
+
+      writeUTF8FileT cacheDbFilePath newContent
+
+      compile [mPath] `shouldReturn` moduleNames ["Module"]
+
     -- Cut off rebuild tests.
 
     -- If a module is compiled with effective changes for downstream they should
@@ -433,13 +459,34 @@ spec = do
       )
       ["A"]
 
+    -- Type synonym in foreign import.
+    recompile2 it "type synonym changed in foreign import"
+      ( "module A where\ntype SynA = Int\n"
+      , "module A where\ntype SynA = String\n"
+      , "module B where\nimport A as A\nforeign import a :: A.SynA\n"
+      )
+
     -- Type synonym change.
     recompile2 it "type synonym changed"
       ( "module A where\ntype SynA = Int\n"
       , "module A where\ntype SynA = String\n"
       , "module B where\nimport A as A\ntype SynB = Array A.SynA\n"
       )
 
+    -- Type synonym change in value.
+    recompile2 it "type synonym changed in value"
+      ( "module A where\ntype SynA = Int\n"
+      , "module A where\ntype SynA = String\n"
+      , "module B where\nimport A as A\nvalue = ([] :: Array A.SynA)\n"
+      )
+
+    -- Type synonym change in pattern.
+    recompile2 it "type synonym changed in pattern"
+      ( "module A where\ntype SynA = Int\n"
+      , "module A where\ntype SynA = String\n"
+      , "module B where\nimport A as A\nfn = \\(_ :: Array A.SynA) -> 0\n"
+      )
+
     -- Type synonym indirect change.
     recompile2 it "type synonym dependency changed"
       ( "module A where\ntype SynA = Int\ntype SynA2 = SynA\n"
@@ -516,7 +563,6 @@ spec = do
       , "module B where\nimport A\nt = 1 :+: \"1\" "
       )
 
-
     -- Type operator change.
     recompile2 it "type op changed"
       ( "module A where\ndata T a b = T a b\ninfixl 2 type T as :+:\n"