Fix names in Core (#2843)

* Closes #2733
anoma · Jun 19, 2024 · 33d5650 · 33d5650
1 parent 235d88f
commit 33d5650
Show file tree

Hide file tree

Showing 4 changed files with 30 additions and 9 deletions.
diff --git a/src/Juvix/Compiler/Core/Data/Module.hs b/src/Juvix/Compiler/Core/Data/Module.hs
@@ -99,10 +99,13 @@ getInfoMain Module {..} =
     <|> _moduleImportsTable ^. infoMain
 
 identName :: Module -> Symbol -> Text
-identName m = identName' (computeCombinedInfoTable m)
+identName md sym = lookupIdentifierInfo md sym ^. identifierName
 
 typeName :: Module -> Symbol -> Text
-typeName m = typeName' (computeCombinedInfoTable m)
+typeName md sym = lookupInductiveInfo md sym ^. inductiveName
+
+constrName :: Module -> Tag -> Text
+constrName md tag = lookupConstructorInfo md tag ^. constructorName
 
 identNames :: Module -> HashSet Text
 identNames m = identNames' (computeCombinedInfoTable m)

diff --git a/src/Juvix/Compiler/Core/Transformation/DisambiguateNames.hs b/src/Juvix/Compiler/Core/Transformation/DisambiguateNames.hs
@@ -16,6 +16,8 @@ disambiguateNodeNames' disambiguate md = dmapL go
         mkVar (setInfoName (BL.lookup _varIndex bl ^. binderName) _varInfo) _varIndex
       NIdt Ident {..} ->
         mkIdent (setInfoName (identName md _identSymbol) _identInfo) _identSymbol
+      NCtr Constr {..} ->
+        mkConstr (setInfoName (constrName md _constrTag) _constrInfo) _constrTag _constrArgs
       NLam lam ->
         NLam (over lambdaBinder (over binderName (disambiguate bl)) lam)
       NLet lt ->
@@ -35,7 +37,18 @@ disambiguateNodeNames' disambiguate md = dmapL go
         where
           vs = toList (lt ^. letRecValues)
       NCase c ->
-        NCase (over caseBranches (map (over caseBranchBinders (disambiguateBinders bl))) c)
+        NCase
+          ( over
+              caseBranches
+              ( map
+                  ( \br ->
+                      over caseBranchInfo (setInfoName (constrName md (br ^. caseBranchTag)))
+                        . over caseBranchBinders (disambiguateBinders bl)
+                        $ br
+                  )
+              )
+              c
+          )
       NMatch m ->
         NMatch (over matchBranches (map (over matchBranchPatterns (NonEmpty.fromList . snd . disambiguatePatterns bl . toList))) m)
       NTyp TypeConstr {..} ->
@@ -64,7 +77,12 @@ disambiguateNodeNames' disambiguate md = dmapL go
           where
             b' = over binderName (disambiguate bl) (c ^. patternConstrBinder)
             (bl', args') = disambiguatePatterns (BL.cons b' bl) (c ^. patternConstrArgs)
-            pat' = PatConstr $ set patternConstrBinder b' $ set patternConstrArgs args' c
+            pat' =
+              PatConstr
+                . set patternConstrBinder b'
+                . set patternConstrArgs args'
+                . over patternConstrInfo (setInfoName (constrName md (c ^. patternConstrTag)))
+                $ c
 
 disambiguateNodeNames :: Module -> Node -> Node
 disambiguateNodeNames md = disambiguateNodeNames' disambiguate md

diff --git a/src/Juvix/Compiler/Internal/Data/Name.hs b/src/Juvix/Compiler/Internal/Data/Name.hs
@@ -43,12 +43,12 @@ varFromHole h =
       _nameFixity = Nothing
     }
   where
-    pp = "_ω" <> prettyText (h ^. holeId)
+    pp :: Text = "_ω"
 
 varFromWildcard :: (Members '[NameIdGen] r) => Wildcard -> Sem r VarName
 varFromWildcard w = do
   _nameId <- freshNameId
-  let _nameText :: Text = "_ω" <> prettyText _nameId
+  let _nameText :: Text = "_ω"
       _nameKind = KNameLocal
       _nameKindPretty = KNameLocal
       _namePretty = _nameText

diff --git a/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs b/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs
@@ -461,16 +461,16 @@ goFunctionDef FunctionDef {..} = do
     argToPattern arg@SigArg {..} = do
       let _patternArgIsImplicit = _sigArgImplicit
           _patternArgName :: Maybe Internal.Name = Nothing
-          noName = goWidlcard (Wildcard (getLoc arg))
-          goWidlcard w = do
+          noName = goWildcard (Wildcard (getLoc arg))
+          goWildcard w = do
             _patternArgPattern <- Internal.PatternVariable <$> varFromWildcard w
             return Internal.PatternArg {..}
           mk :: Concrete.Argument 'Scoped -> Sem r Internal.PatternArg
           mk = \case
             Concrete.ArgumentSymbol s ->
               let _patternArgPattern = Internal.PatternVariable (goSymbol s)
                in return Internal.PatternArg {..}
-            Concrete.ArgumentWildcard w -> goWidlcard w
+            Concrete.ArgumentWildcard w -> goWildcard w
       maybe (pure <$> noName) (mapM mk) (nonEmpty _sigArgNames)
 
 goInductiveParameters ::