From 4251cd65b2002636b117d074d2e822bfe452cdb2 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Wed, 29 Jan 2025 22:04:10 +0100 Subject: [PATCH 1/5] make html links to top symbols stable --- .../Html/Translation/FromTyped/Source.hs | 46 ++++++++++++------- src/Juvix/Compiler/Concrete/Data/Name.hs | 39 ++++++++++++++++ .../Compiler/Concrete/Data/Scope/Base.hs | 6 +-- .../Compiler/Concrete/Data/ScopedName.hs | 39 ++-------------- src/Juvix/Compiler/Concrete/Print/Base.hs | 31 +++++++++---- .../FromParsed/Analysis/Scoping.hs | 34 +++++++------- .../Analysis/Scoping/Error/Types.hs | 2 +- src/Juvix/Data/CodeAnn.hs | 20 ++------ src/Juvix/Data/CodeReference.hs | 43 +++++++++++++++++ 9 files changed, 164 insertions(+), 96 deletions(-) create mode 100644 src/Juvix/Data/CodeReference.hs diff --git a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs index 18b9ef10b6..d509023fbf 100644 --- a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs +++ b/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 + attr <- case mid of + Nothing -> return mempty + Just uid -> do + idAttr <- nameIdAttr uid + return (preEscapedToValue '#' <> idAttr) + return $ prefix <> attr diff --git a/src/Juvix/Compiler/Concrete/Data/Name.hs b/src/Juvix/Compiler/Concrete/Data/Name.hs index 8b2b66d19d..4c418b2913 100644 --- a/src/Juvix/Compiler/Concrete/Data/Name.hs +++ b/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 diff --git a/src/Juvix/Compiler/Concrete/Data/Scope/Base.hs b/src/Juvix/Compiler/Concrete/Data/Scope/Base.hs index 5b5e45e227..137392ea3f 100644 --- a/src/Juvix/Compiler/Concrete/Data/Scope/Base.hs +++ b/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, diff --git a/src/Juvix/Compiler/Concrete/Data/ScopedName.hs b/src/Juvix/Compiler/Concrete/Data/ScopedName.hs index c19d0f7b4e..a63c1790ec 100644 --- a/src/Juvix/Compiler/Concrete/Data/ScopedName.hs +++ b/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, diff --git a/src/Juvix/Compiler/Concrete/Print/Base.hs b/src/Juvix/Compiler/Concrete/Print/Base.hs index 0d8bf2f0fc..e11f973fb3 100644 --- a/src/Juvix/Compiler/Concrete/Print/Base.hs +++ b/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 diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs index 2bc84d13ab..db1d83b536 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs +++ b/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)) diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs index f89d82cd03..cd5ce900df 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs +++ b/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 diff --git a/src/Juvix/Data/CodeAnn.hs b/src/Juvix/Data/CodeAnn.hs index 76a78e2ca3..f45fa518c1 100644 --- a/src/Juvix/Data/CodeAnn.hs +++ b/src/Juvix/Data/CodeAnn.hs @@ -2,15 +2,15 @@ module Juvix.Data.CodeAnn ( module Juvix.Data.CodeAnn, module Juvix.Data.NameKind, module Juvix.Prelude.Pretty, + module Juvix.Data.CodeReference, ) where import Data.Versions (prettySemVer) -import Juvix.Compiler.Concrete.Data.Name +import Juvix.Data.CodeReference import Juvix.Data.Error.GenericError import Juvix.Data.IsImplicit import Juvix.Data.Keyword -import Juvix.Data.NameId import Juvix.Data.NameKind import Juvix.Data.PackageId import Juvix.Data.WithLoc @@ -19,14 +19,6 @@ import Juvix.Prelude.Base import Juvix.Prelude.Pretty hiding (braces, brackets, group, list, parens) import Prettyprinter.Render.Terminal (Color (..), bold, colorDull) -data CodeAnnReference = CodeAnnReference - { _codeAnnReferenceModule :: TopModulePath, - _codeAnnReferenceNameId :: NameId, - _codeAnnReferenceNameKindPretty :: NameKind - } - -makeLenses ''CodeAnnReference - type Ann = CodeAnn data CodeAnn @@ -42,15 +34,11 @@ data CodeAnn | AnnLiteralString | AnnLiteralInteger | AnnUnkindedSym - | AnnDef CodeAnnReference - | AnnRef CodeAnnReference + | AnnDef CodeReference + | AnnRef CodeReference type SemanticItem = WithLoc CodeAnn -instance HasNameKind CodeAnnReference where - getNameKind = (^. codeAnnReferenceNameKindPretty) - getNameKindPretty = (^. codeAnnReferenceNameKindPretty) - instance PrettyCodeAnn PackageId where ppCodeAnn pid = annotate AnnImportant (pretty (pid ^. packageIdName)) diff --git a/src/Juvix/Data/CodeReference.hs b/src/Juvix/Data/CodeReference.hs new file mode 100644 index 0000000000..272d9e3f82 --- /dev/null +++ b/src/Juvix/Data/CodeReference.hs @@ -0,0 +1,43 @@ +module Juvix.Data.CodeReference where + +import Juvix.Compiler.Concrete.Data.Name +import Juvix.Data.NameId +import Juvix.Data.NameKind +import Juvix.Prelude.Base + +-- | `TopCodeAnnReference`s can be used in links because they are stable accross compiler versions and +-- reordering of definitions. Note that if the symbol is moved to a different local module the link will break. +data TopCodeReference = TopCodeReference + { _topCodeReferenceAbsModule :: AbsModulePath, + _topCodeReferenceVerbatimSymbol :: Text + } + +-- | `LocalCodeReference`s should not be used in links as they will most +-- likely break or point to the incorrect symbol if the order of definitions +-- change or the compiler is updated +data LocalCodeReference = LocalCodeReference + { _localCodeReferenceModule :: TopModulePath, + _localCodeReferenceNameId :: NameId + } + +data CodeReferenceLoc + = CodeReferenceLocLocal LocalCodeReference + | CodeReferenceLocTop TopCodeReference + +data CodeReference = CodeReference + { _codeReferenceLoc :: CodeReferenceLoc, + _codeReferenceNameKindPretty :: NameKind + } + +makeLenses ''CodeReference +makeLenses ''TopCodeReference +makeLenses ''LocalCodeReference + +instance HasNameKind CodeReference where + getNameKind = (^. codeReferenceNameKindPretty) + getNameKindPretty = (^. codeReferenceNameKindPretty) + +codeReferenceLocTopModule :: Lens' CodeReferenceLoc TopModulePath +codeReferenceLocTopModule f = \case + CodeReferenceLocLocal l -> CodeReferenceLocLocal <$> localCodeReferenceModule f l + CodeReferenceLocTop l -> CodeReferenceLocTop <$> (topCodeReferenceAbsModule . absTopModulePath) f l From 0bd4bf8f3274e159d9d01c429f11870ba7cdba96 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Wed, 29 Jan 2025 22:29:10 +0100 Subject: [PATCH 2/5] headers --- .../Backend/Html/Translation/FromTyped.hs | 31 +++++++++---------- .../Html/Translation/FromTyped/Source.hs | 2 +- 2 files changed, 15 insertions(+), 18 deletions(-) diff --git a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs index 7060ca09bb..37d626e221 100644 --- a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs +++ b/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,25 +610,27 @@ 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' @@ -635,13 +638,7 @@ sourceAndSelfLink tmp name = do $ "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 diff --git a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs index d509023fbf..00ea3e2311 100644 --- a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs +++ b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs @@ -404,7 +404,7 @@ nameIdAttrRef tp mid = do prefixUrl <- fromText <$> asks (^. htmlOptionsUrlPrefix) path <- fromString . toFilePath <$> moduleDocRelativePath tp noPath <- asks (^. htmlOptionsNoPath) - let prefix = prefixUrl <> if noPath then "" else path + let prefix = prefixUrl <> if noPath then mempty else path attr <- case mid of Nothing -> return mempty Just uid -> do From b8fe9a05aee3f34af2b9296dc629a7d0417001b1 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Wed, 29 Jan 2025 22:30:58 +0100 Subject: [PATCH 3/5] fix import --- app/Commands/Repl.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/Commands/Repl.hs b/app/Commands/Repl.hs index 1e84f298c8..72d69bc672 100644 --- a/app/Commands/Repl.hs +++ b/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 From eaf749d64f268cde41aaaa372e320a4cc51aa051 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Wed, 29 Jan 2025 23:58:34 +0100 Subject: [PATCH 4/5] adapt test --- tests/positive/Markdown/markdown/Test.md | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/tests/positive/Markdown/markdown/Test.md b/tests/positive/Markdown/markdown/Test.md index 5897371090..8dfbfc3091 100644 --- a/tests/positive/Markdown/markdown/Test.md +++ b/tests/positive/Markdown/markdown/Test.md @@ -5,25 +5,25 @@ What is important is seldom urgent. A Juvix Markdown file name ends with `.juvix.md`. This kind of file must contain a module declaration at the top, as shown below ---in the first code block. -
module Test;
+
module Test;
Certain blocks can be hidden from the output by adding the `hide` attribute, as shown below. -
fib : Nat → Nat → Nat → Nat
  | zero x1 _ := x1
  | (suc n) x1 x2 := fib n x2 (x1 + x2);

