Fix highlight command for modules with import statements (#102)

* fix highlight

* Add minijuvix.yaml to test directories

Co-authored-by: Jonathan Cubides <jonathan.cubides@uib.no>

app/Main.hs

@@ -20,9 +20,8 @@ import MiniJuvix.Prelude.Pretty hiding (Doc)
 import MiniJuvix.Syntax.Abstract.InfoTable qualified as Abstract
 import MiniJuvix.Syntax.Abstract.Language qualified as Abstract
 import MiniJuvix.Syntax.Abstract.Pretty qualified as Abstract
-import MiniJuvix.Syntax.Concrete.Language qualified as Concrete
 import MiniJuvix.Syntax.Concrete.Parser qualified as Parser
-import MiniJuvix.Syntax.Concrete.Scoped.Highlight qualified as Scoper
+import MiniJuvix.Syntax.Concrete.Scoped.Highlight qualified as Highlight
 import MiniJuvix.Syntax.Concrete.Scoped.InfoTable qualified as Scoper
 import MiniJuvix.Syntax.Concrete.Scoped.Name qualified as Scoper
 import MiniJuvix.Syntax.Concrete.Scoped.Pretty qualified as Scoper
@@ -235,9 +234,6 @@ mkScopePrettyOptions g ScopeOptions {..} =
       Scoper._optInlineImports = _scopeInlineImports
     }
 
-parseModuleIO :: FilePath -> IO (Concrete.Module 'Concrete.Parsed 'Concrete.ModuleTop)
-parseModuleIO = fromRightIO id . Parser.runModuleParserIO
-
 minijuvixYamlFile :: FilePath
 minijuvixYamlFile = "minijuvix.yaml"
 
@@ -328,13 +324,21 @@ runCLI cli = do
       let entry :: EntryPoint
           entry = getEntryPoint root o
       res <- runIO (upToScoping entry)
+      absP <- makeAbsolute (o ^. highlightInputFile)
       let tbl = res ^. Scoper.resultParserTable
           items = tbl ^. Parser.infoParsedItems
           names = res ^. (Scoper.resultScoperTable . Scoper.infoNames)
-      putStrLn (Scoper.go items names)
-    Parse ParseOptions {..} -> do
-      m <- parseModuleIO _parseInputFile
-      if _parseNoPrettyShow then print m else pPrint m
+          hinput =
+            Highlight.filterInput
+              absP
+              Highlight.HighlightInput
+                { _highlightNames = names,
+                  _highlightParsed = items
+                }
+      putStrLn (Highlight.go hinput)
+    Parse opts -> do
+      m <- head . (^. Parser.resultModules) <$> runIO (upToParsing (getEntryPoint root opts))
+      if opts ^. parseNoPrettyShow then print m else pPrint m
     Scope opts -> do
       l <- (^. Scoper.resultModules) <$> runIO (upToScoping (getEntryPoint root opts))
       forM_ l $ \s -> do

src/MiniJuvix/Syntax/Concrete/Lexer.hs

@@ -14,6 +14,12 @@ type OperatorSym = Text
 
 type ParsecS r = ParsecT Void Text (Sem r)
 
+newtype ParserParams = ParserParams
+  { _parserParamsRoot :: FilePath
+  }
+
+makeLenses ''ParserParams
+
 space :: forall m e. MonadParsec e Text m => m ()
 space = L.space space1 lineComment block
   where
@@ -31,10 +37,10 @@ symbol = void . L.symbol space
 decimal :: (MonadParsec e Text m, Num n) => m n
 decimal = lexeme L.decimal
 
-identifier :: Member InfoTableBuilder r => ParsecS r Text
+identifier :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r Text
 identifier = fmap fst identifierL
 
-identifierL :: Member InfoTableBuilder r => ParsecS r (Text, Interval)
+identifierL :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (Text, Interval)
 identifierL = lexeme bareIdentifier
 
 fromPos :: P.Pos -> Pos
@@ -66,37 +72,38 @@ bracedString =
 string :: MonadParsec e Text m => m Text
 string = pack <$> (char '"' >> manyTill L.charLiteral (char '"'))
 
-mkLoc :: Int -> SourcePos -> Loc
-mkLoc offset SourcePos {..} = Loc {..}
+mkLoc :: Member (Reader ParserParams) r => Int -> SourcePos -> Sem r Loc
+mkLoc offset SourcePos {..} = do
+  root <- asks (^. parserParamsRoot)
+  let _locFile = normalise (root </> sourceName)
+  return Loc {..}
   where
