{-# LANGUAGE OverloadedStrings #-}

module Test.Grin.Suite
  ( grinUnitTests,
    grinGoldenTests,
    grinEvalFixtureTests,
  )
where

import Aihc.Fc.Newtype (extractNewtypeInterface, lowerNewtypes, lowerNewtypesWithInterface)
import Aihc.Fc.Syntax
import Aihc.Grin
import Aihc.Tc (Kind (..), Levity (..), RuntimeRep (..), TcType (..), TyCon (..), TyVarId (..), Unique (..), runtimeRepOfType, typeKind)
import Aihc.Tc.Evidence (Coercion (..))
import Aihc.Tc.Types (mkTyCon)
import Aihc.Testing.EvalFixture qualified as EvalGolden
import Control.Monad (forM_)
import Data.List (isInfixOf)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import GrinGolden qualified
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)

grinUnitTests :: TestTree
grinUnitTests =
  testGroup
    "GRIN"
    [ testCase "pretty printer parenthesizes compound applications" $ do
        let first = GrinVar "$grin_tuple_2720" 2720 (BoxedRep Lifted)
            second = GrinVar "$grin_tuple_2721" 2721 (BoxedRep Lifted)
            function =
              GrinFunction
                { grinFunctionName = FunctionName "$grin_thunk_4",
                  grinFunctionLinkName = Nothing,
                  grinFunctionParameters = [first, second],
                  grinFunctionResultRep = BoxedRep Lifted,
                  grinFunctionBody = GrinApply (BoxedRep Lifted) (GrinVarValue first) [GrinVarValue second]
                }
            program =
              GrinProgram
                { grinConstructors = [],
                  grinPrimitives = [],
                  grinForeignCalls = [],
                  grinExternalGlobals = [],
                  grinExternalFunctions = [],
                  grinWhnfGlobals = [],
                  grinCafs = [],
                  grinFunctions = [function]
                }
        assertEqual
          "rendered program"
          ( unlines
              [ "$grin_thunk_4 ($grin_tuple_2720%2720 :: BoxedRep Lifted) ($grin_tuple_2721%2721 :: BoxedRep Lifted) -> BoxedRep Lifted =",
                "  apply @(BoxedRep Lifted) ($grin_tuple_2720%2720 :: BoxedRep Lifted) ($grin_tuple_2721%2721 :: BoxedRep Lifted)"
              ]
          )
          (renderProgram program <> "\n"),
      testCase "pretty printer does not repeat layout arities" $ do
        let layouts = [[IntRep], []]
            externalInfo = GrinCodeInfo "source" (FunctionName "external_code") layouts IntRep
            function =
              GrinFunction
                { grinFunctionName = FunctionName "entry",
                  grinFunctionLinkName = Nothing,
                  grinFunctionParameters = [],
                  grinFunctionResultRep = BoxedRep Lifted,
                  grinFunctionBody = GrinStore (GrinNode (GrinClosure (FunctionName "worker") layouts) [])
                }
            program =
              emptyGrinProgram
                { grinConstructors = [("Pair", layouts)],
                  grinExternalFunctions = [externalInfo],
                  grinFunctions = [function]
                }
            rendered = renderProgram program
        assertBool "constructor has only its layouts" ("constructor Pair [IntRep, []]" `isInfixOf` rendered)
        assertBool "external function has only its layouts" ("external source [[IntRep], []] -> IntRep" `isInfixOf` rendered)
        assertBool "closure has only its layouts" ("store (Pworker/[[IntRep], []])" `isInfixOf` rendered),
      testCase "FC lowering passes known WHNF arguments without thunk cells" $ do
        let program = lowerProgram applicationProgram
            rendered = renderProgram program
            storedNodes = concatMap (expressionStoredNodes . grinFunctionBody) (grinFunctions program)
        assertEqual "lint" [] (lintProgram program)
        assertBool "does not allocate a constructor argument thunk" (not (any isThunkNode storedNodes))
        assertBool "contains explicit application" ("apply " `isInfixOf` rendered),
      testCase "FC lowering evaluates case and apply operands explicitly" $ do
        let caseProgram = lowerProgram dictionaryProgram
            applyProgram = lowerProgram applicationProgram
        assertEqual "case lint" [] (lintProgram caseProgram)
        assertEqual "apply lint" [] (lintProgram applyProgram)
        assertBool "case operand is produced by eval" (any (containsExplicitOperand GrinCaseOperand) (grinFunctions caseProgram))
        assertBool "apply operand is produced by eval" (any (containsExplicitOperand GrinApplyOperand) (grinFunctions applyProgram)),
      testCase "interpreter case does not evaluate its operand" $ do
        result <- interpretProgramBinding "answer" implicitCaseEvaluationProgram
        case result of
          Left (InterpretNoMatchingAlternative RuntimeLocation {}) -> pure ()
          other -> assertFailure ("expected a non-matching heap pointer, got " <> show other),
      testCase "interpreter apply does not evaluate its operand" $ do
        result <- interpretProgramBinding "answer" implicitApplyEvaluationProgram
        case result of
          Left (InterpretApplyNonFunction RuntimeLocation {}) -> pure ()
          other -> assertFailure ("expected a non-function heap pointer, got " <> show other),
      testCase "interpreter eval preserves a stored WHNF pointer" $ do
        result <- interpretProgramFunctionSnapshot storedWhnfEntry storedWhnfEvalProgram
        assertEqual
          "snapshot"
          (Right "return: @0\nheap:\n  @0 = CBox\n")
          (renderHeapSnapshot <$> result),
      testCase "interpreter represents a static WHNF as a heap pointer" $ do
        result <- interpretProgramFunctionSnapshot staticWhnfEntry staticWhnfProgram
        assertEqual
          "snapshot"
          (Right "return: @0\nheap:\n  @0 = CBox\n")
          (renderHeapSnapshot <$> result),
      testCase "interpreter applies a stored WHNF closure" $ do
        result <- interpretProgramFunctionSnapshot storedClosureEntry storedClosureApplyProgram
        assertEqual
          "snapshot"
          (Right "return: @0\nheap:\n  @0 = CBox\n")
          (renderHeapSnapshot <$> result),
      testCase "interpreter matches a stored WHNF constructor" $ do
        result <- interpretProgramFunctionSnapshot storedWhnfCaseEntry storedWhnfCaseProgram
        assertEqual
          "snapshot"
          (Right "return: @0\nheap:\n  @0 = CBox\n")
          (renderHeapSnapshot <$> result),
      testCase "interpreter implements fetch and update" $ do
        result <- interpretProgramBinding "answer" heapProgram
        assertEqual "result" (Right "Box 2") result,
      testCase "interpreter rejects unlifted thunk results" $ do
        result <- interpretProgramBinding "bad" (unliftedHeapProgram IntRep)
        assertEqual "result" (Left (InterpretInvalidThunkResultRep unliftedThunkFunction IntRep)) result,
      testCase "interpreter rejects unlifted heap updates" $ do
        result <- interpretProgramBinding "answer" invalidUpdateProgram
        assertEqual "result" (Left (InterpretInvalidUpdateValue (RuntimeLit (GrinLitInt IntRep 2)))) result,
      testCase "direct interpreter rejects CPS-only expressions" $
        forM_ cpsOnlyExpressions $ \expression -> do
          result <- interpretProgramFunctionSnapshot cpsOnlyFunction (cpsOnlyProgram expression)
          assertEqual (show expression) (Left (InterpretCpsExpression expression)) result,
      testCase "direct interpreter reports a terminal process exit" $ do
        result <- interpretProgramFunctionSnapshot (FunctionName "process_exit") processExitProgram
        assertEqual "process status" (Left (InterpretProcessExit 7)) result,
      testCase "lint rejects unlifted thunk results and heap updates" $
        forM_ unliftedRuntimeReps $ \runtimeRep ->
          let errors = lintProgram (unliftedHeapProgram runtimeRep)
           in do
                assertBool
                  ("accepted thunk returning " <> show runtimeRep)
                  (GrinLintThunkResult unliftedThunkFunction runtimeRep `elem` errors)
                assertBool
                  ("accepted heap update with " <> show runtimeRep)
                  (GrinLintUpdateNonLifted runtimeRep `elem` errors),
      testCase "lint rejects constructor field representation mismatches" $ do
        let program = heapProgram {grinConstructors = [("Box", [[WordRep]])]}
        assertBool
          "constructor layout mismatch"
          (GrinLintConstructorLayout "Box" [WordRep] [IntRep] `elem` lintProgram program),
      testCase "FC lowering makes exception control explicit" $ do
        let program = lowerProgram exceptionProgram
            rendered = renderProgram program
        assertEqual "lint" [] (lintProgram program)
        assertBool "contains explicit throw" ("throw " `isInfixOf` rendered)
        assertBool "contains explicit catch" ("catch " `isInfixOf` rendered)
        assertEqual "exception primitives are represented by GRIN control nodes" [] (grinPrimitives program),
      testCase "FC lowering makes process exit terminal" $ do
        let program = lowerProgram exitPrimitiveProgram
            exits = [body | function <- grinFunctions program, let body = grinFunctionBody function, GrinExit {} <- [body]]
        assertEqual "lint" [] (lintProgram program)
        assertEqual "direct and partial exits" 2 (length exits)
        assertEqual "raw exit status" [IntRep, IntRep] [grinValueRuntimeRep status | GrinExit status <- exits]
        assertBool "literal exit status" (GrinExit (GrinLitValue (GrinLitInt IntRep 7)) `elem` exits)
        assertEqual "compiler-only primitive is removed" [] (grinPrimitives program),
      testCase "FC lowering preserves catch# through partial application" $ do
        let program = lowerProgram partialCatchProgram
            rendered = renderProgram program
        assertEqual "lint" [] (lintProgram program)
        assertBool "primitive wrapper contains explicit catch" ("catch " `isInfixOf` rendered)
        assertEqual "catch# is represented by GRIN control nodes" [] (grinPrimitives program),
      testCase "GRIN ANF normalization reassociates nested binds" $ do
        let normalized = normalizeGrinProgram nestedDirectBindProgram
        assertBool "source contains a nested bind" (programHasNestedBind nestedDirectBindProgram)
        assertBool "normalized program has a flat bind spine" (not (programHasNestedBind normalized))
        assertEqual "normalization is idempotent" normalized (normalizeGrinProgram normalized),
      testCase "GRIN ANF normalization preserves nested-bind semantics" $ do
        original <- interpretProgramFunctionSnapshot nestedDirectBindEntry nestedDirectBindProgram
        normalized <- interpretProgramFunctionSnapshot nestedDirectBindEntry (normalizeGrinProgram nestedDirectBindProgram)
        assertEqual "normalized result" original normalized,
      testCase "CPS-GRIN does not reify continuations for nested direct binds" $ do
        cps <- expectCpsGrin nestedDirectBindProgram
        assertEqual
          "normal continuations"
          Set.empty
          (cpsContinuationFunctions cps `Set.difference` Set.singleton (cpsUpdateFunction cps)),
      testCase "CPS-GRIN retains transfers found inside nested binds" $ do
        cps <- expectCpsGrin nestedCallBindProgram
        assertEqual
          "one call continuation"
          1
          (Set.size (cpsContinuationFunctions cps `Set.difference` Set.singleton (cpsUpdateFunction cps))),
      testCase "CPS-GRIN allocates and applies ordinary continuation closures" $ do
        cps <- expectCpsGrin callBindProgram
        let program = cpsGrinProgram cps
            rendered = renderProgram program
            callerContinuation = cpsFunctionContinuations cps Map.! FunctionName "caller"
            callerNodes =
              [ node
              | function <- grinFunctions program,
                grinFunctionName function == FunctionName "caller",
                node@(GrinNode (GrinClosure name _) _) <- expressionStoredNodes (grinFunctionBody function),
                name `Set.member` cpsContinuationFunctions cps
              ]
        assertEqual "transformed lint" [] (lintProgram program)
        assertBool "allocates a continuation closure" ("store (P$cps$" `isInfixOf` rendered)
        assertBool "invokes a continuation closure" ("continue ($cps_return" `isInfixOf` rendered)
        assertBool "passes an explicit continuation to the call" (any callEndsInContinuation (grinFunctions program))
        assertBool "generated continuation captures its environment" (any continuationHasCaptures (grinFunctions program))
        assertEqual "one caller continuation" 1 (length callerNodes)
        case callerNodes of
          [GrinNode _ fields] -> assertEqual "parent continuation occupies field zero" (Just (GrinVarValue callerContinuation)) (firstMaybe fields)
          _ -> pure ()
        assertEqual
          "ordinary continuation frame kinds"
          (Just ContinuationFrameNormal)
          ( do
              GrinNode (GrinClosure name _) _ <- firstMaybe callerNodes
              Map.lookup name (cpsContinuationFrames cps)
          ),
      testCase "CPS-GRIN treats a multi-value result as one logical argument" $ do
        cps <- expectCpsGrin multiValueContinuationProgram
        case grinFunctions (cpsGrinProgram cps) of
          function : _ ->
            case grinFunctionBody function of
              GrinBind _ (GrinStore (GrinNode (GrinClosure _ layouts) _)) _ ->
                assertEqual "one multi-value argument layout" [[IntRep, WordRep]] layouts
              body -> assertFailure ("expected a stored continuation closure, got " <> show body)
          [] -> assertFailure "expected transformed functions",
      testCase "CPS-GRIN reifies only transferring binds" $ do
        forM_ transferringExpressions $ \valueExpression -> do
          let source = singleBindProgram valueExpression
          cps <- expectCpsGrin source
          assertEqual (show valueExpression) 1 (Set.size (cpsContinuationFunctions cps `Set.difference` Set.singleton (cpsUpdateFunction cps)))
        primitiveCps <- expectCpsGrin (singleBindProgram (GrinPrimitiveCall (BoxedRep Lifted) "primitive" []))
        assertEqual
          "primitive calls stay direct"
          Set.empty
          (cpsContinuationFunctions primitiveCps `Set.difference` Set.singleton (cpsUpdateFunction primitiveCps)),
      testCase "CPS-GRIN reifies scheduler and generic IO continuations" $ do
        forM_ ["awaitIO#", "fork#", "yield#", "newMVar#", "readMVar#", "takeMVar#", "putMVar#"] $ \name -> do
          cps <- expectCpsGrin (controlPrimitiveBindProgram name)
          let program = cpsGrinProgram cps
          assertEqual "transformed lint" [] (lintProgram program)
          assertBool ("missing CPS primitive " <> T.unpack name) (any (containsCpsPrimitive name . grinFunctionBody) (grinFunctions program))
          assertEqual
            "one reified continuation"
            1
            (Set.size (cpsContinuationFunctions cps `Set.difference` Set.singleton (cpsUpdateFunction cps))),
      testCase "CPS-GRIN preserves an unboxed terminal process status" $ do
        cps <- expectCpsGrin processExitProgram
        let bodies =
              [ grinFunctionBody function
              | function <- grinFunctions (cpsGrinProgram cps),
                grinFunctionName function == FunctionName "process_exit"
              ]
        assertEqual
          "raw exit status"
          [GrinExit (GrinLitValue (GrinLitInt IntRep 7))]
          bodies
        assertEqual
          "does not reify a return continuation"
          Set.empty
          (cpsContinuationFunctions cps `Set.difference` Set.singleton (cpsUpdateFunction cps)),
      testCase "CPS-GRIN keeps non-call binds in direct style" $ do
        cps <- expectCpsGrin directBindProgram
        let rendered = renderProgram (cpsGrinProgram cps)
        assertBool "constant bind remains direct" ("constant" `isInfixOf` rendered)
        assertBool "store bind remains direct" ("store (CBox" `isInfixOf` rendered)
        assertEqual
          "case does not allocate a continuation"
          Set.empty
          (cpsContinuationFunctions cps `Set.difference` Set.singleton (cpsUpdateFunction cps)),
      testCase "GC lowering returns relocated live pointer roots in SSA" $ do
        cps <- expectCpsGrin gcRootProgram
        let gc = lowerGc cps
            gcProgram = gcGrinProgram gc
            reservations = concatMap (ensureHeapReservations . grinFunctionBody) (grinFunctions gcProgram)
            roots = map snd reservations
            rendered = renderProgram gcProgram
        assertEqual "preserves continuation entries" (cpsContinuationFunctions cps) (gcContinuationFunctions gc)
        assertEqual "preserves continuation frame kinds" (cpsContinuationFrames cps) (gcContinuationFrames gc)
        assertEqual "preserves computation continuations" (cpsFunctionContinuations cps) (gcFunctionContinuations gc)
        assertEqual "preserves update entry" (cpsUpdateFunction cps) (gcUpdateFunction gc)
        assertEqual "GC-GRIN lint" [] (lintProgram gcProgram)
        assertBool "contains an explicit reservation" (not (null reservations))
        assertBool "uses a one-word header for a one-field node" (2 `elem` reservationLiteralWords reservations)
        assertBool "roots contain only pointer representations" (all (all (isPointerRuntimeRep . grinValueRuntimeRep)) roots)
        assertBool "renames relocated roots" ("$gc" `isInfixOf` rendered)
        assertBool "uses unchecked stores" ("store-unchecked " `isInfixOf` rendered)
        assertBool "eliminates checked function stores" (not ("\n  store " `isInfixOf` rendered)),
      testCase "GC lowering populates dynamic boxed-array reservation roots" $ do
        cps <- expectCpsGrin gcArrayProgram
        let gcProgram = gcGrinProgram (lowerGc cps)
            reservations = concatMap (ensureHeapReservations . grinFunctionBody) (grinFunctions gcProgram)
            rendered = renderProgram gcProgram
        assertEqual "GC-GRIN lint" [] (lintProgram gcProgram)
        assertBool "contains a dynamic array reservation" (any (isArrayWordCount . fst) reservations)
        forM_ (map snd reservations) $ \roots -> do
          let rootNames = [grinVarName root | GrinVarValue root <- roots]
          assertBool "the scalar size is not a root" ("size" `notElem` rootNames)
          assertBool "array roots are pointer-represented" (all (isPointerRuntimeRep . grinValueRuntimeRep) roots)
        assertBool "renames the relocated initial element" ("initial$gc" `isInfixOf` rendered)
        assertBool "retains newArray# as the initializer" ("primitive newArray#" `isInfixOf` rendered)
        assertBool "does not invent an unchecked array primitive" (not ("newArrayUnchecked#" `isInfixOf` rendered)),
      testCase "CPS-GRIN gives every computation entry a return continuation" $ do
        cps <- expectCpsGrin callBindProgram
        forM_ (Map.toList (cpsFunctionContinuations cps)) $ \(name, continuation) ->
          case [function | function <- grinFunctions (cpsGrinProgram cps), grinFunctionName function == name] of
            [function] ->
              assertEqual "hidden final parameter" (Just continuation) (lastMaybe (grinFunctionParameters function))
            _ -> assertFailure ("missing computation entry " <> show name),
      testCase "CPS-GRIN makes thunk update an explicit continuation" $ do
        cps <- expectCpsGrin heapProgram
        let program = cpsGrinProgram cps
            updateName = cpsUpdateFunction cps
        case [function | function <- grinFunctions program, grinFunctionName function == updateName] of
          [function] -> do
            assertEqual "update frame kind" (Just ContinuationFrameUpdate) (Map.lookup updateName (cpsContinuationFrames cps))
            assertEqual
              "parent and blackhole lead the update entry parameters"
              ["$cps_outer", "$cps_blackhole"]
              (map grinVarName (take 2 (grinFunctionParameters function)))
            assertBool "updates only a blackhole" (containsUpdateBlackhole (grinFunctionBody function))
            assertBool "re-forces the updated result" (containsCpsEval (grinFunctionBody function))
            let parentByOwner =
                  case grinFunctionParameters function of
                    parent : _ -> Map.insert updateName parent (cpsFunctionContinuations cps)
                    [] -> cpsFunctionContinuations cps
            forM_ (updateContinuationNodes updateName program) $ \(owner, node) -> do
              assertEqual "update frame has parent and blackhole fields" 2 (length (grinNodeFields node))
              assertEqual
                "update frame parent occupies field zero"
                (GrinVarValue <$> Map.lookup owner parentByOwner)
                (firstMaybe (grinNodeFields node))
          _ -> assertFailure "missing unique update continuation",
      testCase "CPS-GRIN lowers raise to an explicit continuation transfer" $ do
        cps <- expectCpsGrin (exceptionBoundaryProgram (GrinThrow exceptionValue))
        let continuation = cpsFunctionContinuations cps Map.! exceptionBoundaryFunction
        case [function | function <- grinFunctions (cpsGrinProgram cps), grinFunctionName function == exceptionBoundaryFunction] of
          [function] -> assertEqual "CPS raise" (GrinCpsRaise exceptionValue (GrinVarValue continuation)) (grinFunctionBody function)
          _ -> assertFailure "missing exception boundary function",
      testCase "CPS-GRIN lowers catch to a parent-linked catch frame" $ do
        cps <- expectCpsGrin (exceptionBoundaryProgram (GrinCatch IntRep exceptionAction exceptionHandler []))
        let program = cpsGrinProgram cps
            continuation = cpsFunctionContinuations cps Map.! exceptionBoundaryFunction
            catchNodes =
              [ (name, fields)
              | function <- grinFunctions program,
                grinFunctionName function == exceptionBoundaryFunction,
                GrinNode (GrinClosure name _) fields <- expressionStoredNodes (grinFunctionBody function),
                Map.lookup name (cpsContinuationFrames cps) == Just ContinuationFrameCatch
              ]
        case catchNodes of
          [(catchName, fields)] -> do
            assertEqual "catch frame fields" [GrinVarValue continuation, exceptionHandler] fields
            case [function | function <- grinFunctions program, grinFunctionName function == exceptionBoundaryFunction] of
              [function] -> assertBool "evaluates the action beneath the catch frame" (containsCpsEval (grinFunctionBody function))
              _ -> assertFailure "missing exception boundary function"
            case [function | function <- grinFunctions program, grinFunctionName function == catchName] of
              [function] -> assertBool "normal completion forwards to the parent" (containsContinueTo continuation (grinFunctionBody function))
              _ -> assertFailure "missing catch continuation entry"
          _ -> assertFailure ("expected one catch frame, got " <> show catchNodes),
      testCase "FC lowering evaluates Int# arguments without allocating thunks" $ do
        let program = lowerProgram unboxedApplicationProgram
            rendered = renderProgram program
            storedNodes = concatMap (expressionStoredNodes . grinFunctionBody) (grinFunctions program)
        assertEqual "lint" [] (lintProgram program)
        assertBool "records IntRep" ("IntRep" `isInfixOf` rendered)
        assertBool "does not allocate an argument thunk" (not (any isThunkNode storedNodes)),
      testCase "FC lowering calls saturated primitives without global slots" $ do
        let program = lowerProgram primitiveCallProgram
            rendered = renderProgram program
        assertEqual "lint" [] (lintProgram program)
        assertBool "contains a direct primitive call" ("primitive-call @IntRep +#" `isInfixOf` rendered)
        assertBool "primitive is not global" (not ("global +#" `isInfixOf` rendered)),
      testCase "FC lowering makes the dynamic newArray# reservation explicit" $ do
        let program = lowerProgram arrayPrimitiveProgram
            rendered = renderProgram program
        assertEqual "lint" [] (lintProgram program)
        assertBool "computes header plus element words" ("array_words" `isInfixOf` rendered && "primitive-call @IntRep +#" `isInfixOf` rendered)
        assertBool "reserves the computed word count" ("ensure-heap ($grin_array_words" `isInfixOf` rendered)
        assertBool "leaves newArray# as the initializer" ("primitive-call @(BoxedRep Unlifted) newArray#" `isInfixOf` rendered),
      testCase "FC lowering reserves a managed cell for newMutVar#" $ do
        let program = lowerProgram mutVarPrimitiveProgram
            reservations = concatMap (ensureHeapReservations . grinFunctionBody) (grinFunctions program)
            rendered = renderProgram program
        assertEqual "lint" [] (lintProgram program)
        assertBool "reserves the cell header, length, and value" (3 `elem` reservationLiteralWords reservations)
        assertBool "leaves newMutVar# as the initializer" ("primitive-call @(BoxedRep Unlifted) newMutVar#" `isInfixOf` rendered),
      testCase "FC lowering wraps partially applied primitives in ordinary closures" $ do
        let program = lowerProgram partialPrimitiveProgram
            rendered = renderProgram program
        assertEqual "lint" [] (lintProgram program)
        assertBool "allocates a provenance-named ordinary closure" ("PmakeAdder_primitive_" `isInfixOf` rendered)
        assertBool "wrapper makes a saturated primitive call" ("primitive-call @IntRep +#" `isInfixOf` rendered),
      testCase "FC lowering erases saturated and partially applied unsafeCoerce#" $ do
        let program = lowerProgram unsafeCoerceProgram
            rendered = renderProgram program
        assertEqual "lint" [] (lintProgram program)
        assertEqual "primitive declaration is erased" [] (grinPrimitives program)
        assertBool ("unsafeCoerce# reached GRIN:\n" <> rendered) (not ("unsafeCoerce#" `isInfixOf` rendered)),
      testCase "FC lowering counts zero-width arguments in closure arity" $ do
        let program = lowerProgram zeroWidthSaturatedApplicationProgram
            rendered = renderProgram program
        assertEqual "lint" [] (lintProgram program)
        assertBool "one logical argument remains" ("P$entry$zeroWidthTarget/[[]]" `isInfixOf` rendered)
        assertBool "closure is not saturated" (not ("P$entry$zeroWidthTarget/0" `isInfixOf` rendered)),
      testCase "FC lowering preserves a zero-width application" $ do
        let program = lowerProgram zeroWidthUnknownApplicationProgram
        assertEqual "lint" [] (lintProgram program)
        case grinFunctions program of
          [function] ->
            case grinFunctionBody function of
              GrinBind [evaluated] (GrinEval _ _) (GrinApply _ (GrinVarValue applied) argumentValues) -> do
                assertEqual "applies the explicitly evaluated function" evaluated applied
                assertEqual "zero runtime values" [] argumentValues
              body -> assertFailure ("expected an explicit evaluation followed by application, got " <> show body)
          functions -> assertFailure ("expected one function, got " <> show (length functions)),
      testCase "interpreter consumes one logical zero-width argument" $ do
        assertEqual "lint" [] (lintProgram zeroWidthApplyProgram)
        result <- interpretProgramBinding "answer" zeroWidthApplyProgram
        assertEqual "result" (Right "Box 1") result,
      testCase "FC lowering counts zero-width constructor fields" $ do
        let program = lowerProgram zeroWidthConstructorProgram
        assertEqual "lint" [] (lintProgram program)
        assertEqual "field layouts" [("test:Test.StateBox", [[], [BoxedRep Lifted]])] (grinConstructors program)
        case grinFunctions program of
          [function] ->
            assertEqual
              "one logical field remains"
              (GrinStore (GrinNode (GrinConstructor "test:Test.StateBox" 1) []))
              (grinFunctionBody function)
          functions -> assertFailure ("expected one function, got " <> show (length functions)),
      testCase "lint rejects saturated closure nodes" $ do
        let target = FunctionName "target"
            wrapper = FunctionName "wrapper"
            program =
              heapProgram
                { grinCafs = [],
                  grinFunctions =
                    [ GrinFunction
                        { grinFunctionName = target,
                          grinFunctionLinkName = Nothing,
                          grinFunctionParameters = [],
                          grinFunctionResultRep = BoxedRep Lifted,
                          grinFunctionBody = GrinStore (GrinNode (GrinConstructor "Box" 0) [GrinLitValue (GrinLitInt IntRep 1)])
                        },
                      GrinFunction
                        { grinFunctionName = wrapper,
                          grinFunctionLinkName = Nothing,
                          grinFunctionParameters = [],
                          grinFunctionResultRep = BoxedRep Lifted,
                          grinFunctionBody = GrinStore (GrinNode (GrinClosure target []) [])
                        }
                    ]
                }
        assertBool "saturated closure" (GrinLintSaturatedClosure target `elem` lintProgram program),
      testCase "FC lowering stores saturated constructor nodes" $ do
        let program = lowerProgram saturatedConstructorProgram
        assertEqual "lint" [] (lintProgram program)
        case grinFunctions program of
          [function] ->
            assertEqual
              "constructor body"
              (GrinStore (GrinNode (GrinConstructor "test:Test.I32#" 0) [GrinVarValue (GrinVar "value" 62 Int32Rep)]))
              (grinFunctionBody function)
          functions -> assertFailure ("expected one constructor function, got " <> show (length functions)),
      testCase "FC lowering returns a tail constructor store directly" $ do
        let program = lowerProgram tailStoredTupleProgram
        assertEqual "lint" [] (lintProgram program)
        case grinFunctions program of
          [function] ->
            assertEqual
              "function body"
              (GrinStore (GrinNode (GrinConstructor "test:Test.Box" 0) [GrinVarValue (GrinVar "value" 81 IntRep)]))
              (grinFunctionBody function)
          functions -> assertFailure ("expected one constructor function, got " <> show (length functions)),
      testCase "FC lowering emits saturated strict foreign calls" $ do
        let program = lowerProgram foreignProgram
            rendered = renderProgram program
        assertEqual "lint" [] (lintProgram program)
        assertBool "contains a direct foreign call" ("foreign-call $ffi$abs" `isInfixOf` rendered)
        assertBool "does not apply a foreign function value" (not ("apply @Int32Rep $ffi$abs" `isInfixOf` rendered)),
      testCase "lint rejects undersaturated foreign calls" $ do
        let program = lowerProgram undersaturatedForeignProgram
        assertBool
          "foreign arity mismatch"
          (GrinLintForeignArity "$ffi$abs" 1 0 `elem` lintProgram program),
      testCase "FC lowering distinguishes shadowing locals from globals" $ do
        let program = lowerProgram shadowingProgram
            rendered = renderProgram program
        assertEqual "lint" [] (lintProgram program)
        assertBool "raw local is emitted as a constant" ("constant (answer%2 :: IntRep)" `isInfixOf` rendered)
        assertBool "raw local is not treated as a global cell" (not ("eval @IntRep (answer%2" `isInfixOf` rendered)),
      testCase "FC lowering still evaluates CAF references" $ do
        let program = lowerProgram cafReferenceProgram
            rendered = renderProgram program
        assertEqual "lint" [] (lintProgram program)
        assertBool "CAF reference is evaluated" ("eval @(BoxedRep Lifted) (source%" `isInfixOf` rendered),
      testCase "FC lowering initializes static constructor values without CAF cells" $ do
        let program = lowerProgram staticConstructorProgram
        assertEqual "lint" [] (lintProgram program)
        assertEqual "static globals" ["source"] (map (grinVarName . fst) (grinWhnfGlobals program))
        assertEqual "no CAFs" [] (grinCafs program),
      testCase "FC lowering only makes computed function values CAFs" $ do
        let program = lowerProgram functionClassificationProgram
        assertEqual "lint" [] (lintProgram program)
        assertEqual "direct functions are not globals" [] (map (grinVarName . fst) (grinWhnfGlobals program))
        assertEqual "computed function CAFs" ["computed"] (map (grinVarName . fst) (grinCafs program)),
      testCase "FC lowering flattens top-level lambdas into one exported entry" $ do
        let program = lowerProgram functionClassificationProgram
            exported = [function | function <- grinFunctions program, grinFunctionLinkName function == Just "direct"]
        case exported of
          [function] -> assertEqual "runtime parameters" 2 (length (grinFunctionParameters function))
          _ -> assertFailure ("expected one exported direct entry, got " <> show (length exported)),
      testCase "FC lowering names CAF thunks after their source binding" $ do
        let program = lowerProgram etaExpandedKnownFunctionProgram
        case grinCafs program of
          [(caf, GrinNode (GrinThunk thunkName) [])] -> do
            assertEqual "CAF name" "$fApplicativeIO" (grinVarName caf)
            assertEqual "source-derived thunk name" (FunctionName "$fApplicativeIO_thunk") thunkName
          cafs -> assertFailure ("expected one capture-free CAF thunk, got " <> show cafs),
      testCase "FC lowering eliminates known-function eta wrappers" $ do
        let program = lowerProgram etaExpandedKnownFunctionProgram
            rendered = renderProgram program
        assertEqual "lint" [] (lintProgram program)
        assertBool
          "stores the original function with all arguments remaining"
          ("store (P$entry$pureIO/2)" `isInfixOf` rendered)
        assertEqual
          "emits no eta-wrapper entry"
          [FunctionName "$entry$pureIO", FunctionName "$fApplicativeIO_thunk"]
          (map grinFunctionName (grinFunctions program)),
      testCase "FC lowering retains known-function lambdas that are not eta expansions" $ do
        let program = lowerProgram nonEtaExpandedKnownFunctionProgram
            generatedNames = map (unFunctionName . grinFunctionName) (grinFunctions program)
        assertEqual "lint" [] (lintProgram program)
        assertBool "retains the argument-changing wrapper" (any ("$fApplicativeIO_closure_" `T.isPrefixOf`) generatedNames),
      testCase "FC lowering names local helpers after their Core provenance" $ do
        let program = lowerProgram provenanceNamingProgram
            generatedNames = map (unFunctionName . grinFunctionName) (grinFunctions program)
        assertEqual "lint" [] (lintProgram program)
        assertBool "names the returned closure after its owner" (any ("owner_closure_" `T.isPrefixOf`) generatedNames)
        assertBool "names the local thunk after its binder" (any ("delayed_thunk_" `T.isPrefixOf`) generatedNames)
        assertBool "names helpers inside the thunk after its binder" (any ("delayed_closure_" `T.isPrefixOf`) generatedNames)
        assertBool "emits no anonymous closure names" (not (any (T.isPrefixOf "$grin_closure_") generatedNames))
        assertBool "emits no anonymous thunk names" (not (any (T.isPrefixOf "$grin_thunk_") generatedNames)),
      testCase "FC lowering flattens lambdas hidden by cast aliases" $ do
        let program = lowerProgram castAliasClosureProgram
            closureFunctions = [function | function <- grinFunctions program, "dictionary_closure_" `T.isPrefixOf` unFunctionName (grinFunctionName function)]
            storedClosures =
              [ layouts
              | function <- grinFunctions program,
                GrinNode (GrinClosure _ layouts) _ <- expressionStoredNodes (grinFunctionBody function)
              ]
        assertEqual "lint" [] (lintProgram program)
        assertEqual "one flattened closure entry" 1 (length closureFunctions)
        assertEqual "two logical arguments" [2] (map length storedClosures),
      testCase "FC lowering preserves computed-let closure boundaries" $ do
        let program = lowerProgram computedLetClosureProgram
            closureFunctions = [function | function <- grinFunctions program, "dictionary_closure_" `T.isPrefixOf` unFunctionName (grinFunctionName function)]
        assertEqual "lint" [] (lintProgram program)
        assertEqual "two closure entries around computed work" 2 (length closureFunctions),
      testCase "FC lowering avoids outlining an immediately forced and discarded let" $ do
        let program = lowerProgram immediatelyForcedLetProgram
            ownerFunctions = [function | function <- grinFunctions program, grinFunctionLinkName function == Just "forceOnce"]
            thunkNames = [grinFunctionName function | function <- grinFunctions program, "delayed_thunk_" `T.isPrefixOf` unFunctionName (grinFunctionName function)]
        assertEqual "lint" [] (lintProgram program)
        case (ownerFunctions, thunkNames) of
          ([_], []) -> pure ()
          _ -> assertFailure ("expected one owner and no local thunk entry, got " <> show (length ownerFunctions, length thunkNames)),
      testCase "FC lowering retains an immediately forced thunk cell when it remains shared" $ do
        let program = lowerProgram sharedForcedLetProgram
            ownerFunctions = [function | function <- grinFunctions program, grinFunctionLinkName function == Just "forceShared"]
            thunkNames = [grinFunctionName function | function <- grinFunctions program, "delayed_thunk_" `T.isPrefixOf` unFunctionName (grinFunctionName function)]
        assertEqual "lint" [] (lintProgram program)
        case (ownerFunctions, thunkNames) of
          ([owner], [thunkName]) -> do
            assertBool "retains the shared thunk cell" (any (isNamedThunkNode thunkName) (expressionStoredNodes (grinFunctionBody owner)))
            assertBool "does not bypass the shared cell" (thunkName `notElem` expressionCalledFunctions (grinFunctionBody owner))
          _ -> assertFailure ("expected one owner and one local thunk entry, got " <> show (length ownerFunctions, length thunkNames)),
      testCase "recursive function bindings store closures without thunk wrappers" $ do
        let program = lowerProgram recursiveFunctionProgram
            recursiveNodes =
              [ node
              | function <- grinFunctions program,
                GrinStoreRec bindings _ <- [grinFunctionBody function],
                (_, node) <- bindings
              ]
        assertEqual "lint" [] (lintProgram program)
        case recursiveNodes of
          [GrinNode GrinClosure {} _] -> pure ()
          nodes -> assertFailure ("expected one recursive closure node, got " <> show nodes)
        result <- interpretProgramBinding "answer" program
        assertEqual "result" (Right "<function>") result,
      testCase "FC dictionaries lower to ordinary constructor nodes and cases" $ do
        let program = lowerProgram dictionaryProgram
            rendered = renderProgram program
        assertEqual "lint" [] (lintProgram program)
        assertEqual
          "dictionary constructor has an ordinary declared layout"
          [("test:Test.Box", [[IntRep]]), ("test:Test.$Dict$Test", [[BoxedRep Lifted], [BoxedRep Lifted]])]
          (grinConstructors program)
        assertBool ("explicit dictionary constructor store:\n" <> rendered) ("store (Ctest:Test.$Dict$Test" `isInfixOf` rendered)
        assertBool "ordinary dictionary case" ("$Dict$Test" `isInfixOf` rendered && "case " `isInfixOf` rendered)
        assertBool "no tuple encoding" (not ("C(,)" `isInfixOf` rendered || "C()" `isInfixOf` rendered))
        assertBool "no projection operation" (not ("project " `isInfixOf` rendered))
        result <- interpretProgramBinding "answer" program
        assertEqual "selected field is evaluated" (Right "Box 2") result,
      testCase "FC lowering keeps local nullary constructors out of external globals" $ do
        let localTy = TcTyCon (TyCon "Local" 0) []
            localConstructor = Var "Local" (Unique 60) localTy
            boxConstructor = Var "Box" (Unique 61) (TcFunTy localTy boxedIntTy)
            answer = Var "answer" (Unique 62) boxedIntTy
            core =
              FcProgram
                (FcModuleId "test" "Test")
                [ fcData "Local" [] [("Local", [])],
                  fcData "Box" [] [("Box", [localTy])],
                  FcTopBind (FcNonRec answer (FcApp (FcVar boxConstructor) (FcVar localConstructor)))
                ]
            program = lowerProgramWithLinkNames (linkNamesForProgram ["test"] ["Test"] core) core
        assertEqual "lint" [] (lintProgram program)
        assertEqual "external globals" [] (grinExternalGlobals program),
      testCase "separate FC units do not capture dependency globals" $ do
        case separatePrograms of
          [providerCore, consumerCore] -> do
            let consumer = lowerProgramWithInterface (extractGrinInterface providerCore) consumerCore
                parameters = concatMap grinFunctionParameters (grinFunctions consumer)
            assertBool "dependency CAF remains global" (all ((/= "source") . grinVarName) parameters)
          programs -> assertFailure ("expected two FC programs, got " <> show (length programs)),
      testCase "separate FC units call dependency code entries directly" $ do
        case separateFunctionPrograms of
          [providerCore, consumerCore] -> do
            let consumer = lowerProgramWithInterface (extractGrinInterface providerCore) consumerCore
                rendered = renderProgram consumer
            assertEqual "lint" [] (lintProgram consumer)
            assertEqual "external code" ["identity"] (map grinCodeSourceName (grinExternalFunctions consumer))
            assertBool "direct dependency call" ("call @(BoxedRep Lifted) $entry$identity" `isInfixOf` rendered)
            assertBool "dependency function has no global slot" (not ("global identity" `isInfixOf` rendered))
          programs -> assertFailure ("expected two FC programs, got " <> show (length programs)),
      testCase "separate FC units identify link-visible definitions" $ do
        case (separateLinkableFunctionPrograms "Data.Provider" 80, separateLinkableFunctionPrograms "Data.Other" 90) of
          ([providerCore, consumerCore], [otherProviderCore, otherConsumerCore]) -> do
            let providerNames = linkNamesForProgram ["aihc", "base", "4", "21", "2", "0", "dephash"] ["Data", "Provider"] providerCore
                otherProviderNames = linkNamesForProgram ["aihc", "base", "4", "21", "2", "0", "dephash"] ["Data", "Other"] otherProviderCore
                consumerNames = linkNamesForProgram ["exe"] ["Main"] consumerCore
                providerInterface = extractGrinInterfaceWithLinkNames providerNames providerCore
                otherProviderInterface = extractGrinInterfaceWithLinkNames otherProviderNames otherProviderCore
                combinedInterface = providerInterface <> otherProviderInterface
                provider = lowerProgramWithLinkNames providerNames providerCore
                otherProvider = lowerProgramWithLinkNames otherProviderNames otherProviderCore
                consumer = lowerProgramWithInterfaceAndLinkNames consumerNames combinedInterface consumerCore
                otherConsumer = lowerProgramWithInterfaceAndLinkNames consumerNames combinedInterface otherConsumerCore
                linkedNames program = [name | function <- grinFunctions program, Just name <- [grinFunctionLinkName function]]
            assertEqual "provider link name" [T.intercalate "\0" ["aihc", "base", "4", "21", "2", "0", "dephash", "Data", "Provider", "identity"]] (linkedNames provider)
            assertEqual "other provider link name" [T.intercalate "\0" ["aihc", "base", "4", "21", "2", "0", "dephash", "Data", "Other", "identity"]] (linkedNames otherProvider)
            assertEqual "external link name" [T.intercalate "\0" ["aihc", "base", "4", "21", "2", "0", "dephash", "Data", "Provider", "identity"]] (map grinCodeSourceName (grinExternalFunctions consumer))
            assertEqual "other external link name" [T.intercalate "\0" ["aihc", "base", "4", "21", "2", "0", "dephash", "Data", "Other", "identity"]] (map grinCodeSourceName (grinExternalFunctions otherConsumer))
          programs -> assertFailure ("expected two pairs of FC programs, got " <> show programs),
      testCase "duplicate generated names receive readable unique suffixes" $ do
        let firstVar = Var "xor" (Unique 100) (TcFunTy boxedIntTy boxedIntTy)
            firstArgument = Var "value" (Unique 101) boxedIntTy
            secondVar = Var "xor" (Unique 102) (TcFunTy boxedIntTy boxedIntTy)
            secondArgument = Var "value" (Unique 103) boxedIntTy
            core =
              FcProgram
                (FcModuleId "test" "Test")
                [ FcTopBind (FcNonRec firstVar (FcLam firstArgument (FcVar firstArgument))),
                  FcTopBind (FcNonRec secondVar (FcLam secondArgument (FcVar secondArgument)))
                ]
            program = lowerProgramWithLinkNames (linkNamesForProgram ["package"] ["Module"] core) core
            linkedNames = [name | function <- grinFunctions program, Just name <- [grinFunctionLinkName function]]
        assertEqual
          "link names"
          [T.intercalate "\0" ["package", "Module", "xor", "u100n1"], T.intercalate "\0" ["package", "Module", "xor", "u102n2"]]
          linkedNames,
      testCase "separate FC units namespace global slots" $ do
        case (separateLinkableGlobalPrograms "Data.Provider" 110, separateLinkableGlobalPrograms "Data.Other" 120) of
          ([providerCore, consumerCore], [otherProviderCore, otherConsumerCore]) -> do
            let libraryId = ["aihc", "base", "4", "21", "2", "0", "dephash"]
                providerNames = linkNamesForProgram libraryId ["Data", "Provider"] providerCore
                otherProviderNames = linkNamesForProgram libraryId ["Data", "Other"] otherProviderCore
                combinedInterface = extractGrinInterfaceWithLinkNames providerNames providerCore <> extractGrinInterfaceWithLinkNames otherProviderNames otherProviderCore
                consumer = lowerProgramWithInterfaceAndLinkNames (linkNamesForProgram ["exe"] ["Main"] consumerCore) combinedInterface consumerCore
                otherConsumer = lowerProgramWithInterfaceAndLinkNames (linkNamesForProgram ["exe"] ["OtherMain"] otherConsumerCore) combinedInterface otherConsumerCore
            assertEqual "provider external global" [T.intercalate "\0" (libraryId <> ["Data", "Provider", "value"])] (grinExternalGlobals consumer)
            assertEqual "other external global" [T.intercalate "\0" (libraryId <> ["Data", "Other", "value"])] (grinExternalGlobals otherConsumer)
          programs -> assertFailure ("expected two global pairs, got " <> show programs),
      testCase "incremental lowering resolves qualified constructor identities" $ do
        case separateBuiltinUnitPrograms of
          [providerCore, consumerCore] -> do
            let providerNames = linkNamesForProgram ["aihc-prim"] ["GHC", "Tuple"] providerCore
                consumerNames = linkNamesForProgram ["exe"] ["Main"] consumerCore
                providerInterface = extractGrinInterfaceWithLinkNames providerNames providerCore
                consumer = lowerProgramWithInterfaceAndLinkNames consumerNames providerInterface consumerCore
            assertEqual "lint" [] (lintProgram consumer)
            assertEqual "unit runtime global" ["aihc-prim:GHC.Tuple.()"] (grinExternalGlobals consumer)
          programs -> assertFailure ("expected two FC programs, got " <> show programs),
      testCase "separate FC units store saturated dependency constructors directly" $ do
        case separateConstructorPrograms of
          [providerCore, consumerCore] -> do
            let consumer = lowerProgramWithInterface (extractGrinInterface providerCore) consumerCore
            case grinFunctions consumer of
              [function] ->
                assertEqual
                  "constructor body"
                  (GrinStore (GrinNode (GrinConstructor "test:Test.I32#" 0) [GrinVarValue (GrinVar "value" 72 Int32Rep)]))
                  (grinFunctionBody function)
              functions -> assertFailure ("expected one constructor function, got " <> show (length functions))
          programs -> assertFailure ("expected two FC programs, got " <> show (length programs)),
      testCase "separate FC units erase dependency newtypes" $ do
        case separateNewtypePrograms of
          [providerCore, sourceConsumer] -> do
            let consumerCore = lowerNewtypesWithInterface (extractNewtypeInterface providerCore) sourceConsumer
                provider = lowerProgram providerCore
                consumer = lowerProgramWithInterface (extractGrinInterface providerCore) consumerCore
            assertEqual "newtype declaration emits no constructor" [] (grinConstructors provider)
            assertEqual "consumer lint" [] (lintProgram consumer)
            assertBool "newtype constructor is erased across units" (not ("Wrap" `isInfixOf` renderProgram consumer))
          programs -> assertFailure ("expected two FC programs, got " <> show (length programs))
    ]