fibonacci (n : Nat) : Nat := fib n 0 1;
+
fib : Nat → Nat → Nat → Nat
  | zero x1 _ := x1
  | (suc n) x1 x2 := fib n x2 (x1 + x2);

fibonacci (n : Nat) : Nat := fib n 0 1;
The `extract-module-statements` attribute can be used to display only the statements contained in a module in the output. -
type T := t;
+
type T := t;
You can pass a number to the `extract-module-statements` attribute to drop that number of statements from the start of the module. -
a : T := t;
+
a : T := t;
Commands like `typecheck` and `compile` can be used with Juvix Markdown files. -
main : IO := readLn (printNatLn << fibonacci << stringToNat);
+
main : IO := readLn (printNatLn << fibonacci << stringToNat);
Other code blocks are not touched, e.g: @@ -67,8 +67,8 @@ We also use other markup for documentation such as: Initial function arguments that match variables or wildcards in all clauses can be moved to the left of the colon in the function definition. For example, - 
module move-to-left;
  import Stdlib.Data.Nat open;
  
  add (n : Nat) : Nat -> Nat
    | zero := n
    | (suc m) := suc (add n m);
end;
+ 
module move-to-left;
  import Stdlib.Data.Nat open;
  
  add (n : Nat) : Nat -> Nat
    | zero := n
    | (suc m) := suc (add n m);
