Optimize letFunctionDefs in Juvix.Compiler.Internal.Data.InfoTable

src/Juvix/Compiler/Internal/Data/InfoTable.hs

@@ -20,10 +20,10 @@ module Juvix.Compiler.Internal.Data.InfoTable
   )
 where
 
-import Data.Generics.Uniplate.Data
 import Data.HashMap.Strict qualified as HashMap
 import Juvix.Compiler.Internal.Extra
 import Juvix.Compiler.Internal.Extra.CoercionInfo
+import Juvix.Compiler.Internal.Extra.HasLetDefs
 import Juvix.Compiler.Internal.Extra.InstanceInfo
 import Juvix.Compiler.Internal.Pretty (ppTrace)
 import Juvix.Compiler.Store.Internal.Data.FunctionsTable
@@ -69,11 +69,11 @@ extendWithReplExpression e =
         )
     )
 
-letFunctionDefs :: (Data from) => from -> [FunctionDef]
+letFunctionDefs :: (HasLetDefs a) => a -> [FunctionDef]
 letFunctionDefs e =
   concat
     [ concatMap (toList . flattenClause) _letClauses
-      | Let {..} <- universeBi e
+      | Let {..} <- letDefs e
     ]
   where
     flattenClause :: LetClause -> NonEmpty FunctionDef

src/Juvix/Compiler/Internal/Extra/Base.hs

@@ -1,6 +1,5 @@
 module Juvix.Compiler.Internal.Extra.Base where
 
-import Data.Generics.Uniplate.Data hiding (holes)
 import Data.HashMap.Strict qualified as HashMap
 import Data.HashSet qualified as HashSet
 import Juvix.Compiler.Internal.Data.LocalVars
@@ -766,12 +765,6 @@ isSmallUniverse' = \case
   ExpressionUniverse {} -> True
   _ -> False
 
-allTypeSignatures :: (Data a) => a -> [Expression]
-allTypeSignatures a =
-  [f ^. funDefType | f@FunctionDef {} <- universeBi a]
-    <> [f ^. axiomType | f@AxiomDef {} <- universeBi a]
-    <> [f ^. inductiveType | f@InductiveDef {} <- universeBi a]
-
 explicitPatternArg :: Pattern -> PatternArg
 explicitPatternArg _patternArgPattern =
   PatternArg

src/Juvix/Compiler/Internal/Extra/HasLetDefs.hs

@@ -0,0 +1,103 @@
+module Juvix.Compiler.Internal.Extra.HasLetDefs where
+
+import Juvix.Compiler.Internal.Language
+import Juvix.Prelude
+
+class HasLetDefs a where
+  letDefs' :: [Let] -> a -> [Let]
+  letDefs :: a -> [Let]
+  letDefs = letDefs' []
+
+instance (HasLetDefs a, Foldable f) => HasLetDefs (f a) where
+  letDefs' = foldl' letDefs'
+
+instance HasLetDefs Expression where
+  letDefs' acc = \case
+    ExpressionIden {} -> acc
+    ExpressionApplication x -> letDefs' acc x
+    ExpressionFunction x -> letDefs' acc x
+    ExpressionLiteral {} -> acc
+    ExpressionHole {} -> acc
+    ExpressionInstanceHole {} -> acc
+    ExpressionLet x -> letDefs' acc x
+    ExpressionUniverse {} -> acc
+    ExpressionSimpleLambda x -> letDefs' acc x
+    ExpressionLambda x -> letDefs' acc x
+    ExpressionCase x -> letDefs' acc x
+
+instance HasLetDefs Application where
+  letDefs' acc Application {..} = letDefs' (letDefs' acc _appLeft) _appRight
+
+instance HasLetDefs Function where
+  letDefs' acc Function {..} = letDefs' (letDefs' acc _functionLeft) _functionRight
+
+instance HasLetDefs FunctionParameter where
+  letDefs' acc FunctionParameter {..} = letDefs' acc _paramType
+
+instance HasLetDefs Let where
+  letDefs' acc x@Let {..} = x : letDefs' (letDefs' acc _letExpression) _letClauses
+
+instance HasLetDefs LetClause where
+  letDefs' acc = \case
+    LetFunDef x -> letDefs' acc x
+    LetMutualBlock x -> letDefs' acc x
+
+instance HasLetDefs SimpleLambda where
+  letDefs' acc SimpleLambda {..} = letDefs' (letDefs' acc _slambdaBinder) _slambdaBody
+
+instance HasLetDefs SimpleBinder where
+  letDefs' acc SimpleBinder {..} = letDefs' acc _sbinderType
+
+instance HasLetDefs Lambda where
+  letDefs' acc Lambda {..} = letDefs' (letDefs' acc _lambdaType) _lambdaClauses
+
+instance HasLetDefs LambdaClause where
+  letDefs' acc LambdaClause {..} = letDefs' (letDefs' acc _lambdaBody) _lambdaPatterns
+
+instance HasLetDefs PatternArg where
+  letDefs' acc PatternArg {..} = letDefs' acc _patternArgPattern
+
+instance HasLetDefs Pattern where
+  letDefs' acc = \case
+    PatternVariable {} -> acc
+    PatternConstructorApp x -> letDefs' acc x
+    PatternWildcardConstructor {} -> acc
+
+instance HasLetDefs ConstructorApp where
+  letDefs' acc ConstructorApp {..} = letDefs' (letDefs' acc _constrAppType) _constrAppParameters
+
+instance HasLetDefs Case where
+  letDefs' acc Case {..} = letDefs' (letDefs' acc _caseExpression) _caseBranches
+
+instance HasLetDefs CaseBranch where
+  letDefs' acc CaseBranch {..} = letDefs' acc _caseBranchExpression
+
+instance HasLetDefs MutualBlockLet where
+  letDefs' acc MutualBlockLet {..} = letDefs' acc _mutualLet
+
+instance HasLetDefs MutualBlock where
+  letDefs' acc MutualBlock {..} = letDefs' acc _mutualStatements
+
+instance HasLetDefs MutualStatement where
+  letDefs' acc = \case
+    StatementInductive x -> letDefs' acc x
+    StatementFunction x -> letDefs' acc x
+    StatementAxiom x -> letDefs' acc x
+
+instance HasLetDefs InductiveDef where
+  letDefs' acc InductiveDef {..} = letDefs' (letDefs' (letDefs' acc _inductiveType) _inductiveConstructors) _inductiveParameters
+
+instance HasLetDefs InductiveParameter where
+  letDefs' acc InductiveParameter {..} = letDefs' acc _inductiveParamType
+
+instance HasLetDefs ConstructorDef where
+  letDefs' acc ConstructorDef {..} = letDefs' acc _inductiveConstructorType
+
+instance HasLetDefs FunctionDef where
+  letDefs' acc FunctionDef {..} = letDefs' (letDefs' (letDefs' acc _funDefType) _funDefBody) _funDefArgsInfo
+
+instance HasLetDefs ArgInfo where
+  letDefs' acc ArgInfo {..} = letDefs' acc _argInfoDefault
+
+instance HasLetDefs AxiomDef where
+  letDefs' acc AxiomDef {..} = letDefs' acc _axiomType