expectCpsGrin :: GrinProgram -> IO CpsGrinProgram
expectCpsGrin program =
  case toCpsGrin program of
    Left err -> assertFailure ("expected CPS-GRIN conversion to succeed, got " <> show err)
    Right cps -> pure cps

ensureHeapReservations :: GrinExpr -> [(GrinValue, [GrinValue])]
ensureHeapReservations expression =
  case expression of
    GrinBind _ valueExpression body -> ensureHeapReservations valueExpression <> ensureHeapReservations body
    GrinEnsureHeap requiredWords roots -> [(requiredWords, roots)]
    GrinStoreRec _ body -> ensureHeapReservations body
    GrinStoreRecUnchecked _ body -> ensureHeapReservations body
    GrinCase _ _ alternatives -> concatMap (ensureHeapReservations . grinAltRhs) alternatives
    _ -> []

reservationLiteralWords :: [(GrinValue, [GrinValue])] -> [Integer]
reservationLiteralWords reservations =
  [ words'
  | (GrinLitValue (GrinLitInt _ words'), _) <- reservations
  ]

isArrayWordCount :: GrinValue -> Bool
isArrayWordCount (GrinVarValue var) = grinVarName var == "array_words"
isArrayWordCount _ = False

expressionStoredNodes :: GrinExpr -> [GrinNode]
expressionStoredNodes expression =
  case expression of
    GrinBind _ valueExpression body -> expressionStoredNodes valueExpression <> expressionStoredNodes body
    GrinStore node -> [node]
    GrinStoreUnchecked node -> [node]
    GrinStoreRec bindings body -> map snd bindings <> expressionStoredNodes body
    GrinStoreRecUnchecked bindings body -> map snd bindings <> expressionStoredNodes body
    GrinCase _ _ alternatives -> concatMap (expressionStoredNodes . grinAltRhs) alternatives
    _ -> []

programHasNestedBind :: GrinProgram -> Bool
programHasNestedBind = any (hasNestedBind . grinFunctionBody) . grinFunctions

hasNestedBind :: GrinExpr -> Bool
hasNestedBind expression =
  case expression of
    GrinBind _ (GrinBind {}) _ -> True
    GrinBind _ valueExpression body ->
      hasNestedBind valueExpression || hasNestedBind body
    GrinStoreRec _ body -> hasNestedBind body
    GrinStoreRecUnchecked _ body -> hasNestedBind body
    GrinCase _ _ alternatives -> any (hasNestedBind . grinAltRhs) alternatives
    _ -> False

updateContinuationNodes :: FunctionName -> GrinProgram -> [(FunctionName, GrinNode)]
updateContinuationNodes updateName program =
  [ (grinFunctionName function, node)
  | function <- grinFunctions program,
    node@(GrinNode (GrinClosure name _) _) <- expressionStoredNodes (grinFunctionBody function),
    name == updateName
  ]

expressionCalledFunctions :: GrinExpr -> [FunctionName]
expressionCalledFunctions expression =
  case expression of
    GrinBind _ valueExpression body -> expressionCalledFunctions valueExpression <> expressionCalledFunctions body
    GrinStoreRec _ body -> expressionCalledFunctions body
    GrinStoreRecUnchecked _ body -> expressionCalledFunctions body
    GrinCall _ functionName _ -> [functionName]
    GrinCase _ _ alternatives -> concatMap (expressionCalledFunctions . grinAltRhs) alternatives
    _ -> []

isThunkNode :: GrinNode -> Bool
isThunkNode node =
  case grinNodeTag node of
    GrinThunk {} -> True
    _ -> False

isNamedThunkNode :: FunctionName -> GrinNode -> Bool
isNamedThunkNode expected node =
  case grinNodeTag node of
    GrinThunk actual -> actual == expected
    _ -> False

continuationHasCaptures :: GrinFunction -> Bool
continuationHasCaptures function =
  "$cps$" `T.isInfixOf` unFunctionName (grinFunctionName function)
    && length (grinFunctionParameters function) > 1

containsContinueTo :: GrinVar -> GrinExpr -> Bool
containsContinueTo continuation expression =
  case expression of
    GrinBind _ value body -> containsContinueTo continuation value || containsContinueTo continuation body
    GrinStoreRec _ body -> containsContinueTo continuation body
    GrinStoreRecUnchecked _ body -> containsContinueTo continuation body
    GrinContinue (GrinVarValue actual) _ -> actual == continuation
    GrinCase _ _ alternatives -> any (containsContinueTo continuation . grinAltRhs) alternatives
    _ -> False

data ExplicitOperand
  = GrinCaseOperand
  | GrinApplyOperand
  deriving (Eq)

containsExplicitOperand :: ExplicitOperand -> GrinFunction -> Bool
containsExplicitOperand operand = go Set.empty . grinFunctionBody
  where
    go evaluated expression =
      case expression of
        GrinBind vars value body ->
          go evaluated value
            || go (recordEvaluation evaluated vars value) body
        GrinStoreRec _ body -> go evaluated body
        GrinApply _ (GrinVarValue function) _ ->
          operand == GrinApplyOperand && function `Set.member` evaluated
        GrinCase (GrinVarValue scrutinee) _ alternatives ->
          (operand == GrinCaseOperand && scrutinee `Set.member` evaluated)
            || any (go evaluated . grinAltRhs) alternatives
        GrinCase _ _ alternatives -> any (go evaluated . grinAltRhs) alternatives
        _ -> False
    recordEvaluation evaluated vars value =
      case (vars, value) of
        ([var], GrinEval {}) -> Set.insert var evaluated
        _ -> evaluated `Set.difference` Set.fromList vars

grinGoldenTests :: IO TestTree
grinGoldenTests =
  testGroup "GRIN golden tests" . map goldenTest <$> GrinGolden.loadGrinCases
  where
    goldenTest fixture = testCase (GrinGolden.caseId fixture) $ do
      let (outcome, details) = GrinGolden.evaluateGrinCase fixture
      case outcome of
        GrinGolden.OutcomePass -> pure ()
        GrinGolden.OutcomeXFail -> pure ()
        GrinGolden.OutcomeXPass -> assertFailure ("unexpected pass (xpass): " <> details)
        GrinGolden.OutcomeFail -> assertFailure details

grinEvalFixtureTests :: IO TestTree
grinEvalFixtureTests = do
  cases <- filter (("grin" `elem`) . EvalGolden.evalCaseEvaluators) <$> EvalGolden.loadEvalCases
  let tests = map mkEvalFixtureTest cases
  pure (testGroup "shared evaluation fixtures via GRIN" tests)

mkEvalFixtureTest :: EvalGolden.EvalCase -> TestTree
mkEvalFixtureTest evalCase = testCase (EvalGolden.evalCaseId evalCase) $ do
  (outcome, details) <- EvalGolden.evaluateEvalCase evaluateGrinProgram evalCase
  case outcome of
    EvalGolden.OutcomePass -> pure ()
    EvalGolden.OutcomeXFail -> pure ()
    EvalGolden.OutcomeXPass -> assertFailure ("unexpected pass (xpass): " <> details)
    EvalGolden.OutcomeFail -> assertFailure details

evaluateGrinProgram :: Text -> FcProgram -> IO (Either EvalGolden.EvaluationFailure Text)
evaluateGrinProgram name fcProgram = do
  case prepareEvalProgram name (lowerNewtypes fcProgram) of
    Left err -> pure (Left (EvalGolden.EvaluationError err))
    Right (preparedProgram, entry, unwrapResult) -> do
      let program = lowerProgram preparedProgram
          entryName =
            fromMaybe
              name
              ( listToMaybe
                  [ varName var
                  | FcTopBind bind <- fcTopBinds preparedProgram,
                    var <- topBinders bind,
                    maybe (varName var) fcOriginName (varResolvedName var) == name
                  ]
              )
      case lintProgram program of
        [] -> do
          result <-
            case entry of
              EvaluateBinding -> interpretProgramBinding entryName program
              RunIoAction -> interpretProgramIoBinding entryName program
          pure $
            case result of
              Left (InterpretRaisedException exception) -> Left (EvalGolden.EvaluationRaised exception)
              Left err -> Left (EvalGolden.EvaluationError (show err))
              Right value -> Right (unwrapResult value)
        lintErrors -> pure (Left (EvalGolden.EvaluationError ("GRIN lint error: " <> show lintErrors)))
  where
    topBinders bind =
      case bind of
        FcNonRec var _ -> [var]
        FcRec bindings -> map fst bindings

data BindingEntry
  = EvaluateBinding
  | RunIoAction

prepareEvalProgram :: Text -> FcProgram -> Either String (FcProgram, BindingEntry, Text -> Text)
prepareEvalProgram name program@(FcProgram _ topBinds) =
  case break isEvalBinding topBinds of
    (_, []) -> Left ("missing evaluation binding " <> T.unpack name)
    (_, FcTopBind (FcRec _) : _) -> Left "recursive evaluation binding is unsupported"
    (before, FcTopBind (FcNonRec var rhs) : after) -> do
      runtimeRep <- runtimeRepOfType (varType var)
      if runtimeRep == BoxedRep Lifted
        then Right (program, bindingEntry (varType var), id)
        else do
          let componentCount = length (runtimeRepComponents runtimeRep)
              constructorName = evalResultConstructor componentCount
              wrapperType = TcTyCon (TyCon "__AihcEvalResultType" 0) []
              constructorVar = Var constructorName (Unique (-1000000)) (TcFunTy (varType var) wrapperType)
              wrappedVar = var {varType = wrapperType}
              declaration = fcData "__AihcEvalResultType" [] [(constructorName, [varType var])]
              wrappedBinding = FcTopBind (FcNonRec wrappedVar (FcApp (FcVar constructorVar) rhs))
          Right
            ( FcProgram (fcProgramModule program) (declaration : before <> (wrappedBinding : after)),
              EvaluateBinding,
              unwrapEvalResult componentCount constructorName
            )
    (_, _ : _) -> Left "invalid evaluation binding"
  where
    isEvalBinding topBind =
      case topBind of
        FcTopBind (FcNonRec var _) -> sourceName var == name
        FcTopBind (FcRec bindings) -> any ((== name) . sourceName . fst) bindings
        _ -> False
    sourceName var = maybe (varName var) fcOriginName (varResolvedName var)

bindingEntry :: TcType -> BindingEntry
bindingEntry ty
  | isIOType ty = RunIoAction
  | otherwise = EvaluateBinding

isIOType :: TcType -> Bool
isIOType ty =
  case ty of
    TcTyCon (TyCon name arity) [_] -> name == "IO" && arity == 1
    TcForAllTy _ body -> isIOType body
    TcQualTy _ body -> isIOType body
    _ -> False

callEndsInContinuation :: GrinFunction -> Bool
callEndsInContinuation function =
  case grinFunctionBody function of
    GrinBind _ _ body -> callEndsInContinuation function {grinFunctionBody = body}
    GrinCall _ _ arguments ->
      case reverse arguments of
        GrinVarValue continuation : _ -> grinVarName continuation == "$cps_continuation"
        _ -> False
    _ -> False

containsUpdateBlackhole :: GrinExpr -> Bool
containsUpdateBlackhole expression =
  case expression of
    GrinUpdateBlackhole {} -> True
    GrinBind _ value body -> containsUpdateBlackhole value || containsUpdateBlackhole body
    GrinStoreRec _ body -> containsUpdateBlackhole body
    GrinCase _ _ alternatives -> any (containsUpdateBlackhole . grinAltRhs) alternatives
    _ -> False

containsCpsEval :: GrinExpr -> Bool
containsCpsEval expression =
  case expression of
    GrinCpsEval {} -> True
    GrinBind _ value body -> containsCpsEval value || containsCpsEval body
    GrinStoreRec _ body -> containsCpsEval body
    GrinCase _ _ alternatives -> any (containsCpsEval . grinAltRhs) alternatives
    _ -> False

firstMaybe :: [value] -> Maybe value
firstMaybe values =
  case values of
    value : _ -> Just value
    [] -> Nothing

lastMaybe :: [value] -> Maybe value
lastMaybe values =
  case reverse values of
    value : _ -> Just value
    [] -> Nothing

evalResultConstructor :: Int -> Text
evalResultConstructor componentCount
  | componentCount == 0 = "()"
  | componentCount == 1 = "__AihcEvalResult"
  | otherwise = "(" <> T.replicate (componentCount - 1) "," <> ")"

unwrapEvalResult :: Int -> Text -> Text -> Text
unwrapEvalResult componentCount constructorName rendered
  | componentCount == 0 = "<state>"
  | componentCount == 1 = fromMaybe rendered (T.stripPrefix (constructorName <> " ") rendered)
  | otherwise = rendered

applicationProgram :: FcProgram
applicationProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ fcData "BoxedInt" [] [("BoxedInt", [intTy])],
      FcTopBind
        ( FcNonRec
            answerVar
            ( FcApp
                (FcLam argumentVar (FcVar argumentVar))
                (FcApp (FcVar boxConstructorVar) (FcLit (LitInt IntRep 42) intTy))
            )
        )
    ]
  where
    answerVar = Var "answer" (Unique 1) boxedIntTy
    argumentVar = Var "argument" (Unique 2) boxedIntTy
    boxConstructorVar = Var "BoxedInt" (Unique 3) (TcFunTy intTy boxedIntTy)

provenanceNamingProgram :: FcProgram
provenanceNamingProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ FcTopBind
        ( FcNonRec
            ownerVar
            ( FcLam
                inputVar
                ( FcLet
                    ( FcNonRec
                        delayedVar
                        (FcApp (FcLam evaluatedVar (FcVar evaluatedVar)) (FcVar inputVar))
                    )
                    (FcLam returnedVar (FcVar returnedVar))
                )
            )
        )
    ]
  where
    functionTy = TcFunTy boxedIntTy boxedIntTy
    ownerVar = Var "owner" (Unique 160) (TcFunTy boxedIntTy functionTy)
    inputVar = Var "input" (Unique 161) boxedIntTy
    delayedVar = Var "delayed" (Unique 162) boxedIntTy
    evaluatedVar = Var "evaluated" (Unique 163) boxedIntTy
    returnedVar = Var "returned" (Unique 164) boxedIntTy