end;
is equivalent to - 
module example-add;
  import Stdlib.Data.Nat open;
  
  add : Nat -> Nat -> Nat
    | n zero := n
    | n (suc m) := suc (add n m);
end;
+ 
module example-add;
  import Stdlib.Data.Nat open;
  
  add : Nat -> Nat -> Nat
    | n zero := n
    | n (suc m) := suc (add n m);
end;
From 74ceffbbf099e0b65bf27bd0ce98d06b6f8532e8 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Thu, 30 Jan 2025 09:33:10 +0100 Subject: [PATCH 5/5] fix smoke --- tests/smoke/Commands/html.smoke.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/smoke/Commands/html.smoke.yaml b/tests/smoke/Commands/html.smoke.yaml index 3c52ec55c7..f010a3fcd9 100644 --- a/tests/smoke/Commands/html.smoke.yaml +++ b/tests/smoke/Commands/html.smoke.yaml @@ -108,7 +108,7 @@ tests: - dot-all stdout: matches: | - .*href="HelloWorld.html#XYZHelloWorld:[0-9]+".* + .*href="HelloWorld.html#XYZHelloWorld".* exit-status: 0 - name: html-no-path @@ -122,7 +122,7 @@ tests: cat html/HelloWorld.html stdout: matches: | - .*href="#HelloWorld:[0-9]+".* + .*href="#HelloWorld".* stderr: matches: regex: .*