-    _locFile = sourceName
     _locOffset = Pos (fromIntegral offset)
     _locFileLoc = FileLoc {..}
       where
         _locLine = fromPos sourceLine
         _locCol = fromPos sourceColumn
 
-curLoc :: MonadParsec e Text m => m Loc
+curLoc :: Member (Reader ParserParams) r => ParsecS r Loc
 curLoc = do
   sp <- getSourcePos
   offset <- stateOffset <$> getParserState
-  return (mkLoc offset sp)
+  lift (mkLoc offset sp)
 
-interval :: MonadParsec e Text m => m a -> m (a, Interval)
+interval :: Member (Reader ParserParams) r => ParsecS r a -> ParsecS r (a, Interval)
 interval ma = do
   start <- curLoc
   res <- ma
   end <- curLoc
   return (res, mkInterval start end)
 
-keyword :: Member InfoTableBuilder r => Text -> ParsecS r ()
+keyword :: Members '[Reader ParserParams, InfoTableBuilder] r => Text -> ParsecS r ()
 keyword kw = do
   l <- snd <$> interval (symbol kw)
   lift (registerKeyword l)
 
 -- | Same as @identifier@ but does not consume space after it.
--- TODO: revise.
-bareIdentifier :: Member InfoTableBuilder r => ParsecS r (Text, Interval)
+bareIdentifier :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (Text, Interval)
 bareIdentifier = interval $ do
   notFollowedBy (choice allKeywords)
   h <- P.satisfy validFirstChar
@@ -123,13 +130,13 @@ bareIdentifier = interval $ do
 dot :: forall e m. MonadParsec e Text m => m Char
 dot = P.char '.'
 
-dottedIdentifier :: Member InfoTableBuilder r => ParsecS r (NonEmpty (Text, Interval))
+dottedIdentifier :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (NonEmpty (Text, Interval))
 dottedIdentifier = lexeme $ P.sepBy1 bareIdentifier dot
 
 braces :: MonadParsec e Text m => m a -> m a
 braces = between (symbol "{") (symbol "}")
 