castAliasClosureProgram :: FcProgram
castAliasClosureProgram = hiddenLambdaProgram castAlias
  where
    firstVar = Var "first" (Unique 172) boxedIntTy
    castAlias = FcCast (FcVar firstVar) (AxiomInstCo "FunctionWrapper" [])

computedLetClosureProgram :: FcProgram
computedLetClosureProgram = hiddenLambdaProgram computed
  where
    unaryFunctionTy = TcFunTy boxedIntTy boxedIntTy
    evaluatedVar = Var "evaluated" (Unique 175) unaryFunctionTy
    parameterVar = Var "parameter" (Unique 176) boxedIntTy
    computed = FcApp (FcLam evaluatedVar (FcVar evaluatedVar)) (FcLam parameterVar (FcVar parameterVar))

hiddenLambdaProgram :: FcExpr -> FcProgram
hiddenLambdaProgram aliasRhs =
  FcProgram
    (FcModuleId "test" "Test")
    [ fcData "Holder" [] [("Holder", [binaryFunctionTy])],
      FcTopBind
        ( FcNonRec
            dictionaryVar
            (FcApp (FcVar holderVar) castHiddenLambda)
        )
    ]
  where
    binaryFunctionTy = TcFunTy boxedIntTy (TcFunTy boxedIntTy boxedIntTy)
    unaryFunctionTy = TcFunTy boxedIntTy boxedIntTy
    holderTy = TcTyCon (TyCon "Holder" 0) []
    dictionaryVar = Var "dictionary" (Unique 170) holderTy
    holderVar = Var "Holder" (Unique 171) (TcFunTy binaryFunctionTy holderTy)
    firstVar = Var "first" (Unique 172) boxedIntTy
    aliasVar = Var "alias" (Unique 173) unaryFunctionTy
    secondVar = Var "second" (Unique 174) boxedIntTy
    castHiddenLambda =
      FcLam firstVar $
        FcLet
          (FcNonRec aliasVar aliasRhs)
          (FcCast (FcLam secondVar (FcApp (FcVar aliasVar) (FcVar secondVar))) (Refl unaryFunctionTy))

