Print comments when pretty printing concrete syntax (#1737)

Makefile

@@ -238,11 +238,15 @@ fast-test-skip-slow:
 
 SMOKE := $(shell command -v smoke 2> /dev/null)
 
-.PHONY : smoke
-smoke: install submodules
+.PHONY : smoke-only
+smoke-only:
 	@$(if $(SMOKE),, $(error "Smoke not found, please install it from https://github.com/SamirTalwar/smoke"))
 	@smoke $(shell find tests -name '*.smoke.yaml')
 
+.PHONY : smoke
+smoke: install submodules
+	@${MAKE} smoke-only
+
 # -- Release
 
 .PHONY : changelog-updates

app/Commands/Dev/Scope.hs

@@ -2,14 +2,28 @@ module Commands.Dev.Scope where
 
 import Commands.Base
 import Commands.Dev.Scope.Options
+import Juvix.Compiler.Concrete.Language
 import Juvix.Compiler.Concrete.Pretty qualified as Scoper
+import Juvix.Compiler.Concrete.Print qualified as Print
 import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping qualified as Scoper
+import Juvix.Data.Comment
+import Juvix.Prelude.Pretty
 
 runCommand :: (Members '[Embed IO, App] r) => ScopeOptions -> Sem r ()
 runCommand opts = do
   globalOpts <- askGlobalOptions
-  l <-
-    (^. Scoper.resultModules)
-      <$> runPipeline (opts ^. scopeInputFile) upToScoping
-  forM_ l $ \s -> do
-    renderStdOut (Scoper.ppOut (globalOpts, opts) s)
+  res :: Scoper.ScoperResult <- runPipeline (opts ^. scopeInputFile) upToScoping
+  let modules :: NonEmpty (Module 'Scoped 'ModuleTop) = res ^. Scoper.resultModules
+  forM_ modules $ \s ->
+    if
+        | opts ^. scopeWithComments ->
+            renderStdOut (Print.ppOut (globalOpts, opts) (res ^. Scoper.comments) s)
+        | otherwise ->
+            renderStdOut (Scoper.ppOut (globalOpts, opts) s)
+  when (opts ^. scopeListComments) $ do
+    let mainFile :: Path Abs File = getLoc (res ^. Scoper.mainModule) ^. intervalFile
+    newline
+    newline
+    say "Comments:"
+    forM_ (fileComments mainFile (res ^. Scoper.comments) ^. fileCommentsSorted) $ \c ->
+      say (prettyText (c ^. commentInterval) <> " " <> prettyText c)

app/Commands/Dev/Scope/Options.hs

@@ -5,27 +5,32 @@ import GlobalOptions
 import Juvix.Compiler.Concrete.Pretty qualified as Scoper
 
 data ScopeOptions = ScopeOptions
-  { _scopeInlineImports :: Bool,
-    _scopeInputFile :: AppPath File
+  { _scopeInputFile :: AppPath File,
+    _scopeWithComments :: Bool,
+    _scopeListComments :: Bool
   }
   deriving stock (Data)
 
 makeLenses ''ScopeOptions
 
 parseScope :: Parser ScopeOptions
 parseScope = do
-  _scopeInlineImports <-
+  _scopeWithComments <-
     switch
-      ( long "inline-imports"
-          <> help "Show the code of imported modules next to the import statement"
+      ( long "with-comments"
+          <> help "Include user comments when printing code"
+      )
+  _scopeListComments <-
+    switch
+      ( long "list-comments"
+          <> help "List the user comments"
       )
   _scopeInputFile <- parseInputJuvixFile
   pure ScopeOptions {..}
 
 instance CanonicalProjection (GlobalOptions, ScopeOptions) Scoper.Options where
-  project (g, ScopeOptions {..}) =
+  project (g, _) =
     Scoper.defaultOptions
       { Scoper._optShowNameIds = g ^. globalShowNameIds,
-        Scoper._optInlineImports = _scopeInlineImports,
         Scoper._optNoApe = g ^. globalNoApe
       }

app/Commands/Repl.hs

@@ -317,11 +317,15 @@ replMakeAbsolute = \case
     invokeDir <- State.gets (^. replStateInvokeDir)
     return (invokeDir <//> r)
 
+-- | imaginary file path for error messages in the repl.
+replPath :: Path Abs File
+replPath = $(mkAbsFile "/<repl>")
+
 inferExpressionIO' :: ReplContext -> Text -> IO (Either JuvixError Internal.Expression)
-inferExpressionIO' ctx = inferExpressionIO "" (ctx ^. replContextExpContext) (ctx ^. replContextBuiltins)
+inferExpressionIO' ctx = inferExpressionIO replPath (ctx ^. replContextExpContext) (ctx ^. replContextBuiltins)
 
 compileExpressionIO' :: ReplContext -> Text -> IO (Either JuvixError Core.Node)
-compileExpressionIO' ctx = compileExpressionIO "" (ctx ^. replContextExpContext) (ctx ^. replContextBuiltins)
+compileExpressionIO' ctx = compileExpressionIO replPath (ctx ^. replContextExpContext) (ctx ^. replContextBuiltins)
 
 render' :: (P.HasAnsiBackend a, P.HasTextBackend a) => a -> Repl ()
 render' t = do

src/Juvix/Compiler/Abstract/Translation/FromConcrete.hs

@@ -147,7 +147,7 @@ goStatement ::
 goStatement (Indexed idx s) =
   fmap (Indexed idx) <$> case s of
     StatementAxiom d -> Just . Abstract.StatementAxiom <$> goAxiom d
-    StatementImport (Import t) -> Just . Abstract.StatementImport <$> goModule t
+    StatementImport t -> Just . Abstract.StatementImport <$> goModule (t ^. importModule . moduleRefModule)
     StatementOperator {} -> return Nothing
     StatementOpenModule o -> goOpenModule o
     StatementInductive i -> Just . Abstract.StatementInductive <$> goInductive i
@@ -163,7 +163,7 @@ goOpenModule ::
   OpenModule 'Scoped ->
   Sem r (Maybe Abstract.Statement)
 goOpenModule o
-  | o ^. openModuleImport =
+  | isJust (o ^. openModuleImportKw) =
       case o ^. openModuleName of
         ModuleRef' (SModuleTop :&: m) ->
           Just . Abstract.StatementImport
@@ -179,13 +179,13 @@ goFunctionDef ::
   Sem r Abstract.FunctionDef
 goFunctionDef TypeSignature {..} clauses = do
   let _funDefName = goSymbol _sigName
-      _funDefTerminating = _sigTerminating
-      _funDefBuiltin = _sigBuiltin
+      _funDefTerminating = isJust _sigTerminating
+      _funDefBuiltin = (^. withLocParam) <$> _sigBuiltin
   _funDefClauses <- mapM goFunctionClause clauses
   _funDefTypeSig <- goExpression _sigType
   _funDefExamples <- goExamples _sigDoc
   let fun = Abstract.FunctionDef {..}
-  whenJust _sigBuiltin (registerBuiltinFunction fun)
+  whenJust _sigBuiltin (registerBuiltinFunction fun . (^. withLocParam))
   registerFunction' fun
 
 goExamples ::
@@ -284,14 +284,14 @@ goInductive ty@InductiveDef {..} = do
       indDef =
         Abstract.InductiveDef
           { _inductiveParameters = _inductiveParameters',
-            _inductiveBuiltin = _inductiveBuiltin,
+            _inductiveBuiltin = (^. withLocParam) <$> _inductiveBuiltin,
             _inductiveName = goSymbol _inductiveName,
             _inductiveType = fromMaybe (Abstract.ExpressionUniverse (smallUniverse loc)) _inductiveType',
             _inductiveConstructors = toList _inductiveConstructors',
             _inductiveExamples = _inductiveExamples',
             _inductivePositive = ty ^. inductivePositive
           }
-  whenJust _inductiveBuiltin (registerBuiltinInductive indDef)
+  whenJust ((^. withLocParam) <$> _inductiveBuiltin) (registerBuiltinInductive indDef)
   inductiveInfo <- registerInductive indDef
   forM_ _inductiveConstructors' (registerConstructor inductiveInfo)
   return (inductiveInfo ^. inductiveInfoDef)
@@ -351,8 +351,8 @@ goExpression = \case
             goSig sig = do
               _funDefClauses <- getClauses
               _funDefTypeSig <- goExpression (sig ^. sigType)
-              let _funDefBuiltin = sig ^. sigBuiltin
-                  _funDefTerminating = sig ^. sigTerminating
+              let _funDefBuiltin = (^. withLocParam) <$> sig ^. sigBuiltin
+                  _funDefTerminating = isJust (sig ^. sigTerminating)
                   _funDefName = goSymbol (sig ^. sigName)
                   _funDefExamples :: [Abstract.Example] = []
               registerFunction' Abstract.FunctionDef {..}
@@ -394,8 +394,8 @@ goExpression = \case
       r' <- goExpression r
       return (Abstract.Application l'' r' Explicit)
 
-goLambda :: forall r. (Members '[Error ScoperError, InfoTableBuilder] r) => Lambda 'Scoped -> Sem r Abstract.Lambda
-goLambda (Lambda cl) = Abstract.Lambda <$> mapM goClause cl
+goLambda :: forall r. Members '[Error ScoperError, InfoTableBuilder] r => Lambda 'Scoped -> Sem r Abstract.Lambda
+goLambda l = Abstract.Lambda <$> mapM goClause (l ^. lambdaClauses)
   where
     goClause :: LambdaClause 'Scoped -> Sem r Abstract.LambdaClause
     goClause (LambdaClause ps b) = do
@@ -508,8 +508,8 @@ goAxiom a = do
   let axiom =
         Abstract.AxiomDef
           { _axiomType = _axiomType',
-            _axiomBuiltin = a ^. axiomBuiltin,
+            _axiomBuiltin = (^. withLocParam) <$> a ^. axiomBuiltin,
             _axiomName = goSymbol (a ^. axiomName)
           }
-  whenJust (a ^. axiomBuiltin) (registerBuiltinAxiom axiom)
+  whenJust (a ^. axiomBuiltin) (registerBuiltinAxiom axiom . (^. withLocParam))
   registerAxiom' axiom

src/Juvix/Compiler/Asm/Translation/FromSource/Lexer.hs

@@ -12,7 +12,7 @@ import Text.Megaparsec as P hiding (sepBy1, sepEndBy1, some)
 import Text.Megaparsec.Char.Lexer qualified as L
 
 space :: ParsecS r ()
-space = space' False void
+space = void (space' False)
 
 lexeme :: ParsecS r a -> ParsecS r a
 lexeme = L.lexeme space

src/Juvix/Compiler/Backend/C/Translation/FromInternal.hs

@@ -487,7 +487,7 @@ goAxiom a
     defineName = mkName axiomName
     getCode :: BackendItem -> Maybe Text
     getCode b =
-      guard (BackendC == b ^. backendItemBackend)
+      guard (BackendC == b ^. backendItemBackend . withLocParam)
         $> b
           ^. backendItemCode
     firstBackendMatch ::
@@ -518,7 +518,7 @@ goAxiom a
           return [ExternalFuncSig s]
 
 goForeign :: ForeignBlock -> [CCode]
-goForeign b = case b ^. foreignBackend of
+goForeign b = case b ^. foreignBackend . withLocParam of
   BackendC -> [Verbatim (b ^. foreignCode)]
   _ -> []
 

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

@@ -352,7 +352,7 @@ goJudoc (Judoc bs) = mconcatMapM goBlock bs
       JudocExample e -> goExample e
 
     goLine :: JudocParagraphLine 'Scoped -> Sem r Html
-    goLine (JudocParagraphLine atoms) = mconcatMapM goAtom (toList atoms)
+    goLine (JudocParagraphLine atoms) = mconcatMapM goAtom (map (^. withLocParam) (toList atoms))
 
     goExample :: Example 'Scoped -> Sem r Html
     goExample ex = do

src/Juvix/Compiler/Concrete/Data/Highlight/Input.hs

@@ -21,6 +21,3 @@ filterInput absPth HighlightInput {..} =
     { _highlightNames = filterByLoc absPth _highlightNames,
       _highlightParsed = filterByLoc absPth _highlightParsed
     }
-
-filterByLoc :: (HasLoc p) => Path Abs File -> [p] -> [p]
-filterByLoc p = filter ((== toFilePath p) . (^. intervalFile) . getLoc)

src/Juvix/Compiler/Concrete/Data/Highlight/Properties.hs

@@ -41,7 +41,7 @@ instance ToJSON Face where
 
 data PropertyGoto = PropertyGoto
   { _gotoInterval :: Interval,
-    _gotoFile :: FilePath,
+    _gotoFile :: Path Abs File,
     _gotoPos :: FileLoc
   }
 
@@ -61,12 +61,12 @@ data RawProperties = RawProperties
   }
 
 -- | (File, Row, Col, Length)
-type RawInterval = (FilePath, Int, Int, Int)
+type RawInterval = (Path Abs File, Int, Int, Int)
 
 type RawFace = (RawInterval, Face)
 
 -- | (Interval, TargetFile, TargetLine, TargetColumn)
-type RawGoto = (RawInterval, FilePath, Int, Int)
+type RawGoto = (RawInterval, Path Abs File, Int, Int)
 
 $( deriveToJSON
      defaultOptions
@@ -92,6 +92,7 @@ rawProperties Properties {..} =
       )
     rawFace :: PropertyFace -> RawFace
     rawFace PropertyFace {..} = (rawInterval _faceInterval, _faceFace)
+
     rawGoto :: PropertyGoto -> RawGoto
     rawGoto PropertyGoto {..} =
       ( rawInterval _gotoInterval,
@@ -125,7 +126,7 @@ instance ToSexp PropertyGoto where
       pos l = Int (succ (l ^. locOffset . unPos))
       start = pos (i ^. intervalStart)
       end = pos (i ^. intervalEnd)
-      gotoPair = Pair (String targetFile) (Int (targetPos ^. locOffset . to (succ . fromIntegral)))
+      gotoPair = Pair (String (toFilePath targetFile)) (Int (targetPos ^. locOffset . to (succ . fromIntegral)))
 
 instance ToSexp Properties where
   toSexp Properties {..} =

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

@@ -2,7 +2,9 @@ module Juvix.Compiler.Concrete.Data.ModuleIsTop where
 
 import Juvix.Prelude
 
-data ModuleIsTop = ModuleTop | ModuleLocal
+data ModuleIsTop
+  = ModuleTop
+  | ModuleLocal
   deriving stock (Eq, Ord, Show)
 
 $(genSingletons [''ModuleIsTop])

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

@@ -79,7 +79,12 @@ instance HasLoc TopModulePath where
       [] -> getLoc _modulePathName
       (x : _) -> getLoc x <> getLoc _modulePathName
 
-topModulePathToDottedPath :: (IsString s) => TopModulePath -> s
+topModulePathToName :: TopModulePath -> Name
+topModulePathToName (TopModulePath ms m) = case nonEmpty ms of
+  Nothing -> NameUnqualified m
+  Just ms' -> NameQualified (QualifiedName (SymbolPath ms') m)
+
+topModulePathToDottedPath :: IsString s => TopModulePath -> s
 topModulePathToDottedPath (TopModulePath l r) =
   fromText $ mconcat $ intersperse "." $ map (^. symbolText) $ l ++ [r]
 

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

@@ -19,7 +19,10 @@ newtype AxiomRef' (n :: S.IsConcrete) = AxiomRef'
 
 makeLenses ''AxiomRef'
 
-instance (Hashable (RefNameType s)) => Hashable (AxiomRef' s) where
+instance HasLoc AxiomRef where
+  getLoc = getLoc . (^. axiomRefName)
+
+instance Hashable (RefNameType s) => Hashable (AxiomRef' s) where
   hashWithSalt i = hashWithSalt i . (^. axiomRefName)
 
 instance (Eq (RefNameType s)) => Eq (AxiomRef' s) where
@@ -39,7 +42,10 @@ newtype InductiveRef' (n :: S.IsConcrete) = InductiveRef'
 
 makeLenses ''InductiveRef'
 
-instance (Hashable (RefNameType s)) => Hashable (InductiveRef' s) where
+instance HasLoc InductiveRef where
+  getLoc = getLoc . (^. inductiveRefName)
+
+instance Hashable (RefNameType s) => Hashable (InductiveRef' s) where
   hashWithSalt i = hashWithSalt i . (^. inductiveRefName)
 
 instance (Eq (RefNameType s)) => Eq (InductiveRef' s) where
@@ -59,7 +65,10 @@ newtype FunctionRef' (n :: S.IsConcrete) = FunctionRef'
 
 makeLenses ''FunctionRef'
 
-instance (Hashable (RefNameType s)) => Hashable (FunctionRef' s) where
+instance HasLoc FunctionRef where
+  getLoc = getLoc . (^. functionRefName)
+
+instance Hashable (RefNameType s) => Hashable (FunctionRef' s) where
   hashWithSalt i = hashWithSalt i . (^. functionRefName)
 
 instance (Eq (RefNameType s)) => Eq (FunctionRef' s) where
@@ -79,7 +88,10 @@ newtype ConstructorRef' (n :: S.IsConcrete) = ConstructorRef'
 
 makeLenses ''ConstructorRef'
 
-instance (Hashable (RefNameType s)) => Hashable (ConstructorRef' s) where
+instance HasLoc ConstructorRef where
+  getLoc = getLoc . (^. constructorRefName)
+
+instance Hashable (RefNameType s) => Hashable (ConstructorRef' s) where
   hashWithSalt i = hashWithSalt i . (^. constructorRefName)
 
 instance (Eq (RefNameType s)) => Eq (ConstructorRef' s) where
@@ -90,6 +102,3 @@ instance (Ord (RefNameType s)) => Ord (ConstructorRef' s) where
 
 instance (Show (RefNameType s)) => Show (ConstructorRef' s) where
   show = show . (^. constructorRefName)
-
-instance HasLoc (ConstructorRef' 'S.Concrete) where
-  getLoc (ConstructorRef' c) = getLoc c

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

@@ -1,12 +1,13 @@
 module Juvix.Compiler.Concrete.Data.ParsedInfoTable where
 
 import Juvix.Compiler.Concrete.Data.ParsedItem
+import Juvix.Data.Comment
 import Juvix.Prelude
 
-newtype InfoTable = InfoTable
-  { _infoParsedItems :: [ParsedItem]
+data InfoTable = InfoTable
+  { _infoParsedItems :: [ParsedItem],
+    _infoParsedComments :: Comments
   }
-  deriving newtype (Semigroup, Monoid)
   deriving stock (Eq, Show)
 
 makeLenses ''InfoTable