Fix occurs check bug

.github/workflows/haskell.yml

@@ -69,6 +69,9 @@ jobs:
     - name: Run elm-test-rs tests
       run: python3 run-test-rs-tests.py
 
+    - name: Run compiler-output tests
+      run: python3 run-compiler-output-tests.py
+
     - name: Upload Artifacts
       uses: actions/upload-artifact@v4
       with:

.github/workflows/release.yml

@@ -63,6 +63,9 @@ jobs:
     - name: Run elm-test-rs tests
       run: python3 run-test-rs-tests.py
 
+    - name: Run compiler-output tests
+      run: python3 run-compiler-output-tests.py
+
     # Extract the current git tag
     - name: Extract Git Tag
       id: get_version

compiler-output-tests/elm.json

@@ -0,0 +1,25 @@
+{
+    "type": "application",
+    "source-directories": [
+        "src"
+    ],
+    "elm-version": "0.19.1",
+    "dependencies": {
+        "direct": {
+            "elm/browser": "1.0.2",
+            "elm/core": "1.0.5",
+            "elm/html": "1.0.0"
+        },
+        "indirect": {
+            "elm/json": "1.1.3",
+            "elm/time": "1.0.0",
+            "elm/url": "1.0.0",
+            "elm/virtual-dom": "1.0.3"
+        }
+    },
+    "test-dependencies": {
+        "direct": {},
+        "indirect": {}
+    },
+    "zokka-package-overrides": []
+}

compiler-output-tests/src/BadOccursCheck.elm

@@ -0,0 +1,12 @@
+module BadOccursCheck exposing (..)
+
+-- https://github.com/elm/compiler/issues/2241
+
+foldMap : (a -> b) -> (a -> c) -> (b -> c -> c) -> a -> c
+foldMap fab fac fbc a = fac a
+
+f : a -> a -> a
+f x y = x
+
+break : Float -> (Float, Float)
+break input = foldMap identity (\x -> (x, x)) (\( low, high ) x -> ( f low x, f high x )) input

compiler-output-tests/src/BadOccursCheck1.elm

@@ -0,0 +1,40 @@
+module BadOccursCheck1 exposing (..)
+-- From an error that showed up on incremental-elm Slack
+
+-- This file will cause the vanilla Elm compiler to hang when compiling.
+
+type Effect msg = Effect
+
+type Msg = Msg1 Int | Msg2 Int
+
+-- All our functions will be infinite loops since this is only meant to test
+-- type checking and we don't care about any runtime stuff
+-- We won't use Debug.todo just in case we want to double-check that all of
+-- this works fine when we run `--optimize` (although presently I can't
+-- think of any reason why --optimize would change anything WRT
+-- typechecking, but just in case!)
+applyIf : Bool -> (a -> a) -> a -> a
+applyIf x = applyIf x
+
+update : model -> ( model, Effect msg )
+update x = update x
+
+withQuery : (data -> msg) -> Effect msg -> ( model, Effect msg ) -> ( model, Effect msg )
+withQuery f = withQuery f
+
+-- A nice hack to get us values without resorting to Debug.todo
+-- Can't just directly do x = x because the Elm compiler detects that
+makeAnything : a -> b
+makeAnything x = makeAnything x
+
+query1 = makeAnything ()
+
+query2 = makeAnything ()
+
+model = makeAnything ()
+
+result condition =
+    model
+        |> update
+        |> applyIf condition withQuery Msg1 query1
+        |> applyIf condition withQuery Msg1 query2

compiler/src/Generate/JavaScript.hs

@@ -30,7 +30,6 @@ import qualified Generate.Mode as Mode
 import qualified Reporting.Doc as D
 import qualified Reporting.Render.Type as RT
 import qualified Reporting.Render.Type.Localizer as L
-import qualified Debug.Trace as Debug
 import Control.Exception (Exception, throw)
 import qualified Elm.Package as Pkg
 import qualified Data.Maybe as Maybe

compiler/src/Generate/JavaScript/Expression.hs