immediatelyForcedLetProgram :: FcProgram
immediatelyForcedLetProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ FcTopBind
        ( FcNonRec
            ownerVar
            ( FcLam inputVar $
                FcLet
                  (FcNonRec delayedVar computedFunction)
                  (FcApp (FcVar delayedVar) (FcVar inputVar))
            )
        )
    ]
  where
    unaryFunctionTy = TcFunTy boxedIntTy boxedIntTy
    ownerVar = Var "forceOnce" (Unique 180) unaryFunctionTy
    inputVar = Var "input" (Unique 181) boxedIntTy
    delayedVar = Var "delayed" (Unique 182) unaryFunctionTy
    identityVar = Var "identity" (Unique 183) unaryFunctionTy
    argumentVar = Var "argument" (Unique 184) boxedIntTy
    computedFunction = FcApp (FcLam identityVar (FcVar identityVar)) (FcLam argumentVar (FcVar argumentVar))

sharedForcedLetProgram :: FcProgram
sharedForcedLetProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ fcData "FunctionPair" [] [("FunctionPair", [unaryFunctionTy, unaryFunctionTy])],
      FcTopBind
        ( FcNonRec
            ownerVar
            ( FcLam inputVar $
                FcLet
                  (FcNonRec delayedVar computedFunction)
                  ( FcCase
                      (FcVar delayedVar)
                      evaluatedVar
                      [FcAlt DefaultAlt [] (FcApp (FcApp (FcVar pairVar) (FcVar evaluatedVar)) (FcVar delayedVar))]
                  )
            )
        )
    ]
  where
    unaryFunctionTy = TcFunTy boxedIntTy boxedIntTy
    pairTy = TcTyCon (TyCon "FunctionPair" 0) []
    ownerVar = Var "forceShared" (Unique 185) (TcFunTy boxedIntTy pairTy)
    inputVar = Var "input" (Unique 186) boxedIntTy
    delayedVar = Var "delayed" (Unique 187) unaryFunctionTy
    identityVar = Var "identity" (Unique 188) unaryFunctionTy
    argumentVar = Var "argument" (Unique 189) boxedIntTy
    evaluatedVar = Var "evaluated" (Unique 190) unaryFunctionTy
    pairVar = Var "FunctionPair" (Unique 191) (TcFunTy unaryFunctionTy (TcFunTy unaryFunctionTy pairTy))
    computedFunction = FcApp (FcLam identityVar (FcVar identityVar)) (FcLam argumentVar (FcVar argumentVar))

