diff --git a/app/Main.hs b/app/Main.hs index 38ba79c31..3d4e70326 100644 --- a/app/Main.hs +++ b/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 diff --git a/src/MiniJuvix/Syntax/Concrete/Lexer.hs b/src/MiniJuvix/Syntax/Concrete/Lexer.hs index 261b7a443..8f56ebb36 100644 --- a/src/MiniJuvix/Syntax/Concrete/Lexer.hs +++ b/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 diff --git a/src/MiniJuvix/Syntax/Concrete/Name.hs b/src/MiniJuvix/Syntax/Concrete/Name.hs index a52af3994..3713a4bd3 100644 --- a/src/MiniJuvix/Syntax/Concrete/Name.hs +++ b/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) diff --git a/src/MiniJuvix/Syntax/Concrete/Parser.hs b/src/MiniJuvix/Syntax/Concrete/Parser.hs index 4d8a805df..85030d004 100644 --- a/src/MiniJuvix/Syntax/Concrete/Parser.hs +++ b/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 diff --git a/src/MiniJuvix/Syntax/Concrete/Scoped/Highlight.hs b/src/MiniJuvix/Syntax/Concrete/Scoped/Highlight.hs index 3a0eef13e..17b134fb2 100644 --- a/src/MiniJuvix/Syntax/Concrete/Scoped/Highlight.hs +++ b/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) diff --git a/src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs b/src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs index 03d4b65b9..a9c7c87d6 100644 --- a/src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs +++ b/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 diff --git a/src/MiniJuvix/Syntax/Concrete/Scoped/Utils.hs b/src/MiniJuvix/Syntax/Concrete/Scoped/Utils.hs index c11ce91d4..19d013ae2 100644 --- a/src/MiniJuvix/Syntax/Concrete/Scoped/Utils.hs +++ b/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) diff --git a/test/Scope/Positive.hs b/test/Scope/Positive.hs index ee1fd3d88..ff6a61081 100644 --- a/test/Scope/Positive.hs +++ b/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' diff --git a/tests/negative/BindGroupConflict/minijuvix.yaml b/tests/negative/BindGroupConflict/minijuvix.yaml new file mode 100644 index 000000000..e69de29bb diff --git a/tests/negative/CompileBlocks/minijuvix.yaml b/tests/negative/CompileBlocks/minijuvix.yaml new file mode 100644 index 000000000..e69de29bb diff --git a/tests/negative/ImportCycle/minijuvix.yaml b/tests/negative/ImportCycle/minijuvix.yaml new file mode 100644 index 000000000..e69de29bb diff --git a/tests/negative/MicroJuvix/minijuvix.yaml b/tests/negative/MicroJuvix/minijuvix.yaml new file mode 100644 index 000000000..e69de29bb diff --git a/tests/negative/Termination/minijuvix.yaml b/tests/negative/Termination/minijuvix.yaml new file mode 100644 index 000000000..e69de29bb diff --git a/tests/positive/FullExamples/minijuvix.yaml b/tests/positive/FullExamples/minijuvix.yaml new file mode 100644 index 000000000..e69de29bb diff --git a/tests/positive/Imports/minijuvix.yaml b/tests/positive/Imports/minijuvix.yaml new file mode 100644 index 000000000..e69de29bb diff --git a/tests/positive/MicroJuvix/minijuvix.yaml b/tests/positive/MicroJuvix/minijuvix.yaml new file mode 100644 index 000000000..e69de29bb diff --git a/tests/positive/MiniC/minijuvix.yaml b/tests/positive/MiniC/minijuvix.yaml new file mode 100644 index 000000000..e69de29bb diff --git a/tests/positive/MiniHaskell/minijuvix.yaml b/tests/positive/MiniHaskell/minijuvix.yaml new file mode 100644 index 000000000..e69de29bb diff --git a/tests/positive/QualifiedConstructor/minijuvix.yaml b/tests/positive/QualifiedConstructor/minijuvix.yaml new file mode 100644 index 000000000..e69de29bb diff --git a/tests/positive/QualifiedSymbol/minijuvix.yaml b/tests/positive/QualifiedSymbol/minijuvix.yaml new file mode 100644 index 000000000..e69de29bb diff --git a/tests/positive/QualifiedSymbol2/minijuvix.yaml b/tests/positive/QualifiedSymbol2/minijuvix.yaml new file mode 100644 index 000000000..e69de29bb diff --git a/tests/positive/StdlibList/minijuvix.yaml b/tests/positive/StdlibList/minijuvix.yaml new file mode 100644 index 000000000..e69de29bb diff --git a/tests/positive/Termination/minijuvix.yaml b/tests/positive/Termination/minijuvix.yaml new file mode 100644 index 000000000..e69de29bb diff --git a/tests/positive/minijuvix.yaml b/tests/positive/minijuvix.yaml new file mode 100644 index 000000000..e69de29bb