Add GHC Identity to Juvix/Prelude (#2815)

app/Commands/Dev/Core/Compile/Base.hs

@@ -159,7 +159,7 @@ runTreePipeline pa@PipelineArg {..} = do
   r <-
     runReader entryPoint
       . runError @JuvixError
-      . coreToTree Core.Identity
+      . coreToTree Core.IdentityTrans
       $ _pipelineArgModule
   tab' <- getRight r
   let code = Tree.ppPrint tab' tab'

app/Commands/Dev/Core/Strip.hs

@@ -16,7 +16,7 @@ runCommand opts = do
         run
           . runReader (project' @Core.CoreOptions gopts)
           . runError @JuvixError
-          $ Core.toStripped' Core.Identity (Core.moduleFromInfoTable tab)
+          $ Core.toStripped' Core.IdentityTrans (Core.moduleFromInfoTable tab)
   tab' <- getRight $ mapRight (Stripped.fromCore (project gopts ^. Core.optFieldSize) . Core.computeCombinedInfoTable) r
   unless (project opts ^. coreStripNoPrint) $ do
     renderStdOut (Core.ppOut opts tab')

src/Juvix/Compiler/Core/Data/TransformationId.hs

@@ -13,7 +13,7 @@ data TransformationId
   | NatToPrimInt
   | IntToPrimInt
   | ConvertBuiltinTypes
-  | Identity
+  | IdentityTrans
   | UnrollRecursion
   | ComputeTypeInfo
   | MatchToCase
@@ -92,7 +92,7 @@ instance TransformationId' TransformationId where
     MatchToCase -> strMatchToCase
     NaiveMatchToCase -> strNaiveMatchToCase
     EtaExpandApps -> strEtaExpandApps
-    Identity -> strIdentity
+    IdentityTrans -> strIdentity
     RemoveTypeArgs -> strRemoveTypeArgs
     MoveApps -> strMoveApps
     NatToPrimInt -> strNatToPrimInt
@@ -144,5 +144,5 @@ instance PipelineId' TransformationId PipelineId where
     PipelineNormalize -> toNormalizeTransformations
     PipelineGeb -> toGebTransformations
     PipelineVampIR -> toVampIRTransformations
-    PipelineStripped -> toStrippedTransformations Identity
+    PipelineStripped -> toStrippedTransformations IdentityTrans
     PipelineExec -> toStrippedTransformations CheckExec

src/Juvix/Compiler/Core/Transformation.hs

@@ -25,7 +25,7 @@ import Juvix.Compiler.Core.Transformation.ConvertBuiltinTypes
 import Juvix.Compiler.Core.Transformation.DisambiguateNames
 import Juvix.Compiler.Core.Transformation.Eta
 import Juvix.Compiler.Core.Transformation.FoldTypeSynonyms
-import Juvix.Compiler.Core.Transformation.Identity
+import Juvix.Compiler.Core.Transformation.IdentityTrans
 import Juvix.Compiler.Core.Transformation.IntToPrimInt
 import Juvix.Compiler.Core.Transformation.LambdaLetRecLifting
 import Juvix.Compiler.Core.Transformation.LetHoisting
@@ -66,7 +66,7 @@ applyTransformations ts tbl = foldM (flip appTrans) tbl ts
     appTrans = \case
       LambdaLetRecLifting -> return . lambdaLetRecLifting
       LetRecLifting -> return . letRecLifting
-      Identity -> return . identity
+      IdentityTrans -> return . identity
       TopEtaExpand -> return . topEtaExpand
       RemoveTypeArgs -> return . removeTypeArgs
       MoveApps -> return . moveApps

src/Juvix/Compiler/Core/Transformation/IdentityTrans.hs

@@ -1,5 +1,5 @@
-module Juvix.Compiler.Core.Transformation.Identity
-  ( module Juvix.Compiler.Core.Transformation.Identity,
+module Juvix.Compiler.Core.Transformation.IdentityTrans
+  ( module Juvix.Compiler.Core.Transformation.IdentityTrans,
     module Juvix.Compiler.Core.Transformation.Base,
   )
 where

src/Juvix/Compiler/Pipeline.hs

@@ -156,7 +156,7 @@ upToTree ::
   (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError] r) =>
   Sem r Tree.InfoTable
 upToTree =
-  upToStoredCore >>= \Core.CoreResult {..} -> storedCoreToTree Core.Identity _coreResultModule
+  upToStoredCore >>= \Core.CoreResult {..} -> storedCoreToTree Core.IdentityTrans _coreResultModule
 
 upToAsm ::
   (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError] r) =>

src/Juvix/Compiler/Reg/Data/TransformationId.hs

@@ -5,7 +5,7 @@ import Juvix.Compiler.Reg.Data.TransformationId.Strings
 import Juvix.Prelude
 
 data TransformationId
-  = Identity
+  = IdentityTrans
   | Cleanup
   | SSA
   | InitBranchVars
@@ -31,7 +31,7 @@ toCasmTransformations = [Cleanup, SSA]
 instance TransformationId' TransformationId where
   transformationText :: TransformationId -> Text
   transformationText = \case
-    Identity -> strIdentity
+    IdentityTrans -> strIdentity
     Cleanup -> strCleanup
     SSA -> strSSA
     InitBranchVars -> strInitBranchVars

src/Juvix/Compiler/Reg/Transformation.hs

@@ -8,7 +8,7 @@ where
 import Juvix.Compiler.Reg.Data.TransformationId
 import Juvix.Compiler.Reg.Transformation.Base
 import Juvix.Compiler.Reg.Transformation.Cleanup
-import Juvix.Compiler.Reg.Transformation.Identity
+import Juvix.Compiler.Reg.Transformation.IdentityTrans
 import Juvix.Compiler.Reg.Transformation.InitBranchVars
 import Juvix.Compiler.Reg.Transformation.SSA
 
@@ -17,7 +17,7 @@ applyTransformations ts tbl = foldM (flip appTrans) tbl ts
   where
     appTrans :: TransformationId -> InfoTable -> Sem r InfoTable
     appTrans = \case
-      Identity -> return . identity
+      IdentityTrans -> return . identity
       Cleanup -> return . cleanup
       SSA -> return . computeSSA
       InitBranchVars -> return . initBranchVars

src/Juvix/Compiler/Reg/Transformation/IdentityTrans.hs

@@ -1,4 +1,4 @@
-module Juvix.Compiler.Reg.Transformation.Identity where
+module Juvix.Compiler.Reg.Transformation.IdentityTrans where
 
 import Juvix.Compiler.Reg.Extra.Recursors
 import Juvix.Compiler.Reg.Transformation.Base

src/Juvix/Compiler/Tree/Data/TransformationId.hs

@@ -5,7 +5,7 @@ import Juvix.Compiler.Tree.Data.TransformationId.Strings
 import Juvix.Prelude
 
 data TransformationId
-  = Identity
+  = IdentityTrans
   | IdentityU
   | IdentityD
   | Apply
@@ -35,7 +35,7 @@ toCairoAsmTransformations = [Validate, Apply, FilterUnreachable]
 instance TransformationId' TransformationId where
   transformationText :: TransformationId -> Text
   transformationText = \case
-    Identity -> strIdentity
+    IdentityTrans -> strIdentity
     IdentityU -> strIdentityU
     IdentityD -> strIdentityD
     Apply -> strApply

src/Juvix/Compiler/Tree/Transformation.hs

@@ -12,7 +12,7 @@ import Juvix.Compiler.Tree.Transformation.Apply
 import Juvix.Compiler.Tree.Transformation.Base
 import Juvix.Compiler.Tree.Transformation.CheckNoAnoma
 import Juvix.Compiler.Tree.Transformation.FilterUnreachable
-import Juvix.Compiler.Tree.Transformation.Identity
+import Juvix.Compiler.Tree.Transformation.IdentityTrans
 import Juvix.Compiler.Tree.Transformation.TempHeight
 import Juvix.Compiler.Tree.Transformation.Validate
 
@@ -21,7 +21,7 @@ applyTransformations ts tbl = foldM (flip appTrans) tbl ts
   where
     appTrans :: TransformationId -> InfoTable -> Sem r InfoTable
     appTrans = \case
-      Identity -> return . identity
+      IdentityTrans -> return . identity
       IdentityU -> return . identityU
       IdentityD -> return . identityD
       Apply -> return . computeApply

src/Juvix/Compiler/Tree/Transformation/IdentityTrans.hs

@@ -1,5 +1,5 @@
-module Juvix.Compiler.Tree.Transformation.Identity
-  ( module Juvix.Compiler.Tree.Transformation.Identity,
+module Juvix.Compiler.Tree.Transformation.IdentityTrans
+  ( module Juvix.Compiler.Tree.Transformation.IdentityTrans,
     module Juvix.Compiler.Tree.Transformation.Base,
   )
 where

src/Juvix/Prelude/Base/Foundation.hs

@@ -39,6 +39,7 @@ module Juvix.Prelude.Base.Foundation
     module Data.Text.IO,
     module Data.Text.IO.Utf8,
     module Data.Traversable,
+    module Data.Functor.Identity,
     module Data.Tuple.Extra,
     module Data.Typeable,
     module Data.Void,
@@ -95,6 +96,7 @@ import Data.Eq
 import Data.Foldable hiding (foldr1, minimum, minimumBy)
 import Data.Function
 import Data.Functor
+import Data.Functor.Identity
 import Data.Graph (Graph, SCC (..), Vertex, stronglyConnComp)
 import Data.HashMap.Lazy qualified as LazyHashMap
 import Data.HashMap.Strict (HashMap)

test/Core/Asm/Base.hs

@@ -53,8 +53,17 @@ coreAsmAssertion mainFile expectedFile step = do
       assertEqDiffText ("Check: EVAL output = " <> toFilePath expectedFile) "" expected
     Right (tabIni, Just node) -> do
       step "Translate"
-      case run $ runReader defaultCoreOptions $ runError $ toStored' >=> toStripped' Identity $ moduleFromInfoTable $ setupMainFunction defaultModuleId tabIni node of
+      case run
+        . runReader defaultCoreOptions
+        . runError
+        . (toStored' >=> toStripped' IdentityTrans)
+        . moduleFromInfoTable
+        $ setupMainFunction defaultModuleId tabIni node of
         Left err -> assertFailure (prettyString (fromJuvixError @GenericError err))
         Right m -> do
-          let tab = Asm.fromTree $ Tree.fromCore $ Stripped.fromCore (maximum allowedFieldSizes) $ computeCombinedInfoTable m
+          let tab =
+                Asm.fromTree
+                  . Tree.fromCore
+                  . Stripped.fromCore (maximum allowedFieldSizes)
+                  $ computeCombinedInfoTable m
           Asm.asmRunAssertion' tab expectedFile step

test/Core/Transformation.hs

@@ -1,7 +1,7 @@
 module Core.Transformation where
 
 import Base
-import Core.Transformation.Identity qualified as Identity
+import Core.Transformation.IdentityTrans qualified as IdentityTrans
 import Core.Transformation.Lifting qualified as Lifting
 import Core.Transformation.Pipeline qualified as Pipeline
 import Core.Transformation.TopEtaExpand qualified as TopEtaExpand
@@ -11,7 +11,7 @@ allTests :: TestTree
 allTests =
   testGroup
     "JuvixCore transformations"
-    [ Identity.allTests,
+    [ IdentityTrans.allTests,
       TopEtaExpand.allTests,
       Lifting.allTests,
       Pipeline.allTests,

test/Core/Transformation/IdentityTrans.hs

@@ -1,4 +1,4 @@
-module Core.Transformation.Identity (allTests) where
+module Core.Transformation.IdentityTrans (allTests) where
 
 import Base
 import Core.Eval.Positive qualified as Eval
@@ -9,7 +9,7 @@ allTests :: TestTree
 allTests = testGroup "Identity" (map liftTest Eval.tests)
 
 pipe :: [TransformationId]
-pipe = [Identity]
+pipe = [IdentityTrans]
 
 liftTest :: Eval.PosTest -> TestTree
 liftTest _testEval =

test/Core/Transformation/Pipeline.hs

@@ -9,7 +9,7 @@ allTests :: TestTree
 allTests = testGroup "Transformation pipeline (to Stripped)" (map liftTest Eval.compilableTests)
 
 pipe :: [TransformationId]
-pipe = toStoredTransformations ++ toStrippedTransformations Identity
+pipe = toStoredTransformations ++ toStrippedTransformations IdentityTrans
 
 liftTest :: Eval.PosTest -> TestTree
 liftTest _testEval =

test/Reg/Transformation.hs

@@ -1,7 +1,7 @@
 module Reg.Transformation where
 
 import Base
-import Reg.Transformation.Identity qualified as Identity
+import Reg.Transformation.IdentityTrans qualified as IdentityTrans
 import Reg.Transformation.InitBranchVars qualified as InitBranchVars
 import Reg.Transformation.SSA qualified as SSA
 
@@ -9,7 +9,7 @@ allTests :: TestTree
 allTests =
   testGroup
     "JuvixReg transformations"
-    [ Identity.allTests,
+    [ IdentityTrans.allTests,
       SSA.allTests,
       InitBranchVars.allTests
     ]

test/Reg/Transformation/IdentityTrans.hs

@@ -1,4 +1,4 @@
-module Reg.Transformation.Identity where
+module Reg.Transformation.IdentityTrans where
 
 import Base
 import Juvix.Compiler.Reg.Transformation
@@ -9,7 +9,7 @@ allTests :: TestTree
 allTests = testGroup "Identity" (map liftTest Parse.tests)
 
 pipe :: [TransformationId]
-pipe = [Identity]
+pipe = [IdentityTrans]
 
 liftTest :: Parse.PosTest -> TestTree
 liftTest _testRun =

test/Tree/Transformation.hs

@@ -3,14 +3,14 @@ module Tree.Transformation where
 import Base
 import Tree.Transformation.Apply qualified as Apply
 import Tree.Transformation.CheckNoAnoma qualified as CheckNoAnoma
-import Tree.Transformation.Identity qualified as Identity
+import Tree.Transformation.IdentityTrans qualified as IdentityTrans
 import Tree.Transformation.Reachability qualified as Reachability
 
 allTests :: TestTree
 allTests =
   testGroup
     "JuvixTree transformations"
-    [ Identity.allTests,
+    [ IdentityTrans.allTests,
       Apply.allTests,
       Reachability.allTests,
       CheckNoAnoma.allTests

test/Tree/Transformation/IdentityTrans.hs

@@ -1,4 +1,4 @@
-module Tree.Transformation.Identity (allTests) where
+module Tree.Transformation.IdentityTrans (allTests) where
 
 import Base
 import Juvix.Compiler.Tree.Transformation
@@ -9,7 +9,7 @@ allTests :: TestTree
 allTests = testGroup "Identity" (map liftTest Eval.tests)
 
 pipe :: [TransformationId]
-pipe = [Identity, IdentityU, IdentityD]
+pipe = [IdentityTrans, IdentityU, IdentityD]
 
 liftTest :: Eval.PosTest -> TestTree
 liftTest _testEval =