unboxedApplicationProgram :: FcProgram
unboxedApplicationProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ fcData "BoxedInt" [] [("BoxedInt", [intTy])],
      FcTopBind
        ( FcNonRec
            answerVar
            ( FcApp
                (FcVar boxConstructorVar)
                (FcApp (FcLam argumentVar (FcVar argumentVar)) (FcLit (LitInt IntRep 42) intTy))
            )
        )
    ]
  where
    answerVar = Var "answer" (Unique 10) boxedIntTy
    argumentVar = Var "argument" (Unique 11) intTy
    boxConstructorVar = Var "BoxedInt" (Unique 12) (TcFunTy intTy boxedIntTy)

shadowingProgram :: FcProgram
shadowingProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ fcData "BoxedInt" [] [("BoxedInt", [intTy])],
      FcTopBind
        ( FcNonRec
            answerVar
            ( FcApp
                (FcVar boxConstructorVar)
                (FcApp (FcLam localAnswerVar (FcVar localAnswerVar)) (FcLit (LitInt IntRep 42) intTy))
            )
        )
    ]
  where
    answerVar = Var "answer" (Unique 1) boxedIntTy
    localAnswerVar = Var "answer" (Unique 2) intTy
    boxConstructorVar = Var "BoxedInt" (Unique 3) (TcFunTy intTy boxedIntTy)

cafReferenceProgram :: FcProgram
cafReferenceProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ fcData "BoxedInt" [] [("BoxedInt", [intTy])],
      FcTopBind
        ( FcNonRec
            sourceVar
            ( FcApp
                (FcLam computedVar (FcVar computedVar))
                (FcApp (FcVar boxConstructorVar) (FcLit (LitInt IntRep 1) intTy))
            )
        ),
      FcTopBind (FcNonRec answerVar (FcVar sourceVar))
    ]
  where
    sourceVar = Var "source" (Unique 20) boxedIntTy
    answerVar = Var "answer" (Unique 21) boxedIntTy
    boxConstructorVar = Var "BoxedInt" (Unique 22) (TcFunTy intTy boxedIntTy)
    computedVar = Var "computed" (Unique 23) boxedIntTy

staticConstructorProgram :: FcProgram
staticConstructorProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ fcData "BoxedInt" [] [("BoxedInt", [intTy])],
      FcTopBind
        ( FcNonRec
            sourceVar
            (FcApp (FcVar boxConstructorVar) (FcLit (LitInt IntRep 1) intTy))
        )
    ]
  where
    sourceVar = Var "source" (Unique 24) boxedIntTy
    boxConstructorVar = Var "BoxedInt" (Unique 25) (TcFunTy intTy boxedIntTy)

recursiveFunctionProgram :: FcProgram
recursiveFunctionProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ FcTopBind
        ( FcNonRec
            answerVar
            ( FcLet
                (FcRec [(functionVar, FcLam argumentVar (FcVar argumentVar))])
                (FcVar functionVar)
            )
        )
    ]
  where
    functionTy = TcFunTy boxedIntTy boxedIntTy
    answerVar = Var "answer" (Unique 26) functionTy
    functionVar = Var "function" (Unique 27) functionTy
    argumentVar = Var "argument" (Unique 28) boxedIntTy

primitiveCallProgram :: FcProgram
primitiveCallProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ FcPrimitive addVar 2,
      FcTopBind
        ( FcNonRec
            addOneVar
            (FcLam argumentVar (FcApp (FcApp (FcVar addVar) (FcVar argumentVar)) (FcLit (LitInt IntRep 1) intTy)))
        )
    ]
  where
    addVar = Var "+#" (Unique 29) (TcFunTy intTy (TcFunTy intTy intTy))
    addOneVar = Var "addOne" (Unique 30) (TcFunTy intTy intTy)
    argumentVar = Var "argument" (Unique 31) intTy

arrayPrimitiveProgram :: FcProgram
arrayPrimitiveProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ FcPrimitive newArrayVar 2,
      FcPrimitive addVar 2,
      FcTopBind
        ( FcNonRec
            allocateVar
            ( FcLam
                sizeVar
                (FcLam initialVar (FcApp (FcApp (FcVar newArrayVar) (FcVar sizeVar)) (FcVar initialVar)))
            )
        )
    ]
  where
    arrayTy = TcTyCon (TyCon "Array#" 1) [boxedIntTy]
    newArrayVar = Var "newArray#" (Unique 220) (TcFunTy intTy (TcFunTy boxedIntTy arrayTy))
    addVar = Var "+#" (Unique 221) (TcFunTy intTy (TcFunTy intTy intTy))
    allocateVar = Var "allocate" (Unique 222) (TcFunTy intTy (TcFunTy boxedIntTy arrayTy))
    sizeVar = Var "size" (Unique 223) intTy
    initialVar = Var "initial" (Unique 224) boxedIntTy

mutVarPrimitiveProgram :: FcProgram
mutVarPrimitiveProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ FcPrimitive newMutVarVar 1,
      FcTopBind
        ( FcNonRec
            allocateVar
            (FcLam initialVar (FcApp (FcVar newMutVarVar) (FcVar initialVar)))
        )
    ]
  where
    mutVarTy = TcTyCon (TyCon "MutVar#" 2) [boxedIntTy, boxedIntTy]
    newMutVarVar = Var "newMutVar#" (Unique 225) (TcFunTy boxedIntTy mutVarTy)
    allocateVar = Var "allocateMutVar" (Unique 226) (TcFunTy boxedIntTy mutVarTy)
    initialVar = Var "initial" (Unique 227) boxedIntTy

partialPrimitiveProgram :: FcProgram
partialPrimitiveProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ FcPrimitive addVar 2,
      FcTopBind
        ( FcNonRec
            makeAdderVar
            (FcLam firstVar (FcApp (FcVar addVar) (FcVar firstVar)))
        )
    ]
  where
    addVar = Var "+#" (Unique 130) (TcFunTy intTy (TcFunTy intTy intTy))
    makeAdderVar = Var "makeAdder" (Unique 131) (TcFunTy intTy (TcFunTy intTy intTy))
    firstVar = Var "first" (Unique 132) intTy

unsafeCoerceProgram :: FcProgram
unsafeCoerceProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ FcPrimitive unsafeCoerceVar 1,
      FcTopBind
        ( FcNonRec
            coerceVar
            (FcLam argumentVar (FcApp (FcVar unsafeCoerceVar) (FcVar argumentVar)))
        ),
      FcTopBind (FcNonRec coerceAliasVar (FcVar unsafeCoerceVar))
    ]
  where
    sourceTy = TcTyCon (TyCon "Source" 0) []
    targetTy = TcTyCon (TyCon "Target" 0) []
    coerceTy = TcFunTy sourceTy targetTy
    unsafeCoerceVar = Var "unsafeCoerce#" (Unique 133) coerceTy
    coerceVar = Var "coerce" (Unique 134) coerceTy
    coerceAliasVar = Var "coerceAlias" (Unique 135) coerceTy
    argumentVar = Var "argument" (Unique 136) sourceTy

zeroWidthSaturatedApplicationProgram :: FcProgram
zeroWidthSaturatedApplicationProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ FcTopBind
        ( FcNonRec
            targetVar
            (FcLam targetValueVar (FcLam stateVar (FcVar targetValueVar)))
        ),
      FcTopBind
        ( FcNonRec
            callerVar
            (FcLam callerValueVar (FcApp (FcVar targetVar) (FcVar callerValueVar)))
        )
    ]
  where
    stateTy = TcTyCon (TyCon "State#" 1) [TcTyCon (TyCon "RealWorld" 0) []]
    targetVar = Var "zeroWidthTarget" (Unique 32) (TcFunTy boxedIntTy (TcFunTy stateTy boxedIntTy))
    callerVar = Var "zeroWidthCaller" (Unique 33) (TcFunTy boxedIntTy (TcFunTy stateTy boxedIntTy))
    targetValueVar = Var "targetValue" (Unique 34) boxedIntTy
    stateVar = Var "state" (Unique 35) stateTy
    callerValueVar = Var "callerValue" (Unique 36) boxedIntTy