@@ -36,7 +36,6 @@ import qualified Json.Encode as Encode
 import Json.Encode ((==>))
 import qualified Optimize.DecisionTree as DT
 import qualified Reporting.Annotation as A
-import qualified Debug.Trace as Debug
 
 
 

compiler/src/Type/Unify.hs

@@ -166,15 +166,33 @@ fresh (Context _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =
 guardedUnify :: Variable -> Variable -> Unify ()
 guardedUnify left right =
   Unify $ \vars ok err ->
-    do  equivalent <- UF.equivalent left right
-        if equivalent
-          then ok vars ()
+    do  -- It might be possible to actually just do == instead of >. This is
+        -- because it might be the case that if a variable is not infinite
+        -- right now, it won't ever be infinite during this particular unify
+        -- call. But I haven't really thought that through enough to be
+        -- confident putting it in.
+        --
+        -- Note that we ultimately decided against doing a recursion depth check
+        -- as detailed in
+        -- https://github.com/Zokka-Dev/zokka-compiler/pull/20#issuecomment-2234089482
+        -- This is because we didn't want to have an unpredictable performance
+        -- profile (i.e. mysterious immediate slowdown).
+        -- If we see slowdown we want to know soon so that we can think about a
+        -- better fix. So far benchmarks seem to show that this causes minimal slowdown.
+        occursLeft <- Occurs.occurs left
+        occursRight <- Occurs.occurs right
+        equivalent <- UF.equivalent left right
+        if occursLeft || occursRight
+          then err vars ()
           else
-            do  leftDesc <- UF.get left
-                rightDesc <- UF.get right
-                case actuallyUnify (Context left leftDesc right rightDesc) of
-                  Unify k ->
-                    k vars ok err
+            if equivalent
+              then ok vars ()
+              else
+                do  leftDesc <- UF.get left
+                    rightDesc <- UF.get right
+                    case actuallyUnify (Context left leftDesc right rightDesc) of
+                      Unify k ->
+                        k vars ok err
 
 
 subUnify :: Variable -> Variable -> Unify ()

elm-test-rs-tests/tests/Tests.elm

@@ -12,7 +12,7 @@ import TCOMiscompilation4 exposing (tcoMiscompilation4Test0, tcoMiscompilation4T
 
 
 suite : Test
-suite = describe "TCO tests" 
+suite = describe "All tests" 
     [ anotherBadClosureTest
     , tcoProducesBadClosuresTest
     , tcoMiscompilation0Test

run-compiler-output-tests.py

@@ -0,0 +1,40 @@
+import subprocess
+import os
+import timeit
+
+def run_zokka_make(zokka_cmd, file_to_make, project_dir):
+    return subprocess.run([zokka_cmd, "make", file_to_make], cwd=project_dir)
+
+if __name__ == "__main__":
+
+    start_time = timeit.default_timer()
+
+    find_zokka_cmd = ["cabal", "list-bin", "zokka"]
+
+
+    zokka_exec_location = \
+        subprocess.run(find_zokka_cmd, capture_output=True).stdout.strip()
+
+    run_zokka_make_cmd = [zokka_exec_location, ]
+
+    current_dir = "."
+
+    top_level_tests_dir = os.path.join(current_dir, "compiler-output-tests")
+
+    print(f"=========\nRunning compiler-output tests found in {top_level_tests_dir}\n=========\n")
+
+    bad_occurs_check_test_0 =\
+        run_zokka_make(zokka_exec_location, os.path.join("src", "BadOccursCheck.elm"), top_level_tests_dir)
+
+    if bad_occurs_check_test_0.returncode == 0:
+        raise Exception("Our bad occurs check failed! The compiler succeeded when it should have failed!")
+
+    bad_occurs_check_test_1 =\
+        run_zokka_make(zokka_exec_location, os.path.join("src", "BadOccursCheck1.elm"), top_level_tests_dir)
+
+    if bad_occurs_check_test_1.returncode == 0:
+        raise Exception("Our bad occurs check failed! The compiler succeeded when it should have failed!")
+
+    total_test_duration = timeit.default_timer() - start_time
+
+    print(f"=========\nTotal test duration: {total_test_duration} seconds\n=========\n")