-allKeywords :: Member InfoTableBuilder r => [ParsecS r ()]
+allKeywords :: Members '[Reader ParserParams, InfoTableBuilder] r => [ParsecS r ()]
 allKeywords =
   [ kwAssignment,
     kwAxiom,
@@ -174,108 +181,108 @@ rparen = symbol ")"
 parens :: MonadParsec e Text m => m a -> m a
 parens = between lparen rparen
 
-kwAssignment :: Member InfoTableBuilder r => ParsecS r ()
+kwAssignment :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwAssignment = keyword Str.assignUnicode <|> keyword Str.assignAscii
 
-kwAxiom :: Member InfoTableBuilder r => ParsecS r ()
+kwAxiom :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwAxiom = keyword Str.axiom
 
 -- | Note that the trailing space is needed to distinguish it from ':='.
-kwColon :: Member InfoTableBuilder r => ParsecS r ()
+kwColon :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwColon = keyword Str.colonSpace
 
-kwColonOmega :: Member InfoTableBuilder r => ParsecS r ()
+kwColonOmega :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwColonOmega = keyword Str.colonOmegaUnicode <|> keyword Str.colonOmegaAscii
 
-kwColonOne :: Member InfoTableBuilder r => ParsecS r ()
+kwColonOne :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwColonOne = keyword Str.colonOne
 
-kwColonZero :: Member InfoTableBuilder r => ParsecS r ()
+kwColonZero :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwColonZero = keyword Str.colonZero
 
-kwCompile :: Member InfoTableBuilder r => ParsecS r ()
+kwCompile :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwCompile = keyword Str.compile
 
-kwEnd :: Member InfoTableBuilder r => ParsecS r ()
+kwEnd :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwEnd = keyword Str.end
 
-kwEval :: Member InfoTableBuilder r => ParsecS r ()
+kwEval :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwEval = keyword Str.eval
 
-kwHiding :: Member InfoTableBuilder r => ParsecS r ()
+kwHiding :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwHiding = keyword Str.hiding
 
-kwImport :: Member InfoTableBuilder r => ParsecS r ()
+kwImport :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwImport = keyword Str.import_
 
-kwForeign :: Member InfoTableBuilder r => ParsecS r ()
+kwForeign :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwForeign = keyword Str.foreign_
 
-kwIn :: Member InfoTableBuilder r => ParsecS r ()
+kwIn :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwIn = keyword Str.in_
 
-kwInductive :: Member InfoTableBuilder r => ParsecS r ()
+kwInductive :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwInductive = keyword Str.inductive
 
-kwInfix :: Member InfoTableBuilder r => ParsecS r ()
+kwInfix :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwInfix = keyword Str.infix_
 
-kwInfixl :: Member InfoTableBuilder r => ParsecS r ()
+kwInfixl :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwInfixl = keyword Str.infixl_
 
-kwInfixr :: Member InfoTableBuilder r => ParsecS r ()
+kwInfixr :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwInfixr = keyword Str.infixr_
 
-kwLambda :: Member InfoTableBuilder r => ParsecS r ()
+kwLambda :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwLambda = keyword Str.lambdaUnicode <|> keyword Str.lambdaAscii
 
-kwLet :: Member InfoTableBuilder r => ParsecS r ()
+kwLet :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwLet = keyword Str.let_
 
-kwMapsTo :: Member InfoTableBuilder r => ParsecS r ()
+kwMapsTo :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwMapsTo = keyword Str.mapstoUnicode <|> keyword Str.mapstoAscii
 
-kwMatch :: Member InfoTableBuilder r => ParsecS r ()
+kwMatch :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwMatch = keyword Str.match
 
-kwModule :: Member InfoTableBuilder r => ParsecS r ()
+kwModule :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwModule = keyword Str.module_
 
-kwOpen :: Member InfoTableBuilder r => ParsecS r ()
+kwOpen :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwOpen = keyword Str.open
 
-kwPostfix :: Member InfoTableBuilder r => ParsecS r ()
+kwPostfix :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwPostfix = keyword Str.postfix
 
-kwPrint :: Member InfoTableBuilder r => ParsecS r ()
+kwPrint :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwPrint = keyword Str.print
 
-kwPublic :: Member InfoTableBuilder r => ParsecS r ()
+kwPublic :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwPublic = keyword Str.public
 
-kwRightArrow :: Member InfoTableBuilder r => ParsecS r ()
+kwRightArrow :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwRightArrow = keyword Str.toUnicode <|> keyword Str.toAscii
 
-kwSemicolon :: Member InfoTableBuilder r => ParsecS r ()
+kwSemicolon :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwSemicolon = keyword Str.semicolon
 
-kwType :: Member InfoTableBuilder r => ParsecS r ()
+kwType :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwType = keyword Str.type_
 
-kwTerminating :: Member InfoTableBuilder r => ParsecS r ()
+kwTerminating :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwTerminating = keyword Str.terminating
 
-kwUsing :: Member InfoTableBuilder r => ParsecS r ()
+kwUsing :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwUsing = keyword Str.using
 
-kwWhere :: Member InfoTableBuilder r => ParsecS r ()
+kwWhere :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwWhere = keyword Str.where_
 
-kwWildcard :: Member InfoTableBuilder r => ParsecS r ()
+kwWildcard :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 kwWildcard = keyword Str.underscore
 
-ghc :: Member InfoTableBuilder r => ParsecS r ()
+ghc :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 ghc = keyword Str.ghc
 
-cBackend :: Member InfoTableBuilder r => ParsecS r ()
+cBackend :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ()
 cBackend = keyword Str.cBackend

src/MiniJuvix/Syntax/Concrete/Name.hs

@@ -83,7 +83,7 @@ topModulePathToFilePath = topModulePathToFilePath' (Just ".mjuvix")
 
 topModulePathToFilePath' ::
   Maybe String -> FilePath -> TopModulePath -> FilePath
-topModulePathToFilePath' ext root mp = absPath
+topModulePathToFilePath' ext root mp = normalise absPath
   where
     relDirPath = foldr ((</>) . toPath) mempty (mp ^. modulePathDir)
     relFilePath = relDirPath </> toPath (mp ^. modulePathName)

src/MiniJuvix/Syntax/Concrete/Parser.hs

@@ -8,7 +8,6 @@ where
 import Data.List.NonEmpty.Extra qualified as NonEmpty
 import Data.Singletons
 import Data.Text qualified as Text
-import Data.Text.IO qualified as Text
 import MiniJuvix.Pipeline.EntryPoint
 import MiniJuvix.Prelude
 import MiniJuvix.Syntax.Concrete.Base (MonadParsec)
@@ -25,7 +24,7 @@ import MiniJuvix.Syntax.Concrete.Parser.ParserResult
 
 entryParser :: Members '[Files, Error Text] r => EntryPoint -> Sem r ParserResult
 entryParser e = do
-  (_resultTable, _resultModules) <- runInfoTableBuilder (mapM goFile (e ^. entryModulePaths))
+  (_resultTable, _resultModules) <- runInfoTableBuilder (runReader e (mapM goFile (e ^. entryModulePaths)))
   let _resultEntry = e
   return ParserResult {..}
   where
@@ -35,53 +34,37 @@ entryParser e = do
       Sem r (Module 'Parsed 'ModuleTop)
     goFile fileName = do
       input <- readFile' fileName
-      case runModuleParser'' fileName input of
+      case runModuleParser (e ^. entryRoot) fileName input of
         Left er -> throw er
         Right (tbl, m) -> mergeTable tbl $> m
 
-runModuleParserIO :: FilePath -> IO (Either Text (Module 'Parsed 'ModuleTop))
-runModuleParserIO fileName =
-  fmap (fmap snd) (runModuleParserIO' fileName)
-
-runModuleParserIO' :: FilePath -> IO (Either Text (InfoTable, Module 'Parsed 'ModuleTop))
-runModuleParserIO' fileName = do
-  input <- Text.readFile fileName
-  return (runModuleParser'' fileName input)
-
-runModuleParser :: FilePath -> Text -> Either Text (Module 'Parsed 'ModuleTop)
-runModuleParser fileName input = fmap snd (runModuleParser'' fileName input)
-
--- | The 'FilePath' is only used for reporting errors. It is safe to pass
+-- | The fileName is only used for reporting errors. It is safe to pass
 -- an empty string.
-runModuleParser'' :: FilePath -> Text -> Either Text (InfoTable, Module 'Parsed 'ModuleTop)
-runModuleParser'' fileName input =
-  case run $ runInfoTableBuilder $ P.runParserT topModuleDef fileName input of
+runModuleParser :: FilePath -> FilePath -> Text -> Either Text (InfoTable, Module 'Parsed 'ModuleTop)
+runModuleParser root fileName input =
+  case run $ runInfoTableBuilder $ runReader params $ P.runParserT topModuleDef fileName input of
     (_, Left err) -> Left (Text.pack (P.errorBundlePretty err))
     (tbl, Right r) -> return (tbl, r)
+  where
+    params =
+      ParserParams
+        { _parserParamsRoot = root
+        }
 
--- runModuleParser' :: FilePath -> Text -> Either Text ParserResult
--- runModuleParser' fileName input =
---   mkResult <$> runModuleParser'' fileName input
---   where
---   mkResult (t, m) = ParserResult {
---       _resultTable = t,
---       _resultModules = pure m
---       }
-
-topModuleDef :: Member InfoTableBuilder r => ParsecS r (Module 'Parsed 'ModuleTop)
+topModuleDef :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (Module 'Parsed 'ModuleTop)
 topModuleDef = space >> moduleDef <* (optional kwSemicolon >> P.eof)
 
 --------------------------------------------------------------------------------
 -- Symbols and names
 --------------------------------------------------------------------------------
 
-symbol :: Member InfoTableBuilder r => ParsecS r Symbol
+symbol :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r Symbol
 symbol = uncurry Symbol <$> identifierL
 
-dottedSymbol :: Member InfoTableBuilder r => ParsecS r (NonEmpty Symbol)
+dottedSymbol :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (NonEmpty Symbol)
 dottedSymbol = fmap (uncurry Symbol) <$> dottedIdentifier
 
-name :: Member InfoTableBuilder r => ParsecS r Name
+name :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r Name
 name = do
   parts <- dottedSymbol
   return $ case nonEmptyUnsnoc parts of
@@ -91,17 +74,17 @@ name = do
 mkTopModulePath :: NonEmpty Symbol -> TopModulePath
 mkTopModulePath l = TopModulePath (NonEmpty.init l) (NonEmpty.last l)
 
-symbolList :: Member InfoTableBuilder r => ParsecS r (NonEmpty Symbol)
+symbolList :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (NonEmpty Symbol)
 symbolList = braces (P.sepBy1 symbol kwSemicolon)
 
-topModulePath :: Member InfoTableBuilder r => ParsecS r TopModulePath
+topModulePath :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r TopModulePath
 topModulePath = mkTopModulePath <$> dottedSymbol
 
 --------------------------------------------------------------------------------
 -- Top level statement
 --------------------------------------------------------------------------------
 
-statement :: Member InfoTableBuilder r => ParsecS r (Statement 'Parsed)
+statement :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (Statement 'Parsed)
 statement =
   (StatementOperator <$> operatorSyntaxDef)
     <|> (StatementOpenModule <$> openModule)
@@ -121,7 +104,7 @@ statement =
 -- Compile
 --------------------------------------------------------------------------------
 
-compileBlock :: forall r. Member InfoTableBuilder r => ParsecS r (Compile 'Parsed)
+compileBlock :: forall r. Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (Compile 'Parsed)
 compileBlock = do
   kwCompile
   _compileName <- symbol
@@ -140,10 +123,10 @@ compileBlock = do
 -- Foreign
 --------------------------------------------------------------------------------
 
-backend :: Member InfoTableBuilder r => ParsecS r Backend
+backend :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r Backend
 backend = ghc $> BackendGhc <|> cBackend $> BackendC
 
-foreignBlock :: Member InfoTableBuilder r => ParsecS r ForeignBlock
+foreignBlock :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r ForeignBlock
 foreignBlock = do
   kwForeign
   _foreignBackend <- backend
@@ -157,7 +140,7 @@ foreignBlock = do
 precedence :: MonadParsec e Text m => m Precedence
 precedence = PrecNat <$> decimal
 
-operatorSyntaxDef :: forall r. Member InfoTableBuilder r => ParsecS r OperatorSyntaxDef
+operatorSyntaxDef :: forall r. Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r OperatorSyntaxDef
 operatorSyntaxDef = do
   _fixityArity <- arity
   _fixityPrecedence <- precedence
@@ -177,7 +160,7 @@ operatorSyntaxDef = do
 -- Import statement
 --------------------------------------------------------------------------------
 
-import_ :: Member InfoTableBuilder r => ParsecS r (Import 'Parsed)
+import_ :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (Import 'Parsed)
 import_ = do
   kwImport
   _importModule <- topModulePath
@@ -187,7 +170,7 @@ import_ = do
 -- Expression
 --------------------------------------------------------------------------------
 
-expressionAtom :: Member InfoTableBuilder r => ParsecS r (ExpressionAtom 'Parsed)
+expressionAtom :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (ExpressionAtom 'Parsed)
 expressionAtom =
   do AtomLiteral <$> P.try literal
     <|> (AtomIdentifier <$> name)
@@ -199,24 +182,24 @@ expressionAtom =
     <|> (AtomFunArrow <$ kwRightArrow)
     <|> parens (AtomParens <$> expressionAtoms)
 
-expressionAtoms :: Member InfoTableBuilder r => ParsecS r (ExpressionAtoms 'Parsed)
+expressionAtoms :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (ExpressionAtoms 'Parsed)
 expressionAtoms = ExpressionAtoms <$> P.some expressionAtom
 
 --------------------------------------------------------------------------------
 -- Literals
 --------------------------------------------------------------------------------
 
-literalInteger :: MonadParsec e Text m => m LiteralLoc
+literalInteger :: Member (Reader ParserParams) r => ParsecS r LiteralLoc
 literalInteger = do
   (x, loc) <- interval integer
   return (LiteralLoc (LitInteger x) loc)
 
-literalString :: MonadParsec e Text m => m LiteralLoc
+literalString :: Member (Reader ParserParams) r => ParsecS r LiteralLoc
 literalString = do
   (x, loc) <- interval string
   return (LiteralLoc (LitString x) loc)
 
-literal :: Member InfoTableBuilder r => ParsecS r LiteralLoc
+literal :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r LiteralLoc
 literal = do
   l <-
     literalInteger
@@ -227,14 +210,14 @@ literal = do
 -- Match expression
 --------------------------------------------------------------------------------
 
-matchAlt :: Member InfoTableBuilder r => ParsecS r (MatchAlt 'Parsed)
+matchAlt :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (MatchAlt 'Parsed)
 matchAlt = do
   matchAltPattern <- patternAtom
   kwMapsTo
   matchAltBody <- expressionAtoms
   return MatchAlt {..}
 
-match :: Member InfoTableBuilder r => ParsecS r (Match 'Parsed)
+match :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (Match 'Parsed)
 match = do
   kwMatch
   matchExpression <- expressionAtoms
@@ -245,10 +228,10 @@ match = do
 -- Let expression
 --------------------------------------------------------------------------------
 
-letClause :: Member InfoTableBuilder r => ParsecS r (LetClause 'Parsed)
+letClause :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (LetClause 'Parsed)
 letClause = either LetTypeSig LetFunClause <$> auxTypeSigFunClause
 
-letBlock :: Member InfoTableBuilder r => ParsecS r (LetBlock 'Parsed)
+letBlock :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (LetBlock 'Parsed)
 letBlock = do
   kwLet
   _letClauses <- braces (P.sepEndBy letClause kwSemicolon)
@@ -260,7 +243,7 @@ letBlock = do
 -- Universe expression
 --------------------------------------------------------------------------------
 
-universe :: Member InfoTableBuilder r => ParsecS r Universe
+universe :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r Universe
 universe = do
   kwType
   Universe <$> optional decimal
@@ -270,7 +253,7 @@ universe = do
 -------------------------------------------------------------------------------
 
 typeSignature ::
-  Member InfoTableBuilder r =>
+  Members '[Reader ParserParams, InfoTableBuilder] r =>
   Bool ->
   Symbol ->
   ParsecS r (TypeSignature 'Parsed)
@@ -285,7 +268,7 @@ typeSignature _sigTerminating _sigName = do
 
 -- | Used to minimize the amount of required @P.try@s.
 auxTypeSigFunClause ::
-  Member InfoTableBuilder r =>
+  Members '[Reader ParserParams, InfoTableBuilder] r =>
   ParsecS r (Either (TypeSignature 'Parsed) (FunctionClause 'Parsed))
 auxTypeSigFunClause = do
   terminating <- isJust <$> optional kwTerminating
@@ -297,7 +280,7 @@ auxTypeSigFunClause = do
 -- Axioms
 -------------------------------------------------------------------------------
 
-axiomDef :: Member InfoTableBuilder r => ParsecS r (AxiomDef 'Parsed)
+axiomDef :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (AxiomDef 'Parsed)
 axiomDef = do
   kwAxiom
   _axiomName <- symbol
@@ -309,7 +292,7 @@ axiomDef = do
 -- Function expression
 --------------------------------------------------------------------------------
 
-functionParam :: forall r. Member InfoTableBuilder r => ParsecS r (FunctionParameter 'Parsed)
+functionParam :: forall r. Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (FunctionParameter 'Parsed)
 functionParam = do
   (_paramName, _paramUsage) <- P.try $ do
     lparen
@@ -331,7 +314,7 @@ functionParam = do
         <|> (Just UsageOmega <$ kwColonOmega)
         <|> (Nothing <$ kwColon)
 
-function :: Member InfoTableBuilder r => ParsecS r (Function 'Parsed)
+function :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (Function 'Parsed)
 function = do
   _funParameter <- functionParam
   kwRightArrow
@@ -342,12 +325,12 @@ function = do
 -- Where block clauses
 --------------------------------------------------------------------------------
 
-whereBlock :: Member InfoTableBuilder r => ParsecS r (WhereBlock 'Parsed)
+whereBlock :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (WhereBlock 'Parsed)
 whereBlock = do
   kwWhere
   WhereBlock <$> braces (P.sepEndBy1 whereClause kwSemicolon)
 
-whereClause :: forall r. Member InfoTableBuilder r => ParsecS r (WhereClause 'Parsed)
+whereClause :: forall r. Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (WhereClause 'Parsed)
 whereClause =
   (WhereOpenModule <$> openModule)
     <|> sigOrFun
@@ -359,14 +342,14 @@ whereClause =
 -- Lambda expression
 --------------------------------------------------------------------------------
 
-lambdaClause :: Member InfoTableBuilder r => ParsecS r (LambdaClause 'Parsed)
+lambdaClause :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (LambdaClause 'Parsed)
 lambdaClause = do
   lambdaParameters <- P.some patternAtom
   kwMapsTo
   lambdaBody <- expressionAtoms
   return LambdaClause {..}
 
-lambda :: Member InfoTableBuilder r => ParsecS r (Lambda 'Parsed)
+lambda :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (Lambda 'Parsed)
 lambda = do
   kwLambda
   lambdaClauses <- braces (P.sepEndBy lambdaClause kwSemicolon)
@@ -376,7 +359,7 @@ lambda = do
 -- Data type construction declaration
 -------------------------------------------------------------------------------
 
-inductiveDef :: Member InfoTableBuilder r => ParsecS r (InductiveDef 'Parsed)
+inductiveDef :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (InductiveDef 'Parsed)
 inductiveDef = do
   kwInductive
   _inductiveName <- symbol
@@ -385,14 +368,14 @@ inductiveDef = do
   _inductiveConstructors <- braces $ P.sepEndBy constructorDef kwSemicolon
   return InductiveDef {..}
 
-inductiveParam :: Member InfoTableBuilder r => ParsecS r (InductiveParameter 'Parsed)
+inductiveParam :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (InductiveParameter 'Parsed)
 inductiveParam = parens $ do
   _inductiveParameterName <- symbol
   kwColon
   _inductiveParameterType <- expressionAtoms
   return InductiveParameter {..}
 
-constructorDef :: Member InfoTableBuilder r => ParsecS r (InductiveConstructorDef 'Parsed)
+constructorDef :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (InductiveConstructorDef 'Parsed)
 constructorDef = do
   _constructorName <- symbol
   kwColon
@@ -403,20 +386,20 @@ constructorDef = do
 -- Pattern section
 --------------------------------------------------------------------------------
 
-patternAtom :: Member InfoTableBuilder r => ParsecS r (PatternAtom 'Parsed)
+patternAtom :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (PatternAtom 'Parsed)
 patternAtom =
   PatternAtomIden <$> name
     <|> PatternAtomWildcard <$ kwWildcard
     <|> (PatternAtomParens <$> parens patternAtoms)
 
-patternAtoms :: Member InfoTableBuilder r => ParsecS r (PatternAtoms 'Parsed)
+patternAtoms :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (PatternAtoms 'Parsed)
 patternAtoms = PatternAtoms <$> P.some patternAtom
 
 --------------------------------------------------------------------------------
 -- Function binding declaration
 --------------------------------------------------------------------------------
 
-functionClause :: Member InfoTableBuilder r => Symbol -> ParsecS r (FunctionClause 'Parsed)
+functionClause :: Members '[Reader ParserParams, InfoTableBuilder] r => Symbol -> ParsecS r (FunctionClause 'Parsed)
 functionClause _clauseOwnerFunction = do
   _clausePatterns <- P.many patternAtom
   kwAssignment
@@ -428,12 +411,12 @@ functionClause _clauseOwnerFunction = do
 -- Module declaration
 --------------------------------------------------------------------------------
 
-pmodulePath :: forall t r. (SingI t, Member InfoTableBuilder r) => ParsecS r (ModulePathType 'Parsed t)
+pmodulePath :: forall t r. (SingI t, Members '[Reader ParserParams, InfoTableBuilder] r) => ParsecS r (ModulePathType 'Parsed t)
 pmodulePath = case sing :: SModuleIsTop t of
   SModuleTop -> topModulePath
   SModuleLocal -> symbol
 
-moduleDef :: (SingI t, Member InfoTableBuilder r) => ParsecS r (Module 'Parsed t)
+moduleDef :: (SingI t, Members '[Reader ParserParams, InfoTableBuilder] r) => ParsecS r (Module 'Parsed t)
 moduleDef = do
   kwModule
   _modulePath <- pmodulePath
@@ -444,7 +427,7 @@ moduleDef = do
   return Module {..}
 
 -- | An ExpressionAtom which is a valid expression on its own.
-atomicExpression :: Member InfoTableBuilder r => ParsecS r (ExpressionType 'Parsed)
+atomicExpression :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (ExpressionType 'Parsed)
 atomicExpression = do
   atom <- expressionAtom
   case atom of
@@ -452,7 +435,7 @@ atomicExpression = do
     _ -> return ()
   return $ ExpressionAtoms (NonEmpty.singleton atom)
 
-openModule :: forall r. Member InfoTableBuilder r => ParsecS r (OpenModule 'Parsed)
+openModule :: forall r. Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (OpenModule 'Parsed)
 openModule = do
   kwOpen
   _openModuleName <- name
@@ -470,12 +453,12 @@ openModule = do
 -- Debugging statements
 --------------------------------------------------------------------------------
 
-eval :: Member InfoTableBuilder r => ParsecS r (Eval 'Parsed)
+eval :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (Eval 'Parsed)
 eval = do
   kwEval
   Eval <$> expressionAtoms
 
-printS :: Member InfoTableBuilder r => ParsecS r (Print 'Parsed)
+printS :: Members '[Reader ParserParams, InfoTableBuilder] r => ParsecS r (Print 'Parsed)
 printS = do
   kwPrint
   Print <$> expressionAtoms

src/MiniJuvix/Syntax/Concrete/Scoped/Highlight.hs

@@ -26,6 +26,13 @@ data Instruction = SetProperty
     _setPropertyProperty :: Property
   }
 
+data HighlightInput = HighlightInput
+  { _highlightParsed :: [ParsedItem],
+    _highlightNames :: [Name]
+  }
+
+makeLenses ''HighlightInput
+
 data SExp
   = Symbol Text
   | App [SExp]
@@ -37,8 +44,18 @@ data SExp
 
 makeLenses ''Instruction
 
-go :: [ParsedItem] -> [Name] -> Text
-go items names =
+filterInput :: FilePath -> HighlightInput -> HighlightInput
+filterInput absPth h =
+  HighlightInput
+    { _highlightNames = filterByLoc (h ^. highlightNames),
+      _highlightParsed = filterByLoc (h ^. highlightParsed)
+    }
+  where
+    filterByLoc :: HasLoc p => [p] -> [p]
+    filterByLoc = filter ((== absPth) . (^. intFile) . getLoc)
+
+go :: HighlightInput -> Text
+go HighlightInput {..} =
   renderSExp
     ( progn
         ( map goParsedItem items
@@ -46,6 +63,11 @@ go items names =
             <> map gotoDefName names
         )
     )
+  where
+    names :: [Name]
+    names = _highlightNames
+    items :: [ParsedItem]
+    items = _highlightParsed
 
 progn :: [SExp] -> SExp
 progn l = App (Symbol "progn" : l)

src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs

@@ -18,7 +18,7 @@ import MiniJuvix.Prelude
 import MiniJuvix.Syntax.Concrete.Base qualified as P
 import MiniJuvix.Syntax.Concrete.Language
 import MiniJuvix.Syntax.Concrete.Name qualified as N
-import MiniJuvix.Syntax.Concrete.Parser (runModuleParser'')
+import MiniJuvix.Syntax.Concrete.Parser (runModuleParser)
 import MiniJuvix.Syntax.Concrete.Parser qualified as Parser
 import MiniJuvix.Syntax.Concrete.Parser.InfoTableBuilder (mergeTable)
 import MiniJuvix.Syntax.Concrete.Parser.InfoTableBuilder qualified as Parser
@@ -369,7 +369,8 @@ readParseModule ::
 readParseModule mp = do
   path <- modulePathToFilePath mp
   txt <- readFile' path
-  case runModuleParser'' path txt of
+  root <- asks (^. scopeRootPath)
+  case runModuleParser root path txt of
     Left err -> throw (ErrParser (MegaParsecError err))
     Right (tbl, m) -> Parser.mergeTable tbl $> m
 

src/MiniJuvix/Syntax/Concrete/Scoped/Utils.hs

@@ -24,3 +24,6 @@ getAllModules m =
 
 getModuleFilePath :: Module 'Scoped 'ModuleTop -> FilePath
 getModuleFilePath m = getLoc (m ^. modulePath) ^. intFile
+
+getModuleFileAbsPath :: FilePath -> Module 'Scoped 'ModuleTop -> FilePath
+getModuleFileAbsPath root m = normalise (root </> getModuleFilePath m)

test/Scope/Positive.hs

@@ -27,7 +27,9 @@ testDescr PosTest {..} =
         { _testName = _name,
           _testRoot = tRoot,
           _testAssertion = Steps $ \step -> do
-            let entryPoint = EntryPoint "." (pure _file)
+            cwd <- getCurrentDirectory
+            entryFile <- makeAbsolute _file
+            let entryPoint = EntryPoint cwd (pure entryFile)
 
             step "Parsing"
             p :: Parser.ParserResult <- runIO (upToParsing entryPoint)
@@ -39,22 +41,22 @@ testDescr PosTest {..} =
 
             let s2 = head (s ^. Scoper.resultModules)
 
-            let fs :: HashMap FilePath Text
+                fs :: HashMap FilePath Text
                 fs =
                   HashMap.fromList
-                    [ (getModuleFilePath m, M.renderPrettyCodeDefault m)
+                    [ (getModuleFileAbsPath cwd m, M.renderPrettyCodeDefault m)
                       | m <- toList (getAllModules s2)
                     ]
 
             let scopedPretty = M.renderPrettyCodeDefault s2
-            let parsedPretty = M.renderPrettyCodeDefault p2
+                parsedPretty = M.renderPrettyCodeDefault p2
 
             step "Parsing pretty scoped"
-            let fs2 = HashMap.singleton _file scopedPretty
+            let fs2 = HashMap.singleton entryFile scopedPretty
             p' :: Parser.ParserResult <- (runM . runErrorIO @AJuvixError . runNameIdGen . runFilesPure fs2) (upToParsing entryPoint)
 
             step "Parsing pretty parsed"
-            let fs3 = HashMap.singleton _file parsedPretty
+            let fs3 = HashMap.singleton entryFile parsedPretty
             parsedPretty' :: Parser.ParserResult <- (runM . runErrorIO @AJuvixError . runNameIdGen . runFilesPure fs3) (upToParsing entryPoint)
 
             step "Scoping the scoped"
@@ -62,11 +64,11 @@ testDescr PosTest {..} =
 
             step "Checks"
             let smodules = s ^. Scoper.resultModules
-            let smodules' = s' ^. Scoper.resultModules
+                smodules' = s' ^. Scoper.resultModules
 
             let pmodules = p ^. Parser.resultModules
-            let pmodules' = p' ^. Parser.resultModules
-            let parsedPrettyModules = parsedPretty' ^. Parser.resultModules
+                pmodules' = p' ^. Parser.resultModules
+                parsedPrettyModules = parsedPretty' ^. Parser.resultModules
 
             assertEqDiff "check: scope . parse . pretty . scope . parse = scope . parse" smodules smodules'
             assertEqDiff "check: parse . pretty . scope . parse = parse" pmodules pmodules'