zeroWidthUnknownApplicationProgram :: FcProgram
zeroWidthUnknownApplicationProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ FcTopBind
        ( FcNonRec
            callerVar
            (FcLam actionVar (FcLam stateVar (FcApp (FcVar actionVar) (FcVar stateVar))))
        )
    ]
  where
    stateTy = TcTyCon (TyCon "State#" 1) [TcTyCon (TyCon "RealWorld" 0) []]
    actionTy = TcFunTy stateTy boxedIntTy
    callerVar = Var "applyZeroWidth" (Unique 37) (TcFunTy actionTy actionTy)
    actionVar = Var "action" (Unique 38) actionTy
    stateVar = Var "state" (Unique 39) stateTy

zeroWidthConstructorProgram :: FcProgram
zeroWidthConstructorProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ fcData "StateBox" [] [("StateBox", [stateTy, boxedIntTy])],
      FcTopBind
        ( FcNonRec
            partialVar
            (FcLam stateVar (FcApp (FcVar constructorVar) (FcVar stateVar)))
        )
    ]
  where
    stateTy = TcTyCon (TyCon "State#" 1) [TcTyCon (TyCon "RealWorld" 0) []]
    resultTy = TcTyCon (TyCon "StateBox" 0) []
    constructorVar = Var "StateBox" (Unique 40) (TcFunTy stateTy (TcFunTy boxedIntTy resultTy))
    partialVar = Var "partialStateBox" (Unique 41) (TcFunTy stateTy (TcFunTy boxedIntTy resultTy))
    stateVar = Var "state" (Unique 42) stateTy

functionClassificationProgram :: FcProgram
functionClassificationProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ fcData "BoxedInt" [] [("BoxedInt", [intTy])],
      FcTopBind
        ( FcNonRec
            directVar
            (FcTyLam typeVar (FcLam dictionaryVar (FcLam directArgumentVar (FcVar directArgumentVar))))
        ),
      FcTopBind
        ( FcNonRec
            computedVar
            ( FcLet
                (FcNonRec expensiveVar (FcApp (FcVar boxConstructorVar) (FcLit (LitInt IntRep 42) intTy)))
                (FcLam computedArgumentVar (FcVar expensiveVar))
            )
        )
    ]
  where
    typeVar = TyVarId "a" (Unique 30)
    typeVarTy = TcTyVar typeVar
    dictionaryVar = Var "$dictionary" (Unique 31) boxedIntTy
    directArgumentVar = Var "argument" (Unique 32) typeVarTy
    directVar = Var "direct" (Unique 33) (TcForAllTy typeVar (TcFunTy boxedIntTy (TcFunTy typeVarTy typeVarTy)))
    expensiveVar = Var "expensive" (Unique 34) boxedIntTy
    computedArgumentVar = Var "argument" (Unique 35) boxedIntTy
    computedVar = Var "computed" (Unique 36) (TcFunTy boxedIntTy boxedIntTy)
    boxConstructorVar = Var "BoxedInt" (Unique 37) (TcFunTy intTy boxedIntTy)

etaExpandedKnownFunctionProgram :: FcProgram
etaExpandedKnownFunctionProgram = knownFunctionWrapperProgram True

nonEtaExpandedKnownFunctionProgram :: FcProgram
nonEtaExpandedKnownFunctionProgram = knownFunctionWrapperProgram False

knownFunctionWrapperProgram :: Bool -> FcProgram
knownFunctionWrapperProgram isEtaExpansion =
  FcProgram
    (FcModuleId "test" "Test")
    [ fcData "Applicative" [] [("$Dict$Applicative", [unaryFunctionTy])],
      FcTopBind
        ( FcNonRec
            pureIoVar
            (FcLam pureValueVar (FcLam stateVar (FcVar pureValueVar)))
        ),
      FcTopBind
        ( FcNonRec
            dictionaryVar
            ( FcApp
                (FcVar dictionaryConstructorVar)
                (FcLam valueVar (FcApp (FcVar pureIoVar) argument))
            )
        )
    ]
  where
    unaryFunctionTy = TcFunTy boxedIntTy boxedIntTy
    pureIoTy = TcFunTy boxedIntTy unaryFunctionTy
    dictionaryTy = TcTyCon (TyCon "Applicative" 0) []
    pureIoVar = Var "pureIO" (Unique 140) pureIoTy
    pureValueVar = Var "value" (Unique 141) boxedIntTy
    stateVar = Var "state" (Unique 142) boxedIntTy
    dictionaryVar = Var "$fApplicativeIO" (Unique 143) dictionaryTy
    dictionaryConstructorVar = Var "$Dict$Applicative" (Unique 144) (TcFunTy unaryFunctionTy dictionaryTy)
    valueVar = Var "value" (Unique 145) boxedIntTy
    argument
      | isEtaExpansion = FcVar valueVar
      | otherwise = FcLit (LitString "changed") boxedIntTy

dictionaryProgram :: FcProgram
dictionaryProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ fcData "Box" [] [("Box", [intTy])],
      fcData "Test" [] [("$Dict$Test", [boxedIntTy, boxedIntTy])],
      FcTopBind
        ( FcNonRec
            answerVar
            ( FcCase
                dictionary
                dictionaryBinder
                [FcAlt (DataAlt (FcConstructorId "test" "Test" "$Dict$Test")) [firstMethod, secondMethod] (FcVar secondMethod)]
            )
        )
    ]
  where
    dictionaryTy = TcTyCon (TyCon "Test" 0) []
    answerVar = Var "answer" (Unique 40) boxedIntTy
    boxConstructorVar = Var "Box" (Unique 41) (TcFunTy intTy boxedIntTy)
    dictionaryConstructorVar = Var "$Dict$Test" (Unique 42) (TcFunTy boxedIntTy (TcFunTy boxedIntTy dictionaryTy))
    dictionaryBinder = Var "$dictionary" (Unique 43) dictionaryTy
    firstMethod = Var "$method0" (Unique 44) boxedIntTy
    secondMethod = Var "$method1" (Unique 45) boxedIntTy
    dictionary = FcApp (FcApp (FcVar dictionaryConstructorVar) (boxed 1)) (boxed 2)
    boxed value = FcApp (FcVar boxConstructorVar) (FcLit (LitInt IntRep value) intTy)

exceptionProgram :: FcProgram
exceptionProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ fcData "BoxedInt" [] [("BoxedInt", [intTy])],
      FcPrimitive raiseVar 1,
      FcPrimitive catchVar 3,
      FcTopBind (FcNonRec answerVar (FcApp (FcVar boxConstructorVar) caughtExpression))
    ]
  where
    raiseVar = Var "raise#" (Unique 1) (TcFunTy intTy intTy)
    catchVar = Var "catch#" (Unique 2) (TcFunTy actionTy (TcFunTy handlerTy (TcFunTy intTy intTy)))
    answerVar = Var "answer" (Unique 3) boxedIntTy
    actionState = Var "actionState" (Unique 4) intTy
    exception = Var "exception" (Unique 5) intTy
    handlerState = Var "handlerState" (Unique 6) intTy
    actionTy = TcFunTy intTy intTy
    handlerTy = TcFunTy intTy (TcFunTy intTy intTy)
    action = FcLam actionState (FcApp (FcVar raiseVar) (FcLit (LitInt IntRep 10) intTy))
    handler = FcLam exception (FcLam handlerState (FcVar exception))
    boxConstructorVar = Var "BoxedInt" (Unique 7) (TcFunTy intTy boxedIntTy)
    caughtExpression =
      FcApp
        (FcApp (FcApp (FcVar catchVar) action) handler)
        (FcLit (LitInt IntRep 0) intTy)

partialCatchProgram :: FcProgram
partialCatchProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ FcPrimitive catchVar 3,
      FcTopBind
        ( FcNonRec
            wrapCatchVar
            (FcLam actionVar (FcApp (FcVar catchVar) (FcVar actionVar)))
        )
    ]
  where
    catchVar = Var "catch#" (Unique 8) (TcFunTy actionTy (TcFunTy handlerTy (TcFunTy stateTy resultTy)))
    wrapCatchVar = Var "wrapCatch" (Unique 9) (TcFunTy actionTy (TcFunTy handlerTy (TcFunTy stateTy resultTy)))
    actionVar = Var "action" (Unique 10) actionTy
    stateTy = TcTyCon (TyCon "State#" 1) [TcTyCon (TyCon "RealWorld" 0) []]
    resultTy = TcTyCon (TyCon "(#,#)" 2) [stateTy, boxedIntTy]
    actionTy = TcFunTy stateTy resultTy
    handlerTy = TcFunTy boxedIntTy actionTy

exitPrimitiveProgram :: FcProgram
exitPrimitiveProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ FcPrimitive exitVar 2,
      FcTopBind (FcNonRec exitActionVar (FcApp (FcVar exitVar) (FcLit (LitInt IntRep 7) intTy))),
      FcTopBind
        ( FcNonRec
            processExitVar
            ( FcLam
                stateVar
                ( FcCase
                    exitCall
                    tupleBinder
                    [FcAlt (DataAlt (FcConstructorId "aihc-prim" "GHC.Types" "(#,#)")) [nextStateVar, resultVar] (FcVar resultVar)]
                )
            )
        )
    ]
  where
    stateTy = TcTyCon (TyCon "State#" 1) [TcTyCon (TyCon "RealWorld" 0) []]
    resultTy = TcTyCon (TyCon "(#,#)" 2) [stateTy, intTy]
    exitVar = Var "aihcExit#" (Unique 11) (TcFunTy intTy (TcFunTy stateTy resultTy))
    processExitVar = Var "processExit" (Unique 12) (TcFunTy stateTy intTy)
    stateVar = Var "state" (Unique 13) stateTy
    tupleBinder = Var "resultTuple" (Unique 14) resultTy
    nextStateVar = Var "nextState" (Unique 15) stateTy
    resultVar = Var "result" (Unique 16) intTy
    exitActionVar = Var "exitAction" (Unique 17) (TcFunTy stateTy resultTy)
    exitCall = FcApp (FcApp (FcVar exitVar) (FcLit (LitInt IntRep 7) intTy)) (FcVar stateVar)

multiValueContinuationProgram :: GrinProgram
multiValueContinuationProgram =
  GrinProgram
    { grinConstructors = [("Box", [[IntRep]])],
      grinPrimitives = [],
      grinForeignCalls = [],
      grinExternalGlobals = [],
      grinExternalFunctions = [],
      grinWhnfGlobals = [],
      grinCafs = [],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = FunctionName "multiValue",
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody =
                GrinBind
                  [first, second]
                  (GrinCall multiValueRep calleeName [])
                  (GrinStore (GrinNode (GrinConstructor "Box" 0) [GrinVarValue first]))
            },
          GrinFunction
            { grinFunctionName = calleeName,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = multiValueRep,
              grinFunctionBody = GrinConstant [GrinLitValue (GrinLitInt IntRep 1), GrinLitValue (GrinLitInt WordRep 2)]
            }
        ]
    }
  where
    first = GrinVar "first" 1 IntRep
    second = GrinVar "second" 2 WordRep
    calleeName = FunctionName "multiValueCallee"
    multiValueRep = TupleRep [IntRep, WordRep]

zeroWidthApplyProgram :: GrinProgram
zeroWidthApplyProgram =
  GrinProgram
    { grinConstructors = [("Box", [[IntRep]])],
      grinPrimitives = [],
      grinForeignCalls = [],
      grinExternalGlobals = [],
      grinExternalFunctions = [],
      grinWhnfGlobals = [],
      grinCafs = [(answer, GrinNode (GrinThunk wrapperName) [])],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = wrapperName,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody =
                GrinBind
                  [closurePointer]
                  (GrinStore (GrinNode (GrinClosure targetName [[]]) []))
                  ( GrinBind
                      [closure]
                      (GrinEval (BoxedRep Lifted) (GrinVarValue closurePointer))
                      (GrinApply (BoxedRep Lifted) (GrinVarValue closure) [])
                  )
            },
          GrinFunction
            { grinFunctionName = targetName,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody = GrinStore (GrinNode (GrinConstructor "Box" 0) [GrinLitValue (GrinLitInt IntRep 1)])
            }
        ]
    }
  where
    answer = GrinVar "answer" 1 (BoxedRep Lifted)
    closurePointer = GrinVar "closure_pointer" 2 (BoxedRep Lifted)
    closure = GrinVar "closure" 3 (BoxedRep Lifted)
    wrapperName = FunctionName "zeroWidthWrapper"
    targetName = FunctionName "zeroWidthTarget"

heapProgram :: GrinProgram
heapProgram =
  GrinProgram
    { grinConstructors = [("Box", [[IntRep]])],
      grinPrimitives = [],
      grinForeignCalls = [],
      grinExternalGlobals = [],
      grinExternalFunctions = [],
      grinWhnfGlobals = [],
      grinCafs =
        [ ( answer,
            GrinNode (GrinThunk functionName) []
          )
        ],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = functionName,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody =
                GrinBind [pointer] (GrinStore (GrinNode (GrinConstructor "Box" 0) [GrinLitValue (GrinLitInt IntRep 1)])) $
                  GrinBind [fetched] (GrinFetch (BoxedRep Lifted) (GrinVarValue pointer)) $
                    GrinBind [replacementPointer] (GrinStore replacementBox) $
                      GrinBind [replacement] (GrinFetch (BoxedRep Lifted) (GrinVarValue replacementPointer)) $
                        GrinBind [updated] (GrinUpdate (GrinVarValue pointer) (GrinVarValue replacement)) $
                          GrinEval (BoxedRep Lifted) (GrinVarValue pointer)
            }
        ]
    }
  where
    answer = GrinVar "answer" 1 (BoxedRep Lifted)
    pointer = GrinVar "pointer" 2 (BoxedRep Lifted)
    fetched = GrinVar "fetched" 3 (BoxedRep Lifted)
    replacementPointer = GrinVar "replacement_pointer" 4 (BoxedRep Lifted)
    replacement = GrinVar "replacement" 5 (BoxedRep Lifted)
    updated = GrinVar "updated" 6 (BoxedRep Lifted)
    replacementBox = GrinNode (GrinConstructor "Box" 0) [GrinLitValue (GrinLitInt IntRep 2)]
    functionName = FunctionName "answer_code"

implicitCaseEvaluationProgram :: GrinProgram
implicitCaseEvaluationProgram =
  implicitEvaluationProgram $
    GrinCase
      (GrinVarValue implicitPointer)
      implicitValue
      [ GrinAlt
          (GrinDataAlt "Box")
          [implicitField]
          (GrinConstant [GrinVarValue implicitValue])
      ]

implicitApplyEvaluationProgram :: GrinProgram
implicitApplyEvaluationProgram =
  implicitEvaluationProgram $
    GrinApply
      (BoxedRep Lifted)
      (GrinVarValue implicitPointer)
      []

