make html links to top symbols stable

src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs

@@ -13,9 +13,10 @@ import Juvix.Compiler.Concrete.Language
 import Juvix.Compiler.Concrete.Print
 import Juvix.Compiler.Internal.Pretty qualified as Internal
 import Juvix.Compiler.Pipeline.Loader.PathResolver
-import Juvix.Data.CodeAnn (codeAnnReferenceModule, codeAnnReferenceNameId)
+import Juvix.Data.CodeReference
 import Juvix.Extra.Assets (writeAssets)
 import Juvix.Prelude
+import Juvix.Prelude.Pretty (prettyIsString, prettyText)
 import Prettyprinter
 import Prettyprinter.Render.Util.SimpleDocTree
 import Text.Blaze.Html
@@ -341,15 +342,16 @@ putTag ann x = case ann of
         HtmlSrc -> id
         HtmlOnly -> id
 
-    tagDef :: CodeAnnReference -> Sem r Html
+    tagDef :: CodeReference -> Sem r Html
     tagDef ref = do
       ref' <- tagRef ref
-      attrId <- nameIdAttr (ref ^. codeAnnReferenceNameId)
+      attrId <- nameIdAttr (ref ^. codeReferenceLoc)
       return $ (Html.span ! Attr.id attrId) ref'
 
-    tagRef :: CodeAnnReference -> Sem r Html
+    tagRef :: CodeReference -> Sem r Html
     tagRef ref = do
