From 821473a8e9d62a34146de1b3cf95ef0232b6d18d Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Wed, 11 Sep 2024 13:44:33 +0200 Subject: [PATCH] disambiguate toplevel names --- src/Juvix/Compiler/Core/Data/InfoTable.hs | 12 +++++---- src/Juvix/Compiler/Core/Data/Module.hs | 3 +++ src/Juvix/Compiler/Core/Language/Base.hs | 21 +++++++++++---- src/Juvix/Compiler/Core/Language/Builtins.hs | 17 +++++++++++- .../Core/Transformation/DisambiguateNames.hs | 27 +++++++++++++++++-- src/Juvix/Compiler/Tree/Pretty/Extra.hs | 9 ++++++- .../Tree/Translation/FromSource/Base.hs | 8 +++--- src/Juvix/Extra/Strings.hs | 12 +++++++++ src/Juvix/Prelude/Base/Foundation.hs | 3 +++ 9 files changed, 94 insertions(+), 18 deletions(-) diff --git a/src/Juvix/Compiler/Core/Data/InfoTable.hs b/src/Juvix/Compiler/Core/Data/InfoTable.hs index 09e06ed11b..5830f67241 100644 --- a/src/Juvix/Compiler/Core/Data/InfoTable.hs +++ b/src/Juvix/Compiler/Core/Data/InfoTable.hs @@ -106,11 +106,13 @@ typeName' :: InfoTable -> Symbol -> Text typeName' tab sym = lookupTabInductiveInfo tab sym ^. inductiveName identNames' :: InfoTable -> HashSet Text -identNames' tab = - HashSet.fromList $ - map (^. identifierName) (HashMap.elems (tab ^. infoIdentifiers)) - ++ map (^. constructorName) (HashMap.elems (tab ^. infoConstructors)) - ++ map (^. inductiveName) (HashMap.elems (tab ^. infoInductives)) +identNames' = HashSet.fromList . identNamesList' + +identNamesList' :: InfoTable -> [Text] +identNamesList' tab = + map (^. identifierName) (HashMap.elems (tab ^. infoIdentifiers)) + ++ map (^. constructorName) (HashMap.elems (tab ^. infoConstructors)) + ++ map (^. inductiveName) (HashMap.elems (tab ^. infoInductives)) freshIdentName' :: InfoTable -> Text -> Text freshIdentName' tab = freshName (identNames' tab) diff --git a/src/Juvix/Compiler/Core/Data/Module.hs b/src/Juvix/Compiler/Core/Data/Module.hs index 9e322fc9b0..4a7502f92a 100644 --- a/src/Juvix/Compiler/Core/Data/Module.hs +++ b/src/Juvix/Compiler/Core/Data/Module.hs @@ -110,6 +110,9 @@ constrName md tag = lookupConstructorInfo md tag ^. constructorName identNames :: Module -> HashSet Text identNames m = identNames' (computeCombinedInfoTable m) +identNamesList :: Module -> [Text] +identNamesList m = identNamesList' (computeCombinedInfoTable m) + freshIdentName :: Module -> Text -> Text freshIdentName m = freshName (identNames m) diff --git a/src/Juvix/Compiler/Core/Language/Base.hs b/src/Juvix/Compiler/Core/Language/Base.hs index f48f14e6d9..941e951e3c 100644 --- a/src/Juvix/Compiler/Core/Language/Base.hs +++ b/src/Juvix/Compiler/Core/Language/Base.hs @@ -39,14 +39,11 @@ instance Show Symbol where defaultSymbol :: Word -> Symbol defaultSymbol = Symbol defaultModuleId -uniqueName :: Text -> Symbol -> Text -uniqueName txt sym = txt <> "_" <> show sym - data TagUser = TagUser { _tagUserModuleId :: ModuleId, _tagUserWord :: Word } - deriving stock (Eq, Generic, Ord, Show) + deriving stock (Eq, Generic, Ord) instance Hashable TagUser @@ -54,6 +51,12 @@ instance Serialize TagUser instance NFData TagUser +instance Pretty TagUser where + pretty TagUser {..} = pretty _tagUserWord <> "@" <> pretty _tagUserModuleId + +instance Show TagUser where + show = show . pretty + -- | Tag of a constructor, uniquely identifying it. Tag values are consecutive -- and separate from symbol IDs. We might need fixed special tags in Core for -- common "builtin" constructors, e.g., unit, nat, so that the code generator @@ -61,7 +64,7 @@ instance NFData TagUser data Tag = BuiltinTag BuiltinDataTag | UserTag TagUser - deriving stock (Eq, Generic, Ord, Show) + deriving stock (Eq, Generic, Ord) instance Hashable Tag @@ -69,6 +72,14 @@ instance Serialize Tag instance NFData Tag +instance Pretty Tag where + pretty = \case + BuiltinTag b -> pretty b + UserTag u -> pretty u + +instance Show Tag where + show = show . pretty + isBuiltinTag :: Tag -> Bool isBuiltinTag = \case BuiltinTag {} -> True diff --git a/src/Juvix/Compiler/Core/Language/Builtins.hs b/src/Juvix/Compiler/Core/Language/Builtins.hs index c6c81a1bee..c18b645042 100644 --- a/src/Juvix/Compiler/Core/Language/Builtins.hs +++ b/src/Juvix/Compiler/Core/Language/Builtins.hs @@ -1,7 +1,10 @@ module Juvix.Compiler.Core.Language.Builtins where +import GHC.Show qualified as Show import Juvix.Extra.Serialize +import Juvix.Extra.Strings qualified as Str import Juvix.Prelude +import Prettyprinter -- Builtin operations which the evaluator and the code generator treat -- specially and non-uniformly. @@ -56,7 +59,7 @@ data BuiltinDataTag | TagBind | TagWrite | TagReadLn - deriving stock (Eq, Generic, Ord, Show) + deriving stock (Eq, Generic, Ord) instance Hashable BuiltinDataTag @@ -64,6 +67,18 @@ instance Serialize BuiltinDataTag instance NFData BuiltinDataTag +instance Pretty BuiltinDataTag where + pretty = \case + TagTrue -> Str.true_ + TagFalse -> Str.false_ + TagReturn -> Str.return + TagBind -> Str.bind + TagWrite -> Str.write + TagReadLn -> Str.readLn + +instance Show BuiltinDataTag where + show = show . pretty + builtinOpArgsNum :: BuiltinOp -> Int builtinOpArgsNum = \case OpIntAdd -> 2 diff --git a/src/Juvix/Compiler/Core/Transformation/DisambiguateNames.hs b/src/Juvix/Compiler/Core/Transformation/DisambiguateNames.hs index e4e88a1304..fa94500d19 100644 --- a/src/Juvix/Compiler/Core/Transformation/DisambiguateNames.hs +++ b/src/Juvix/Compiler/Core/Transformation/DisambiguateNames.hs @@ -122,6 +122,28 @@ disambiguateNodeNames md = disambiguateNodeNames' disambiguate md names :: HashSet Text names = identNames md +disambiguateTopNames :: Module -> Module +disambiguateTopNames md = + mapInductives (\i -> over inductiveName (renameDuplicated (i ^. inductiveSymbol)) i) + . mapConstructors (\i -> over constructorName (renameDuplicated (i ^. constructorTag)) i) + . mapIdents (\i -> over identifierName (renameDuplicated (i ^. identifierSymbol)) i) + $ md + where + duplicatedNames :: HashSet Text + duplicatedNames = + HashSet.fromList + . map head + . filter (\x -> length x > 1) + . NonEmpty.group + . sort + . identNamesList + $ md + + renameDuplicated :: (Show a) => a -> Text -> Text + renameDuplicated sym name + | HashSet.member name duplicatedNames = uniqueName name sym + | otherwise = name + setArgNames :: Module -> Symbol -> Node -> Node setArgNames md sym node = reLambdas lhs' body where @@ -135,8 +157,9 @@ setArgNames md sym node = reLambdas lhs' body disambiguateNames :: Module -> Module disambiguateNames md = - let md' = mapT (setArgNames md) md - in mapAllNodes (disambiguateNodeNames md') md' + let md1 = disambiguateTopNames md + md2 = mapT (setArgNames md1) md1 + in mapAllNodes (disambiguateNodeNames md2) md2 disambiguateNames' :: InfoTable -> InfoTable disambiguateNames' = withInfoTable disambiguateNames diff --git a/src/Juvix/Compiler/Tree/Pretty/Extra.hs b/src/Juvix/Compiler/Tree/Pretty/Extra.hs index 9d2e530494..cc7902f8c9 100644 --- a/src/Juvix/Compiler/Tree/Pretty/Extra.hs +++ b/src/Juvix/Compiler/Tree/Pretty/Extra.hs @@ -24,8 +24,15 @@ quoteName txt = [ ("$", "__dollar__"), (":", "__colon__"), ("@", "__at__"), + (".", "__dot__"), + (",", "__comma__"), + (";", "__semicolon__"), ("arg", "__arg__"), - ("tmp", "__tmp__") + ("tmp", "__tmp__"), + ("sub", "__sub__"), + ("add", "__add__"), + ("mul", "__mul__"), + ("div", "__div__") ] quoteFunName :: Text -> Text diff --git a/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs b/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs index 194bf14384..424c45122e 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs +++ b/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs @@ -91,10 +91,10 @@ declareBuiltins = do sym <- lift $ freshSymbol' @t @e let tyio = mkTypeInductive sym constrs = - [ createBuiltinConstr sym TagReturn "return" (mkTypeFun [TyDynamic] tyio) i, - createBuiltinConstr sym TagBind "bind" (mkTypeFun [tyio, mkTypeFun [TyDynamic] tyio] tyio) i, - createBuiltinConstr sym TagWrite "write" (mkTypeFun [TyDynamic] tyio) i, - createBuiltinConstr sym TagReadLn "readLn" tyio i + [ createBuiltinConstr sym TagReturn (show TagReturn) (mkTypeFun [TyDynamic] tyio) i, + createBuiltinConstr sym TagBind (show TagBind) (mkTypeFun [tyio, mkTypeFun [TyDynamic] tyio] tyio) i, + createBuiltinConstr sym TagWrite (show TagWrite) (mkTypeFun [TyDynamic] tyio) i, + createBuiltinConstr sym TagReadLn (show TagReadLn) tyio i ] lift $ registerInductive' @t @e diff --git a/src/Juvix/Extra/Strings.hs b/src/Juvix/Extra/Strings.hs index f3607b646b..de933f18c1 100644 --- a/src/Juvix/Extra/Strings.hs +++ b/src/Juvix/Extra/Strings.hs @@ -608,6 +608,18 @@ false_ = "false" default_ :: (IsString s) => s default_ = "default" +return :: (IsString s) => s +return = "return" + +bind :: (IsString s) => s +bind = "bind" + +write :: (IsString s) => s +write = "write" + +readLn :: (IsString s) => s +readLn = "readLn" + plus :: (IsString s) => s plus = "+" diff --git a/src/Juvix/Prelude/Base/Foundation.hs b/src/Juvix/Prelude/Base/Foundation.hs index 8b083657f4..3b49eccdc1 100644 --- a/src/Juvix/Prelude/Base/Foundation.hs +++ b/src/Juvix/Prelude/Base/Foundation.hs @@ -286,6 +286,9 @@ toUpperFirst :: String -> String toUpperFirst [] = [] toUpperFirst (x : xs) = Char.toUpper x : xs +uniqueName :: (Show a) => Text -> a -> Text +uniqueName txt sym = txt <> "_" <> show sym + -------------------------------------------------------------------------------- -- Text --------------------------------------------------------------------------------