disambiguate toplevel names

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)

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)
 

src/Juvix/Compiler/Core/Language/Base.hs

@@ -39,36 +39,47 @@ 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
 
 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
 -- can treat them specially.
 data Tag
   = BuiltinTag BuiltinDataTag
   | UserTag TagUser
-  deriving stock (Eq, Generic, Ord, Show)
+  deriving stock (Eq, Generic, Ord)
 
 instance Hashable Tag
 
 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

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,14 +59,26 @@ data BuiltinDataTag
   | TagBind
   | TagWrite
   | TagReadLn
-  deriving stock (Eq, Generic, Ord, Show)
+  deriving stock (Eq, Generic, Ord)
 
 instance Hashable BuiltinDataTag
 
 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

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

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

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

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 = "+"
 

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
 --------------------------------------------------------------------------------