diff --git a/src/Juvix/Compiler/Core/Data/Module.hs b/src/Juvix/Compiler/Core/Data/Module.hs index 53f1e57f9c..9e322fc9b0 100644 --- 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 index 6b41deb01c..7bc8641c4a 100644 --- 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 index 8bd64b2607..917a92ed0d 100644 --- 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 index a6087fcc76..87deadd9c2 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs @@ -461,8 +461,8 @@ 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 @@ -470,7 +470,7 @@ goFunctionDef FunctionDef {..} = do 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 ::