implicitEvaluationProgram :: GrinExpr -> GrinProgram
implicitEvaluationProgram operation =
  GrinProgram
    { grinConstructors = [("Box", [[IntRep]])],
      grinPrimitives = [],
      grinForeignCalls = [],
      grinExternalGlobals = [],
      grinExternalFunctions = [],
      grinWhnfGlobals = [],
      grinCafs = [(implicitAnswer, GrinNode (GrinThunk implicitAnswerFunction) [])],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = implicitAnswerFunction,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody =
                GrinBind
                  [implicitPointer]
                  (GrinStore (GrinNode (GrinThunk implicitValueFunction) []))
                  operation
            },
          GrinFunction
            { grinFunctionName = implicitValueFunction,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody =
                GrinStore
                  (GrinNode (GrinConstructor "Box" 0) [GrinLitValue (GrinLitInt IntRep 1)])
            }
        ]
    }

implicitAnswer :: GrinVar
implicitAnswer = GrinVar "answer" 100 (BoxedRep Lifted)

implicitPointer :: GrinVar
implicitPointer = GrinVar "pointer" 101 (BoxedRep Lifted)

implicitValue :: GrinVar
implicitValue = GrinVar "value" 102 (BoxedRep Lifted)

implicitField :: GrinVar
implicitField = GrinVar "field" 103 IntRep

implicitAnswerFunction :: FunctionName
implicitAnswerFunction = FunctionName "implicit_answer"

implicitValueFunction :: FunctionName
implicitValueFunction = FunctionName "implicit_value"

storedWhnfEvalProgram :: GrinProgram
storedWhnfEvalProgram =
  emptyGrinProgram
    { grinConstructors = [("Box", [])],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = storedWhnfEntry,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody =
                GrinBind
                  [storedWhnfPointer]
                  (GrinStore (GrinNode (GrinConstructor "Box" 0) []))
                  (GrinEval (BoxedRep Lifted) (GrinVarValue storedWhnfPointer))
            }
        ]
    }

staticWhnfProgram :: GrinProgram
staticWhnfProgram =
  emptyGrinProgram
    { grinConstructors = [("Box", [])],
      grinWhnfGlobals = [(staticWhnfGlobal, GrinNode (GrinConstructor "Box" 0) [])],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = staticWhnfEntry,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody = GrinEval (BoxedRep Lifted) (GrinVarValue staticWhnfGlobal)
            }
        ]
    }

storedClosureApplyProgram :: GrinProgram
storedClosureApplyProgram =
  emptyGrinProgram
    { grinConstructors = [("Box", [])],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = storedClosureEntry,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody =
                GrinBind
                  [storedClosurePointer]
                  (GrinStore (GrinNode (GrinClosure storedClosureTarget [[BoxedRep Lifted]]) []))
                  ( GrinBind
                      [storedClosureArgument]
                      (GrinStore (GrinNode (GrinConstructor "Box" 0) []))
                      ( GrinApply
                          (BoxedRep Lifted)
                          (GrinVarValue storedClosurePointer)
                          [GrinVarValue storedClosureArgument]
                      )
                  )
            },
          GrinFunction
            { grinFunctionName = storedClosureTarget,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [storedClosureParameter],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody = GrinConstant [GrinVarValue storedClosureParameter]
            }
        ]
    }

storedWhnfCaseProgram :: GrinProgram
storedWhnfCaseProgram =
  emptyGrinProgram
    { grinConstructors = [("Box", [])],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = storedWhnfCaseEntry,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody =
                GrinBind
                  [storedWhnfPointer]
                  (GrinStore (GrinNode (GrinConstructor "Box" 0) []))
                  ( GrinCase
                      (GrinVarValue storedWhnfPointer)
                      storedWhnfBinder
                      [ GrinAlt
                          (GrinDataAlt "Box")
                          []
                          (GrinConstant [GrinVarValue storedWhnfBinder])
                      ]
                  )
            }
        ]
    }

emptyGrinProgram :: GrinProgram
emptyGrinProgram =
  GrinProgram
    { grinConstructors = [],
      grinPrimitives = [],
      grinForeignCalls = [],
      grinExternalGlobals = [],
      grinExternalFunctions = [],
      grinWhnfGlobals = [],
      grinCafs = [],
      grinFunctions = []
    }

storedWhnfEntry, staticWhnfEntry, storedWhnfCaseEntry, storedClosureEntry, storedClosureTarget :: FunctionName
storedWhnfEntry = FunctionName "stored_whnf"
staticWhnfEntry = FunctionName "static_whnf"
storedWhnfCaseEntry = FunctionName "stored_whnf_case"
storedClosureEntry = FunctionName "stored_closure"
storedClosureTarget = FunctionName "stored_closure_target"

storedWhnfPointer, staticWhnfGlobal, storedWhnfBinder, storedClosurePointer, storedClosureArgument, storedClosureParameter :: GrinVar
storedWhnfPointer = GrinVar "stored_whnf_pointer" 104 (BoxedRep Lifted)
staticWhnfGlobal = GrinVar "static_whnf_global" 105 (BoxedRep Lifted)
storedWhnfBinder = GrinVar "stored_whnf_binder" 106 (BoxedRep Lifted)
storedClosurePointer = GrinVar "stored_closure_pointer" 107 (BoxedRep Lifted)
storedClosureArgument = GrinVar "stored_closure_argument" 108 (BoxedRep Lifted)
storedClosureParameter = GrinVar "stored_closure_parameter" 109 (BoxedRep Lifted)

directBindProgram :: GrinProgram
directBindProgram =
  heapProgram
    { grinCafs = [],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = FunctionName "direct_binds",
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody =
                GrinBind [constant] (GrinConstant [zero]) $
                  GrinBind [pointer] (GrinStore box) $
                    GrinBind [selected] (GrinCase (GrinVarValue constant) caseBinder [alternative]) $
                      GrinConstant [GrinVarValue selected]
            }
        ]
    }
  where
    constant = GrinVar "constant" 1 IntRep
    pointer = GrinVar "pointer" 2 (BoxedRep Lifted)
    caseBinder = GrinVar "case" 3 IntRep
    selected = GrinVar "selected" 4 (BoxedRep Lifted)
    zero = GrinLitValue (GrinLitInt IntRep 0)
    box = GrinNode (GrinConstructor "Box" 0) [GrinLitValue (GrinLitInt IntRep 1)]
    alternative =
      GrinAlt
        { grinAltCon = GrinDefaultAlt,
          grinAltBinders = [],
          grinAltRhs = GrinConstant [GrinVarValue pointer]
        }

nestedDirectBindEntry :: FunctionName
nestedDirectBindEntry = FunctionName "nested_direct_bind"

nestedDirectBindProgram :: GrinProgram
nestedDirectBindProgram =
  emptyGrinProgram
    { grinConstructors = [("Box", [[IntRep]])],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = nestedDirectBindEntry,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody =
                GrinBind
                  [outer]
                  ( GrinBind
                      [middle]
                      ( GrinBind
                          [inner]
                          (GrinStore box)
                          (GrinConstant [GrinVarValue inner])
                      )
                      (GrinConstant [GrinVarValue middle])
                  )
                  (GrinConstant [GrinVarValue outer])
            }
        ]
    }
  where
    inner = GrinVar "inner" 220 (BoxedRep Lifted)
    middle = GrinVar "middle" 221 (BoxedRep Lifted)
    outer = GrinVar "outer" 222 (BoxedRep Lifted)
    box = GrinNode (GrinConstructor "Box" 0) [GrinLitValue (GrinLitInt IntRep 1)]

nestedCallBindProgram :: GrinProgram
nestedCallBindProgram =
  nestedDirectBindProgram
    { grinFunctions =
        [ GrinFunction
            { grinFunctionName = nestedDirectBindEntry,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody =
                GrinBind
                  [outer]
                  ( GrinBind
                      [inner]
                      (GrinCall (BoxedRep Lifted) callee [])
                      (GrinConstant [GrinVarValue inner])
                  )
                  (GrinConstant [GrinVarValue outer])
            },
          GrinFunction
            { grinFunctionName = callee,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody = GrinStore box
            }
        ]
    }
  where
    callee = FunctionName "nested_call_callee"
    inner = GrinVar "inner" 223 (BoxedRep Lifted)
    outer = GrinVar "outer" 224 (BoxedRep Lifted)
    box = GrinNode (GrinConstructor "Box" 0) [GrinLitValue (GrinLitInt IntRep 1)]

gcRootProgram :: GrinProgram
gcRootProgram =
  heapProgram
    { grinConstructors = [("Box", [[BoxedRep Lifted]])],
      grinCafs = [],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = FunctionName "gc_roots",
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [root, scalar],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody =
                GrinBind
                  [result]
                  (GrinStore (GrinNode (GrinConstructor "Box" 0) [GrinVarValue root]))
                  (GrinConstant [GrinVarValue result])
            }
        ]
    }
  where
    root = GrinVar "root" 201 (BoxedRep Lifted)
    scalar = GrinVar "scalar" 202 IntRep
    result = GrinVar "result" 203 (BoxedRep Lifted)

gcArrayProgram :: GrinProgram
gcArrayProgram =
  heapProgram
    { grinPrimitives = [(arrayPrimitive, 2), (plusPrimitive, 2)],
      grinCafs = [],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = FunctionName "gc_array",
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [arraySize, initial],
              grinFunctionResultRep = BoxedRep Unlifted,
              grinFunctionBody =
                GrinBind
                  [arrayWords]
                  (GrinPrimitiveCall IntRep "+#" [GrinVarValue arraySize, GrinLitValue (GrinLitInt IntRep 2)])
                  ( GrinBind
                      []
                      (GrinEnsureHeap (GrinVarValue arrayWords) [])
                      ( GrinBind
                          [array]
                          (GrinPrimitiveCall (BoxedRep Unlifted) "newArray#" [GrinVarValue arraySize, GrinVarValue initial])
                          (GrinConstant [GrinVarValue array])
                      )
                  )
            }
        ]
    }
  where
    arrayPrimitive = GrinVar "newArray#" 210 (BoxedRep Unlifted)
    plusPrimitive = GrinVar "+#" 214 IntRep
    arraySize = GrinVar "size" 211 IntRep
    initial = GrinVar "initial" 212 (BoxedRep Lifted)
    array = GrinVar "array" 213 (BoxedRep Unlifted)
    arrayWords = GrinVar "array_words" 215 IntRep

callBindProgram :: GrinProgram
callBindProgram =
  heapProgram
    { grinCafs = [],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = caller,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [capture],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody =
                GrinBind [result] (GrinCall (BoxedRep Lifted) callee []) $
                  GrinConstant [GrinVarValue capture]
            },
          GrinFunction
            { grinFunctionName = callee,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody = GrinStore box
            }
        ]
    }
  where
    caller = FunctionName "caller"
    callee = FunctionName "callee"
    capture = GrinVar "capture" 1 (BoxedRep Lifted)
    result = GrinVar "result" 2 (BoxedRep Lifted)
    box = GrinNode (GrinConstructor "Box" 0) [GrinLitValue (GrinLitInt IntRep 1)]

transferringExpressions :: [GrinExpr]
transferringExpressions =
  [ GrinEval lifted string,
    GrinCall lifted (FunctionName "callee") [],
    GrinApply lifted string []
  ]
  where
    lifted = BoxedRep Lifted
    string = GrinLitValue (GrinLitString "function")

cpsOnlyExpressions :: [GrinExpr]
cpsOnlyExpressions =
  [ GrinCpsEval lifted string string string,
    GrinCpsPrimitiveCall lifted "fork#" [string] string,
    GrinCpsApply lifted string [] string,
    GrinContinue string [],
    GrinUpdateBlackhole string string,
    GrinHalt []
  ]
  where
    lifted = BoxedRep Lifted
    string = GrinLitValue (GrinLitString "continuation")

controlPrimitiveBindProgram :: Text -> GrinProgram
controlPrimitiveBindProgram name =
  GrinProgram
    { grinConstructors = [],
      grinPrimitives = [(GrinVar name 1 lifted, primitiveArity)],
      grinForeignCalls = [],
      grinExternalGlobals = [],
      grinExternalFunctions = [],
      grinWhnfGlobals = [],
      grinCafs = [],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = FunctionName "control_primitive",
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = lifted,
              grinFunctionBody = GrinBind resultVars primitiveCall (GrinConstant [string])
            }
        ]
    }
  where
    lifted = BoxedRep Lifted
    string = GrinLitValue (GrinLitString "result")
    (primitiveArity, resultVars, primitiveCall) =
      case name of
        "fork#" ->
          ( 2,
            [GrinVar "thread_id" 2 (BoxedRep Unlifted)],
            GrinPrimitiveCall (TupleRep [TupleRep [], BoxedRep Unlifted]) name [GrinLitValue (GrinLitString "action")]
          )
        "awaitIO#" ->
          ( 2,
            [],
            GrinPrimitiveCall
              (TupleRep [])
              name
              [GrinLitValue (GrinLitAddr "request")]
          )
        "newMVar#" ->
          ( 1,
            [GrinVar "mvar" 2 (BoxedRep Unlifted)],
            GrinPrimitiveCall (BoxedRep Unlifted) name []
          )
        "readMVar#" -> mvarValueOperation name
        "takeMVar#" -> mvarValueOperation name
        "putMVar#" ->
          ( 3,
            [],
            GrinPrimitiveCall
              (TupleRep [])
              name
              [ GrinLitValue (GrinLitString "mvar"),
                GrinLitValue (GrinLitString "value")
              ]
          )
        _ -> (1, [], GrinPrimitiveCall (TupleRep []) name [])

    mvarValueOperation operation =
      ( 2,
        [GrinVar "value" 2 (BoxedRep Lifted)],
        GrinPrimitiveCall (BoxedRep Lifted) operation [GrinLitValue (GrinLitString "mvar")]
      )

containsCpsPrimitive :: Text -> GrinExpr -> Bool
containsCpsPrimitive name expression =
  case expression of
    GrinCpsPrimitiveCall _ actual _ _ -> actual == name
    GrinBind _ value body -> containsCpsPrimitive name value || containsCpsPrimitive name body
    GrinStoreRec _ body -> containsCpsPrimitive name body
    GrinCase _ _ alternatives -> any (containsCpsPrimitive name . grinAltRhs) alternatives
    _ -> False

cpsOnlyFunction :: FunctionName
cpsOnlyFunction = FunctionName "cps_only"

cpsOnlyProgram :: GrinExpr -> GrinProgram
cpsOnlyProgram expression =
  directBindProgram
    { grinFunctions =
        [ GrinFunction
            { grinFunctionName = cpsOnlyFunction,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody = expression
            }
        ]
    }

singleBindProgram :: GrinExpr -> GrinProgram
singleBindProgram valueExpression =
  directBindProgram
    { grinFunctions =
        [ GrinFunction
            { grinFunctionName = FunctionName "single_bind",
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody =
                GrinBind [result] valueExpression $
                  GrinConstant [GrinVarValue result]
            }
        ]
    }
  where
    result = GrinVar "result" 1 (BoxedRep Lifted)