-      pth <- nameIdAttrRef (ref ^. codeAnnReferenceModule) (Just (ref ^. codeAnnReferenceNameId))
+      let loc = ref ^. codeReferenceLoc
+      pth <- nameIdAttrRef (loc ^. codeReferenceLocTopModule) (Just loc)
       return
         . (Html.span ! Attr.class_ "annot")
         . ( a
@@ -363,10 +365,20 @@ putTag ann x = case ann of
       Html.span
         ! juClass (juKindColor k)
 
-nameIdAttr :: (Members '[Reader HtmlOptions] r) => S.NameId -> Sem r AttributeValue
+nameIdAttr :: (Members '[Reader HtmlOptions] r) => CodeReferenceLoc -> Sem r AttributeValue
 nameIdAttr nid = do
-  pfx <- unpack <$> asks (^. htmlOptionsIdPrefix)
-  return $ fromString $ pfx <> show (pretty nid)
+  pfx <- fromText <$> asks (^. htmlOptionsIdPrefix)
+  return (pfx <> uid)
+  where
+    uid :: AttributeValue
+    uid = case nid of
+      CodeReferenceLocLocal l -> prettyIsString (l ^. localCodeReferenceNameId)
+      CodeReferenceLocTop t -> fromText (dottedTopCodeReference t)
+
+    --  If the path is Top.Local-1.Local-2.sym it returns Local-1.Local-2.sym. Note
+    -- that the top module is ignored.
+    dottedTopCodeReference :: TopCodeReference -> Text
+    dottedTopCodeReference TopCodeReference {..} = Text.intercalate "." (map prettyText (_topCodeReferenceAbsModule ^. absLocalPath) ++ [prettyText _topCodeReferenceAbsSymbol])
 
 moduleDocRelativePath :: (Members '[Reader HtmlOptions] r) => TopModulePath -> Sem r (Path Rel File)
 moduleDocRelativePath m = do
@@ -387,15 +399,15 @@ moduleDocRelativePath m = do
               relpath
               (stripProperPrefix (fromJust (parseRelDir fixPrefix)) relpath)
 
-nameIdAttrRef :: (Members '[Reader HtmlOptions] r) => TopModulePath -> Maybe S.NameId -> Sem r AttributeValue
+nameIdAttrRef :: (Members '[Reader HtmlOptions] r) => TopModulePath -> Maybe CodeReferenceLoc -> Sem r AttributeValue
 nameIdAttrRef tp mid = do
-  prefixUrl <- unpack <$> asks (^. htmlOptionsUrlPrefix)
-  path <- toFilePath <$> moduleDocRelativePath tp
+  prefixUrl <- fromText <$> asks (^. htmlOptionsUrlPrefix)
+  path <- fromString . toFilePath <$> moduleDocRelativePath tp
   noPath <- asks (^. htmlOptionsNoPath)
   let prefix = prefixUrl <> if noPath then "" else path
-  attr <-
-    maybe
-      (return mempty)
-      (((preEscapedToValue '#' <>) <$>) . nameIdAttr)
-      mid
-  return $ fromString prefix <> attr
+  attr <- case mid of
+    Nothing -> return mempty
+    Just uid -> do
+      idAttr <- nameIdAttr uid
+      return (preEscapedToValue '#' <> idAttr)
+  return $ prefix <> attr

src/Juvix/Compiler/Concrete/Data/Name.hs

@@ -94,8 +94,47 @@ instance NFData TopModulePath
 
 instance Hashable TopModulePath
 
+data AbsModulePath = AbsModulePath
+  { _absTopModulePath :: TopModulePath,
+    -- | List of local module names
+    _absLocalPath :: [Symbol]
+  }
+  deriving stock (Show, Eq, Generic)
+
+instance Serialize AbsModulePath
+
+instance NFData AbsModulePath
+
 makeLenses ''TopModulePath
 
+makeLenses ''AbsModulePath
+
+instance HasLoc AbsModulePath where
+  getLoc a = getLoc (a ^. absTopModulePath)
+
+topModulePathToAbsPath :: TopModulePath -> AbsModulePath
+topModulePathToAbsPath p =
+  AbsModulePath
+    { _absTopModulePath = p,
+      _absLocalPath = []
+    }
+
+instance Hashable AbsModulePath
+
+-- | Tells whether the first argument is an immediate child of the second argument.
+-- In other words, tells whether the first argument is a local module of the second.
+isChildOf :: AbsModulePath -> AbsModulePath -> Bool
+isChildOf child parentMod
+  | null (child ^. absLocalPath) = False
+  | otherwise =
+      init (child ^. absLocalPath) == parentMod ^. absLocalPath
+        && child ^. absTopModulePath == parentMod ^. absTopModulePath
+
+-- | Appends a local path to the absolute path
+-- e.g. TopMod.Local <.> Inner == TopMod.Local.Inner
+appendModulePath :: AbsModulePath -> Symbol -> AbsModulePath
+appendModulePath absP localMod = absP {_absLocalPath = absP ^. absLocalPath ++ [localMod]}
+
 topModulePathKey :: TopModulePath -> TopModulePathKey
 topModulePathKey TopModulePath {..} =
   TopModulePathKey

src/Juvix/Compiler/Concrete/Data/Scope/Base.hs

@@ -11,7 +11,7 @@ newtype SymbolInfo (n :: NameSpace) = SymbolInfo
   { -- | This map must have at least one entry. If there are more than one
     -- entry, it means that the same symbol has been brought into scope from two
     -- different places
-    _symbolInfo :: HashMap S.AbsModulePath (NameSpaceEntryType n)
+    _symbolInfo :: HashMap AbsModulePath (NameSpaceEntryType n)
   }
 
 instance (SingI n) => Semigroup (SymbolInfo n) where
@@ -45,7 +45,7 @@ data Reserved = Reserved
   }
 
 data Scope = Scope
-  { _scopePath :: S.AbsModulePath,
+  { _scopePath :: AbsModulePath,
     _scopeFixities :: HashMap NameId Fixity,
     _scopeIterators :: HashMap NameId IteratorInfo,
     _scopeInScope :: InScope,
@@ -150,7 +150,7 @@ emptyInScope =
       _inScopeFixitySymbols = mempty
     }
 
-emptyScopeTop :: NameId -> S.AbsModulePath -> Scope
+emptyScopeTop :: NameId -> AbsModulePath -> Scope
 emptyScopeTop modId absPath =
   Scope
     { _scopePath = absPath,

src/Juvix/Compiler/Concrete/Data/ScopedName.hs

@@ -17,40 +17,6 @@ import Juvix.Extra.Serialize
 import Juvix.Prelude
 import Juvix.Prelude.Pretty
 
-data AbsModulePath = AbsModulePath
-  { _absTopModulePath :: C.TopModulePath,
-    _absLocalPath :: [C.Symbol]
-  }
-  deriving stock (Show, Eq, Generic)
-
-instance Serialize AbsModulePath
-
-instance NFData AbsModulePath
-
-makeLenses ''AbsModulePath
-
-instance HasLoc AbsModulePath where
-  getLoc a = getLoc (a ^. absTopModulePath)
-
-topModulePathToAbsPath :: C.TopModulePath -> AbsModulePath
-topModulePathToAbsPath p = AbsModulePath p []
-
-instance Hashable AbsModulePath
-
--- | Tells whether the first argument is an immediate child of the second argument.
--- In other words, tells whether the first argument is a local module of the second.
-isChildOf :: AbsModulePath -> AbsModulePath -> Bool
-isChildOf child parentMod
-  | null (child ^. absLocalPath) = False
-  | otherwise =
-      init (child ^. absLocalPath) == parentMod ^. absLocalPath
-        && child ^. absTopModulePath == parentMod ^. absTopModulePath
-
--- | Appends a local path to the absolute path
--- e.g. TopMod.Local <.> Inner == TopMod.Local.Inner
-(<.>) :: AbsModulePath -> C.Symbol -> AbsModulePath
-absP <.> localMod = absP {_absLocalPath = absP ^. absLocalPath ++ [localMod]}
-
 -- | Why a symbol is in scope.
 data WhyInScope
   = -- | Inherited from the parent module.
@@ -79,7 +45,10 @@ data Name' n = Name'
     -- | Used to display sensitive colors for builtins. It the name is not a
     -- builtin, then _nameKind == _nameKindPretty
     _nameKindPretty :: NameKind,
-    _nameDefinedIn :: AbsModulePath,
+    -- | True when the name is defined in a top definition (including top
+    -- definitions in local modules).
+    _nameTop :: Bool,
+    _nameDefinedIn :: C.AbsModulePath,
     _nameFixity :: Maybe C.Fixity,
     _nameIterator :: Maybe IteratorInfo,
     _nameWhyInScope :: WhyInScope,

src/Juvix/Compiler/Concrete/Print/Base.hs

@@ -23,8 +23,9 @@ import Juvix.Compiler.Pipeline.Loader.PathResolver.PackageInfo
 import Juvix.Compiler.Store.Scoped.Language
 import Juvix.Data.Ape.Base
 import Juvix.Data.Ape.Print
-import Juvix.Data.CodeAnn (Ann, CodeAnn (..), CodeAnnReference (..), ppCodeAnn, ppStringLit)
+import Juvix.Data.CodeAnn (Ann, CodeAnn (..), ppCodeAnn, ppStringLit)
 import Juvix.Data.CodeAnn qualified as C
+import Juvix.Data.CodeReference
 import Juvix.Data.Effect.ExactPrint
 import Juvix.Data.Keyword.All qualified as Kw
 import Juvix.Data.NameKind
@@ -173,8 +174,8 @@ ppAnyStage (s :&: p) = case s of
   SParsed -> ppCode p
   SScoped -> ppCode p
 
-instance PrettyPrint S.AbsModulePath where
-  ppCode S.AbsModulePath {..} = do
+instance PrettyPrint AbsModulePath where
+  ppCode AbsModulePath {..} = do
     let absLocalPath' = ppCode <$> _absLocalPath
         absTopModulePath' = ppCode _absTopModulePath
     dotted (absTopModulePath' : absLocalPath')
@@ -766,13 +767,27 @@ annDef nm = case sing :: SStage s of
   SScoped -> annSDef nm
   SParsed -> id
 
-nameReference :: S.Name' n -> CodeAnnReference
+nameReference :: S.Name' n -> CodeReference
 nameReference n@S.Name' {..} =
-  CodeAnnReference
-    { _codeAnnReferenceNameId = _nameId,
-      _codeAnnReferenceModule = _nameDefinedIn ^. S.absTopModulePath,
-      _codeAnnReferenceNameKindPretty = getNameKindPretty n
+  CodeReference
+    { _codeReferenceNameKindPretty = getNameKindPretty n,
+      _codeReferenceLoc = loc
     }
+  where
+    loc :: CodeReferenceLoc
+    loc
+      | _nameTop =
+          CodeReferenceLocTop
+            TopCodeReference
+              { _topCodeReferenceAbsModule = _nameDefinedIn,
+                _topCodeReferenceVerbatimSymbol = _nameVerbatim
+              }
+      | otherwise =
+          CodeReferenceLocLocal
+            LocalCodeReference
+              { _localCodeReferenceModule = _nameDefinedIn ^. absTopModulePath,
+                _localCodeReferenceNameId = _nameId
+              }
 
 annSDef :: (Members '[ExactPrint] r) => S.Name' n -> Sem r () -> Sem r ()
 annSDef = annotated . AnnDef . nameReference

src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs

@@ -165,16 +165,17 @@ scopeCheckOpenModule ::
 scopeCheckOpenModule = mapError (JuvixError @ScoperError) . checkOpenModule
 
 freshVariable :: (Members '[NameIdGen, State Scope, State ScoperState] r) => Symbol -> Sem r S.Symbol
-freshVariable = freshSymbol KNameLocal KNameLocal
+freshVariable = freshSymbol KNameLocal KNameLocal False
 
 freshSymbol ::
   forall r.
   (Members '[State Scope, State ScoperState, NameIdGen] r) =>
   NameKind ->
   NameKind ->
+  Bool ->
   Symbol ->
   Sem r S.Symbol
-freshSymbol _nameKind _nameKindPretty _nameConcrete = do
+freshSymbol _nameKind _nameKindPretty _nameTop _nameConcrete = do
   _nameId <- freshNameId
   _nameDefinedIn <- gets (^. scopePath)
   let _nameDefined = getLoc _nameConcrete
@@ -269,13 +270,13 @@ reserveSymbolOfNameSpace ::
 reserveSymbolOfNameSpace ns kind kindPretty nameSig builtin s = do
   checkNotBound
   strat <- ask
-  s' <- freshSymbol kind kindPretty s
-  whenJust builtin (`registerBuiltin` s')
-  whenJust nameSig (modify' . set (scoperNameSignatures . at (s' ^. S.nameId)) . Just)
-  whenJust nameSig (registerParsedNameSig (s' ^. S.nameId))
   let isTop = case strat of
         BindingLocal -> False
         BindingTop -> True
+  s' <- freshSymbol kind kindPretty isTop s
+  whenJust builtin (`registerBuiltin` s')
+  whenJust nameSig (modify' . set (scoperNameSignatures . at (s' ^. S.nameId)) . Just)
+  whenJust nameSig (registerParsedNameSig (s' ^. S.nameId))
   registerName isTop s'
   modify (set (scopeReservedNameSpace sns . at s) (Just s'))
   addToScope ns kind s s'
@@ -782,11 +783,11 @@ checkImportNoPublic import_@Import {..} = do
       modify (set (scoperExportInfo . at (m ^. scopedModulePath . S.nameId)) (Just (scopedModuleToModuleExportInfo m)))
       forM_ (m ^. scopedModuleLocalModules) registerScoperModules
 
-getTopModulePath :: Module 'Parsed 'ModuleTop -> S.AbsModulePath
+getTopModulePath :: Module 'Parsed 'ModuleTop -> AbsModulePath
 getTopModulePath Module {..} =
-  S.AbsModulePath
-    { S._absTopModulePath = _modulePath,
-      S._absLocalPath = mempty
+  AbsModulePath
+    { _absTopModulePath = _modulePath,
+      _absLocalPath = mempty
     }
 
 getModuleExportInfo :: forall r. (HasCallStack, Members '[State ScoperState] r) => ModuleSymbolEntry -> Sem r ModuleExportInfo
@@ -862,9 +863,9 @@ lookupSymbolAux modules final = do
     hereOrInLocalModule :: Sem r ()
     hereOrInLocalModule = do
       path0 <- gets (^. scopePath)
-      let topPath = path0 ^. S.absTopModulePath
+      let topPath = path0 ^. absTopModulePath
           path1 = topPath ^. modulePathDir ++ [topPath ^. modulePathName]
-          path2 = path0 ^. S.absLocalPath
+          path2 = path0 ^. absLocalPath
           pref = commonPrefix path2 modules
       when (path1 `isPrefixOf` modules) $ do
         let modules' = drop (length path1) modules
@@ -1056,7 +1057,7 @@ genExportInfo = do
     mkentry ::
       forall ns.
       (SingI ns) =>
-      S.AbsModulePath ->
+      AbsModulePath ->
       (Symbol, SymbolInfo ns) ->
       Sem r (Maybe (Symbol, NameSpaceEntryType ns))
     mkentry _scopePath (s, SymbolInfo {..}) =
@@ -1406,7 +1407,7 @@ checkFunctionDef fdef@FunctionDef {..} = do
             _functionDefNamePattern = Nothing
           }
     FunctionDefNamePattern p -> do
-      name' <- freshSymbol KNameFunction KNameFunction (WithLoc (getLoc p) "__pattern__")
+      name' <- freshSymbol KNameFunction KNameFunction False (WithLoc (getLoc p) "__pattern__")
       p' <- runReader PatternNamesKindFunctions (checkParsePatternAtom p)
       return
         FunctionDefNameScoped
@@ -1648,7 +1649,7 @@ checkTopModule m@Module {..} = checkedModule
       Sem s S.TopModulePath
     freshTopModulePath = do
       _nameId <- freshNameId
-      let _nameDefinedIn = S.topModulePathToAbsPath _modulePath
+      let _nameDefinedIn = topModulePathToAbsPath _modulePath
           _nameConcrete = _modulePath
           _nameDefined = getLoc (_modulePath ^. modulePathName)
           _nameKind = KNameTopModule
@@ -1661,6 +1662,7 @@ checkTopModule m@Module {..} = checkedModule
           _nameVerbatim = N.topModulePathToDottedPath _modulePath
           _nameIterator :: Maybe IteratorInfo
           _nameIterator = Nothing
+          _nameTop = True
           moduleName = S.Name' {..}
       registerName True moduleName
       return moduleName
@@ -2042,7 +2044,7 @@ reserveLocalModule Module {..} = do
 
 inheritScope :: (Members '[State Scope] r') => Symbol -> Sem r' ()
 inheritScope _modulePath = do
-  absPath <- (S.<.> _modulePath) <$> gets (^. scopePath)
+  absPath <- (`appendModulePath` _modulePath) <$> gets (^. scopePath)
   modify (set scopePath absPath)
   modify (over scopeSymbols (fmap inheritSymbol))
   modify (over scopeModuleSymbols (fmap inheritSymbol))

src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs

@@ -215,7 +215,7 @@ data ExportEntries
   deriving stock (Show)
 
 data MultipleExportConflict = MultipleExportConflict
-  { _multipleExportModule :: S.AbsModulePath,
+  { _multipleExportModule :: AbsModulePath,
     _multipleExportSymbol :: Symbol,
     _multipleExportNameSpace :: NameSpace,
     _multipleExportEntries :: ExportEntries