Make html links to top symbols stable

app/Commands/Repl.hs

@@ -13,9 +13,9 @@ import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Reader (mapReaderT)
 import Data.String.Interpolate (i)
 import HaskelineJB
+import Juvix.Compiler.Concrete.Data.Name (absTopModulePath)
 import Juvix.Compiler.Concrete.Data.Scope (scopePath)
 import Juvix.Compiler.Concrete.Data.Scope qualified as Scoped
-import Juvix.Compiler.Concrete.Data.ScopedName (absTopModulePath)
 import Juvix.Compiler.Concrete.Data.ScopedName qualified as Scoped
 import Juvix.Compiler.Concrete.Language qualified as Concrete
 import Juvix.Compiler.Concrete.Pretty qualified as Concrete

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

@@ -17,6 +17,7 @@ import Juvix.Compiler.Concrete.Keywords qualified as Kw
 import Juvix.Compiler.Concrete.Language
 import Juvix.Compiler.Concrete.Print
 import Juvix.Compiler.Pipeline.EntryPoint
+import Juvix.Data.CodeReference
 import Juvix.Extra.Assets
 import Juvix.Prelude hiding (Tree)
 import Juvix.Prelude.Pretty
@@ -609,39 +610,35 @@ defHeader name sig mjudoc = do
     $ funHeader'
       <> judoc'
   where
-    uid :: NameId
-    uid = name ^. S.nameId
-
-    tmp :: TopModulePath
-    tmp = name ^. S.nameDefinedIn . S.absTopModulePath
-
     judoc :: Sem r Html
     judoc = do
       judoc' <- goJudocMay mjudoc
       return (Html.div ! Attr.class_ "doc" $ judoc')
 
+    loc :: TopCodeReference
+    loc =
+      TopCodeReference
+        { _topCodeReferenceAbsModule = name ^. S.nameDefinedIn,
+          _topCodeReferenceVerbatimSymbol = name ^. S.nameVerbatim
+        }
+
     functionHeader :: Sem r Html
     functionHeader = do
-      sourceLink' <- sourceAndSelfLink tmp uid
+      sourceLink' <- sourceAndSelfLink (CodeReferenceLocTop loc)
       return $ noDefHeader (sig <> sourceLink')
 
-sourceAndSelfLink :: (Members '[Reader HtmlOptions] r) => TopModulePath -> NameId -> Sem r Html
-sourceAndSelfLink tmp name = do
-  ref' <- local (set htmlOptionsKind HtmlSrc) (nameIdAttrRef tmp (Just name))
+sourceAndSelfLink :: (Members '[Reader HtmlOptions] r) => CodeReferenceLoc -> Sem r Html
+sourceAndSelfLink loc = do
+  ref' <- local (set htmlOptionsKind HtmlSrc) (nameIdAttrRef (loc ^. codeReferenceLocTopModule) (Just loc))
+  attrId <- nameIdAttr loc
   return $
     ( a
         ! Attr.href ref'
         ! Attr.class_ "link"
         $ "Source"
     )
       <> ( a
-             ! Attr.href (selfLinkName name)
+             ! Attr.href ("#" <> attrId)
              ! Attr.class_ "selflink"
              $ "#"
          )
-
-tagIden :: (IsString c) => NameId -> c
-tagIden = fromText . prettyText
-
-selfLinkName :: (IsString c) => NameId -> c
-selfLinkName x = fromText $ "#" <> tagIden x

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) ++ [_topCodeReferenceVerbatimSymbol])
 
 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
+  let prefix = prefixUrl <> if noPath then mempty else path
+  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 [email protected]' {..} =
-  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