exceptionBoundaryProgram :: GrinExpr -> GrinProgram
exceptionBoundaryProgram body =
  GrinProgram
    { grinConstructors = [],
      grinPrimitives = [],
      grinForeignCalls = [],
      grinExternalGlobals = [],
      grinExternalFunctions = [],
      grinWhnfGlobals = [],
      grinCafs = [],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = exceptionBoundaryFunction,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = IntRep,
              grinFunctionBody = body
            }
        ]
    }

exceptionBoundaryFunction :: FunctionName
exceptionBoundaryFunction = FunctionName "exception_boundary"

exceptionAction :: GrinValue
exceptionAction = GrinLitValue (GrinLitString "action")

exceptionHandler :: GrinValue
exceptionHandler = GrinLitValue (GrinLitString "handler")

exceptionValue :: GrinValue
exceptionValue = GrinLitValue (GrinLitInt IntRep 1)

invalidUpdateProgram :: GrinProgram
invalidUpdateProgram =
  heapProgram
    { grinFunctions =
        [ GrinFunction
            { grinFunctionName = FunctionName "answer_code",
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = BoxedRep Lifted,
              grinFunctionBody =
                GrinBind [pointer] (GrinStore initialBox) $
                  GrinBind [updated] (GrinUpdate (GrinVarValue pointer) (GrinLitValue (GrinLitInt IntRep 2))) $
                    GrinConstant [GrinLitValue (GrinLitInt IntRep 0)]
            }
        ]
    }
  where
    pointer = GrinVar "pointer" 2 (BoxedRep Lifted)
    updated = GrinVar "updated" 3 IntRep
    initialBox = GrinNode (GrinConstructor "Box" 0) [GrinLitValue (GrinLitInt IntRep 1)]

unliftedRuntimeReps :: [RuntimeRep]
unliftedRuntimeReps =
  [ IntRep,
    WordRep,
    BoxedRep Unlifted,
    TupleRep [IntRep, WordRep],
    TupleRep []
  ]

unliftedHeapProgram :: RuntimeRep -> GrinProgram
unliftedHeapProgram runtimeRep =
  GrinProgram
    { grinConstructors = [],
      grinPrimitives = [],
      grinForeignCalls = [],
      grinExternalGlobals = [],
      grinExternalFunctions = [],
      grinWhnfGlobals = [],
      grinCafs = [(GrinVar "bad" 1 (BoxedRep Lifted), GrinNode (GrinThunk unliftedThunkFunction) [GrinLitValue (GrinLitString "capture")])],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = unliftedThunkFunction,
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [pointer],
              grinFunctionResultRep = runtimeRep,
              grinFunctionBody =
                GrinBind
                  [updated]
                  (GrinUpdate (GrinVarValue pointer) (GrinLitValue (GrinLitInt runtimeRep 0)))
                  ( GrinConstant
                      [ GrinLitValue (GrinLitInt componentRep 0)
                      | componentRep <- runtimeRepComponents runtimeRep
                      ]
                  )
            }
        ]
    }
  where
    pointer = GrinVar "pointer" 2 (BoxedRep Lifted)
    updated = GrinVar "updated" 3 runtimeRep

unliftedThunkFunction :: FunctionName
unliftedThunkFunction = FunctionName "unlifted_thunk"

intTy :: TcType
intTy = TcTyCon (TyCon "Int#" 0) []

boxedIntTy :: TcType
boxedIntTy = TcTyCon (TyCon "Int" 0) []

foreignProgram :: FcProgram
foreignProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ fcData "BoxedInt32" [] [("BoxedInt32", [int32Ty])],
      FcForeignImport foreignCall,
      FcTopBind
        ( FcNonRec
            foreignAnswerVar
            (FcApp (FcVar foreignBoxConstructorVar) (FcCallForeign foreignCall [FcLit (LitInt Int32Rep 42) int32Ty]))
        )
    ]

undersaturatedForeignProgram :: FcProgram
undersaturatedForeignProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ fcData "BoxedInt32" [] [("BoxedInt32", [int32Ty])],
      FcForeignImport foreignCall,
      FcTopBind (FcNonRec foreignAnswerVar (FcApp (FcVar foreignBoxConstructorVar) (FcCallForeign foreignCall [])))
    ]

foreignCall :: FcForeignCall
foreignCall =
  FcForeignCall
    { fcForeignCallName = "$ffi$abs",
      fcForeignCallSymbol = "abs",
      fcForeignCallSignature =
        FcForeignSignature
          { fcForeignArgumentTypes = [FcForeignInt32],
            fcForeignResultType = FcForeignInt32,
            fcForeignEffect = FcForeignPure
          }
    }

foreignAnswerVar :: Var
foreignAnswerVar = Var "answer" (Unique 50) boxedIntTy

foreignBoxConstructorVar :: Var
foreignBoxConstructorVar = Var "BoxedInt32" (Unique 51) (TcFunTy int32Ty boxedIntTy)

int32Ty :: TcType
int32Ty = TcTyCon (TyCon "Int32#" 0) []

saturatedConstructorProgram :: FcProgram
saturatedConstructorProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ fcData "Int32" [] [("I32#", [int32Ty])],
      FcTopBind
        ( FcNonRec
            int32WrapperVar
            (FcLam int32ArgumentVar (FcApp (FcVar int32ConstructorVar) (FcVar int32ArgumentVar)))
        )
    ]
  where
    int32WrapperVar = Var "wrapInt32" (Unique 60) (TcFunTy int32Ty boxedInt32Ty)
    int32ConstructorVar = Var "I32#" (Unique 61) (TcFunTy int32Ty boxedInt32Ty)

tailStoredTupleProgram :: FcProgram
tailStoredTupleProgram =
  FcProgram
    (FcModuleId "test" "Test")
    [ fcData "Box" [] [("Box", [intTy])],
      FcPrimitive tailStoredStateVar 0,
      FcTopBind
        ( FcNonRec
            tailStoredFunctionVar
            ( FcLam
                tailStoredValueVar
                ( FcApp
                    (FcApp (FcVar tailStoredTupleConstructorVar) (FcVar tailStoredStateVar))
                    (FcApp (FcVar tailStoredBoxConstructorVar) (FcVar tailStoredValueVar))
                )
            )
        )
    ]

tailStoredFunctionVar :: Var
tailStoredFunctionVar = Var "tailStored" (Unique 80) (TcFunTy intTy tailStoredTupleTy)

tailStoredValueVar :: Var
tailStoredValueVar = Var "value" (Unique 81) intTy

tailStoredStateVar :: Var
tailStoredStateVar = Var "realWorld#" (Unique 82) tailStoredStateTy

tailStoredBoxConstructorVar :: Var
tailStoredBoxConstructorVar = Var "Box" (Unique 83) (TcFunTy intTy tailStoredBoxTy)

tailStoredTupleConstructorVar :: Var
tailStoredTupleConstructorVar =
  Var "(#,#)" (Unique 84) (TcFunTy tailStoredStateTy (TcFunTy tailStoredBoxTy tailStoredTupleTy))

tailStoredStateTy :: TcType
tailStoredStateTy = TcTyCon (TyCon "State#" 1) [TcTyCon (TyCon "RealWorld" 0) []]

tailStoredBoxTy :: TcType
tailStoredBoxTy = TcTyCon (TyCon "Box" 0) []

tailStoredTupleTy :: TcType
tailStoredTupleTy = TcTyCon tupleTyCon fields
  where
    fields = [tailStoredStateTy, tailStoredBoxTy]
    tupleTyCon = mkTyCon "Tuple2#" 2 (foldr (KFun . typeKind) (KTYPE (TupleRep [TupleRep [], BoxedRep Lifted])) fields)

boxedInt32Ty :: TcType
boxedInt32Ty = TcTyCon (TyCon "Int32" 0) []

int32ArgumentVar :: Var
int32ArgumentVar = Var "value" (Unique 62) int32Ty

separateConstructorPrograms :: [FcProgram]
separateConstructorPrograms =
  [ FcProgram (FcModuleId "test" "Test") [fcData "Int32" [] [("I32#", [int32Ty])]],
    FcProgram
      (FcModuleId "test" "Test")
      [ FcTopBind
          ( FcNonRec
              wrapperVar
              (FcLam argumentVar (FcApp (FcVar constructorVar) (FcVar argumentVar)))
          )
      ]
  ]
  where
    wrapperVar = Var "wrapInt32" (Unique 70) (TcFunTy int32Ty boxedInt32Ty)
    constructorVar = Var "I32#" (Unique 71) (TcFunTy int32Ty boxedInt32Ty)
    argumentVar = Var "value" (Unique 72) int32Ty

separatePrograms :: [FcProgram]
separatePrograms =
  [ FcProgram (FcModuleId "test" "Test") [FcTopBind (FcNonRec sourceVar (FcLit (LitString "provider") boxedIntTy))],
    FcProgram (FcModuleId "test" "Test") [FcTopBind (FcNonRec answerVar (FcLam argumentVar (FcVar sourceVar)))]
  ]
  where
    sourceVar = Var "source" (Unique 30) boxedIntTy
    answerVar = Var "answer" (Unique 31) (TcFunTy boxedIntTy boxedIntTy)
    argumentVar = Var "argument" (Unique 32) boxedIntTy

separateFunctionPrograms :: [FcProgram]
separateFunctionPrograms =
  [ FcProgram
      (FcModuleId "test" "Test")
      [ FcTopBind (FcNonRec sourceVar (FcLit (LitString "provider") boxedIntTy)),
        FcTopBind (FcNonRec identityVar (FcLam argumentVar (FcVar argumentVar)))
      ],
    FcProgram (FcModuleId "test" "Test") [FcTopBind (FcNonRec answerVar (FcApp (FcVar identityVar) (FcVar sourceVar)))]
  ]
  where
    sourceVar = Var "source" (Unique 80) boxedIntTy
    identityVar = Var "identity" (Unique 81) (TcFunTy boxedIntTy boxedIntTy)
    argumentVar = Var "argument" (Unique 82) boxedIntTy
    answerVar = Var "answer" (Unique 83) boxedIntTy

separateLinkableFunctionPrograms :: Text -> Int -> [FcProgram]
separateLinkableFunctionPrograms qualifier uniqueBase =
  [ FcProgram (FcModuleId "" qualifier) [FcTopBind (FcNonRec identityVar (FcLam argumentVar (FcVar argumentVar)))],
    FcProgram (FcModuleId "exe" "Main") [FcTopBind (FcNonRec answerVar (FcApp (FcVar importedIdentityVar) (FcLit (LitString "argument") boxedIntTy)))]
  ]
  where
    identityType = TcFunTy boxedIntTy boxedIntTy
    identityVar = Var "identity" (Unique uniqueBase) identityType
    importedIdentityVar =
      (Var "identity" (Unique uniqueBase) identityType)
        { varResolvedName = Just (FcTopLevelOrigin "" qualifier "identity")
        }
    argumentVar = Var "argument" (Unique (uniqueBase + 1)) boxedIntTy
    answerVar = Var "answer" (Unique (uniqueBase + 2)) boxedIntTy

separateLinkableGlobalPrograms :: Text -> Int -> [FcProgram]
separateLinkableGlobalPrograms qualifier uniqueBase =
  [ FcProgram (FcModuleId "" qualifier) [FcTopBind (FcNonRec valueVar (FcLit (LitString "provider") boxedIntTy))],
    FcProgram (FcModuleId "exe" "Main") [FcTopBind (FcNonRec answerVar (FcVar importedValueVar))]
  ]
  where
    valueVar = Var "value" (Unique uniqueBase) boxedIntTy
    importedValueVar =
      (Var "value" (Unique uniqueBase) boxedIntTy)
        { varResolvedName = Just (FcTopLevelOrigin "" qualifier "value")
        }
    answerVar = Var "answer" (Unique (uniqueBase + 1)) boxedIntTy

separateBuiltinUnitPrograms :: [FcProgram]
separateBuiltinUnitPrograms =
  [ FcProgram
      (FcModuleId "aihc-prim" "GHC.Tuple")
      [ FcData (FcDataDecl (FcBuiltinOrigin "Unit") "Unit" [] KType [FcDataConDecl unitConstructor "()" []])
      ],
    FcProgram
      (FcModuleId "" "Main")
      [ FcExternal unitOrigin unitTy,
        FcTopBind (FcNonRec answerVar (FcVar importedUnitVar))
      ]
  ]
  where
    unitConstructor = FcConstructorId "aihc-prim" "GHC.Tuple" "()"
    unitOrigin = fcConstructorSymbolOrigin unitConstructor
    unitTy = TcTyCon (TyCon "Unit" 0) []
    importedUnitVar = (Var "()" (Unique 130) unitTy) {varResolvedName = Just unitOrigin}
    answerVar = Var "answer" (Unique 131) unitTy

separateNewtypePrograms :: [FcProgram]
separateNewtypePrograms =
  [ FcProgram (FcModuleId "test" "Test") [FcNewtype declaration],
    FcProgram (FcModuleId "test" "Test") [FcTopBind (FcNonRec answerVar (FcLam argumentVar (FcApp (FcVar constructorVar) (FcLit (LitInt IntRep 42) intTy))))]
  ]
  where
    declaration =
      FcNewtypeDecl
        { fcNewtypeOrigin = FcTopLevelOrigin "test" "Test" "Wrapper",
          fcNewtypeName = "Wrapper",
          fcNewtypeTyVars = [],
          fcNewtypeConstructorOrigin = FcConstructorId "test" "Test" "Wrap",
          fcNewtypeConstructor = "Wrap",
          fcNewtypeRepresentation = intTy,
          fcNewtypeResult = wrapperTy
        }
    wrapperTy = TcTyCon (TyCon "Wrapper" 0) []
    constructorVar = Var "Wrap" (Unique 40) (TcFunTy intTy wrapperTy)
    answerVar = Var "answer" (Unique 41) (TcFunTy boxedIntTy wrapperTy)
    argumentVar = Var "argument" (Unique 42) boxedIntTy

processExitProgram :: GrinProgram
processExitProgram =
  GrinProgram
    { grinConstructors = [],
      grinPrimitives = [],
      grinForeignCalls = [],
      grinExternalGlobals = [],
      grinExternalFunctions = [],
      grinWhnfGlobals = [],
      grinCafs = [],
      grinFunctions =
        [ GrinFunction
            { grinFunctionName = FunctionName "process_exit",
              grinFunctionLinkName = Nothing,
              grinFunctionParameters = [],
              grinFunctionResultRep = TupleRep [],
              grinFunctionBody = GrinExit (GrinLitValue (GrinLitInt IntRep 7))
            }
        ]
    }

fcData :: Text -> [TyVarId] -> [(Text, [TcType])] -> FcTopBind
fcData dataName tyVars constructors =
  FcData
    ( FcDataDecl
        (testOrigin dataName)
        dataName
        tyVars
        KType
        [FcDataConDecl (FcConstructorId "test" "Test" constructorName) constructorName fields | (constructorName, fields) <- constructors]
    )
  where
    testOrigin = FcTopLevelOrigin "test" "Test"
