diff --git a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs index 620547bdf3..806a2e74c8 100644 --- a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs +++ b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs @@ -543,7 +543,7 @@ goFunctionDef def = do defHeader (def ^. signName) sig' (def ^. signDoc) where funSig :: Sem r Html - funSig = ppHelper (ppFunctionSignature def) + funSig = ppHelper (ppCode (functionDefLhs def)) goInductive :: forall r. (Members '[Reader HtmlOptions] r) => InductiveDef 'Scoped -> Sem r Html goInductive def = do diff --git a/src/Juvix/Compiler/Concrete/Language/Base.hs b/src/Juvix/Compiler/Concrete/Language/Base.hs index 9878dca050..25c122fc75 100644 --- a/src/Juvix/Compiler/Concrete/Language/Base.hs +++ b/src/Juvix/Compiler/Concrete/Language/Base.hs @@ -2801,15 +2801,15 @@ deriving stock instance Ord (JudocAtom 'Parsed) deriving stock instance Ord (JudocAtom 'Scoped) -data FunctionLhs = FunctionLhs - { _funLhsInstance :: Maybe KeywordRef, +data FunctionLhs (s :: Stage) = FunctionLhs + { _funLhsBuiltin :: Maybe (WithLoc BuiltinFunction), + _funLhsTerminating :: Maybe KeywordRef, + _funLhsInstance :: Maybe KeywordRef, _funLhsCoercion :: Maybe KeywordRef, - _funLhsName :: FunctionName 'Parsed, - _funLhsArgs :: [SigArg 'Parsed], + _funLhsName :: FunctionName s, + _funLhsArgs :: [SigArg s], _funLhsColonKw :: Irrelevant (Maybe KeywordRef), - _funLhsRetType :: Maybe (ExpressionType 'Parsed), - _funLhsTerminating :: Maybe KeywordRef, - _funLhsAfterLastArgOff :: Int + _funLhsRetType :: Maybe (ExpressionType s) } makeLenses ''SideIfs @@ -2900,6 +2900,19 @@ makeLenses ''RecordInfo makeLenses ''MarkdownInfo makePrisms ''NamedArgumentNew +functionDefLhs :: FunctionDef s -> FunctionLhs s +functionDefLhs FunctionDef {..} = + FunctionLhs + { _funLhsBuiltin = _signBuiltin, + _funLhsTerminating = _signTerminating, + _funLhsInstance = _signInstance, + _funLhsCoercion = _signCoercion, + _funLhsName = _signName, + _funLhsArgs = _signArgs, + _funLhsColonKw = _signColonKw, + _funLhsRetType = _signRetType + } + fixityFieldHelper :: SimpleGetter (ParsedFixityFields s) (Maybe a) -> SimpleGetter (ParsedFixityInfo s) (Maybe a) fixityFieldHelper l = to (^? fixityFields . _Just . l . _Just) diff --git a/src/Juvix/Compiler/Concrete/Print/Base.hs b/src/Juvix/Compiler/Concrete/Print/Base.hs index 8824e85130..0bb4d9be43 100644 --- a/src/Juvix/Compiler/Concrete/Print/Base.hs +++ b/src/Juvix/Compiler/Concrete/Print/Base.hs @@ -1123,34 +1123,34 @@ instance (SingI s) => PrettyPrint (SigArg s) where defaultVal = ppCode <$> _sigArgDefault ppCode l <> arg <+?> defaultVal <> ppCode r -ppFunctionSignature :: (SingI s) => PrettyPrinting (FunctionDef s) -ppFunctionSignature FunctionDef {..} = do - let termin' = (<> line) . ppCode <$> _signTerminating - coercion' = (<> if isJust instance' then space else line) . ppCode <$> _signCoercion - instance' = (<> line) . ppCode <$> _signInstance - builtin' = (<> line) . ppCode <$> _signBuiltin - margs' = fmap ppCode <$> nonEmpty _signArgs - mtype' = case _signColonKw ^. unIrrelevant of - Just col -> Just (ppCode col <+> ppExpressionType (fromJust _signRetType)) - Nothing -> Nothing - argsAndType' = case mtype' of - Nothing -> margs' - Just ty' -> case margs' of - Nothing -> Just (pure ty') - Just args' -> Just (args' <> pure ty') - name' = annDef _signName (ppSymbolType _signName) - in builtin' - ?<> termin' - ?<> coercion' - ?<> instance' - ?<> (name' <>? (oneLineOrNext . sep <$> argsAndType')) +instance (SingI s) => PrettyPrint (FunctionLhs s) where + ppCode FunctionLhs {..} = do + let termin' = (<> line) . ppCode <$> _funLhsTerminating + coercion' = (<> if isJust instance' then space else line) . ppCode <$> _funLhsCoercion + instance' = (<> line) . ppCode <$> _funLhsInstance + builtin' = (<> line) . ppCode <$> _funLhsBuiltin + margs' = fmap ppCode <$> nonEmpty _funLhsArgs + mtype' = case _funLhsColonKw ^. unIrrelevant of + Just col -> Just (ppCode col <+> ppExpressionType (fromJust _funLhsRetType)) + Nothing -> Nothing + argsAndType' = case mtype' of + Nothing -> margs' + Just ty' -> case margs' of + Nothing -> Just (pure ty') + Just args' -> Just (args' <> pure ty') + name' = annDef _funLhsName (ppSymbolType _funLhsName) + builtin' + ?<> termin' + ?<> coercion' + ?<> instance' + ?<> (name' <>? (oneLineOrNext . sep <$> argsAndType')) instance (SingI s) => PrettyPrint (FunctionDef s) where ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => FunctionDef s -> Sem r () ppCode fun@FunctionDef {..} = do let doc' :: Maybe (Sem r ()) = ppCode <$> _signDoc pragmas' :: Maybe (Sem r ()) = ppCode <$> _signPragmas - sig' = ppFunctionSignature fun + sig' = ppCode (functionDefLhs fun) body' = case _signBody of SigBodyExpression e -> space <> ppCode Kw.kwAssign <> oneLineOrNext (ppTopExpressionType e) SigBodyClauses k -> line <> indent (vsep (ppCode <$> k)) diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs index f956300513..5fab4fc798 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs @@ -849,10 +849,7 @@ expressionAtom = <|> AtomParens <$> parens parseExpressionAtoms <|> AtomDoubleBraces <$> pdoubleBracesExpression <|> AtomRecordUpdate <$> recordUpdate - <|> ( do - checkNoNamedApplication - AtomBraces <$> withLoc (braces parseExpressionAtoms) - ) + <|> AtomBraces <$> withLoc (braces parseExpressionAtoms) parseExpressionAtoms :: (Members '[ParserResultBuilder, PragmasStash, Error ParserError, JudocStash] r) => @@ -1045,6 +1042,7 @@ namedApplicationNew :: (Members '[ParserResultBuilder, PragmasStash, Error ParserError, JudocStash] r) => ParsecS r (NamedApplicationNew 'Parsed) namedApplicationNew = P.label "" $ do + checkNoNamedApplicationMissingAt (_namedApplicationNewName, _namedApplicationNewExhaustive) <- P.try $ do n <- name exhaustive <- pisExhaustive @@ -1287,8 +1285,13 @@ getPragmas = P.lift $ do put (Nothing @ParsedPragmas) return j -functionDefinitionLhs :: forall r. (Members '[ParserResultBuilder, PragmasStash, Error ParserError, JudocStash] r) => FunctionSyntaxOptions -> ParsecS r FunctionLhs -functionDefinitionLhs opts = P.label "" $ do +functionDefinitionLhs :: + forall r. + (Members '[ParserResultBuilder, PragmasStash, Error ParserError, JudocStash] r) => + FunctionSyntaxOptions -> + Maybe (WithLoc BuiltinFunction) -> + ParsecS r (FunctionLhs 'Parsed) +functionDefinitionLhs opts _funLhsBuiltin = P.label "" $ do let allowInstance = opts ^. funAllowInstance allowOmitType = opts ^. funAllowOmitType _funLhsTerminating <- optional (kw kwTerminating) @@ -1304,7 +1307,6 @@ functionDefinitionLhs opts = P.label "" $ do parseFailure off0 "expected: instance" _funLhsName <- symbol _funLhsArgs <- many parseArg - _funLhsAfterLastArgOff <- P.getOffset _funLhsColonKw <- Irrelevant <$> if @@ -1317,8 +1319,8 @@ functionDefinitionLhs opts = P.label "" $ do return FunctionLhs { _funLhsInstance, + _funLhsBuiltin, _funLhsCoercion, - _funLhsAfterLastArgOff, _funLhsName, _funLhsArgs, _funLhsColonKw, @@ -1373,7 +1375,8 @@ functionDefinition :: Maybe (WithLoc BuiltinFunction) -> ParsecS r (FunctionDef 'Parsed) functionDefinition opts _signBuiltin = P.label "" $ do - FunctionLhs {..} <- functionDefinitionLhs opts + FunctionLhs {..} <- functionDefinitionLhs opts _signBuiltin + off <- P.getOffset _signDoc <- getJudoc _signPragmas <- getPragmas _signBody <- parseBody @@ -1381,7 +1384,7 @@ functionDefinition opts _signBuiltin = P.label "" $ do ( isJust (_funLhsColonKw ^. unIrrelevant) || (P.isBodyExpression _signBody && null _funLhsArgs) ) - $ parseFailure _funLhsAfterLastArgOff "expected result type" + $ parseFailure off "expected result type" return FunctionDef { _signName = _funLhsName, @@ -1391,7 +1394,10 @@ functionDefinition opts _signBuiltin = P.label "" $ do _signTerminating = _funLhsTerminating, _signInstance = _funLhsInstance, _signCoercion = _funLhsCoercion, - .. + _signBuiltin = _funLhsBuiltin, + _signDoc, + _signPragmas, + _signBody } where parseBody :: ParsecS r (FunctionDefBody 'Parsed) @@ -1464,17 +1470,13 @@ functionParams = P.label "" $ do (openDelim, _paramNames, _paramImplicit, _paramColon) <- P.try $ do (opn, impl) <- implicitOpen -- checking that there is a : and not a := is needed to give a better error for missing @ in named application. - let kwColon' :: ParsecS r KeywordRef = - do - P.notFollowedBy (kw kwAssign) - kw kwColon case impl of ImplicitInstance -> do - n <- pName <* kwColon' + n <- pName <* kw kwColon return (opn, [n], impl, Irrelevant Nothing) _ -> do n <- some pName - c <- Irrelevant . Just <$> kwColon' + c <- Irrelevant . Just <$> kw kwColon return (opn, n, impl, c) _paramType <- parseExpressionAtoms closeDelim <- implicitClose _paramImplicit @@ -1633,8 +1635,8 @@ patternAtomWildcardConstructor = P.try $ do -- | Used to report better errors when the user forgets the @ on a named -- application. It tries to parse the lhs of a function definition (up to the -- :=). If it succeeds, it reports an error. -checkNoNamedApplication :: forall r. (Members '[ParserResultBuilder, PragmasStash, Error ParserError, JudocStash] r) => ParsecS r () -checkNoNamedApplication = recoverStashes $ do +checkNoNamedApplicationMissingAt :: forall r. (Members '[ParserResultBuilder, PragmasStash, Error ParserError, JudocStash] r) => ParsecS r () +checkNoNamedApplicationMissingAt = recoverStashes $ do let funSyntax = FunctionSyntaxOptions { _funAllowOmitType = True, @@ -1644,15 +1646,21 @@ checkNoNamedApplication = recoverStashes $ do P.observing . P.try . interval - $ lbrace >> functionDefinitionLhs funSyntax <* kw kwAssign + $ do + fun <- symbol + lbrace + lhs <- functionDefinitionLhs funSyntax Nothing + kw kwAssign + return (fun, lhs) case x of Left {} -> return () - Right (lhs, loc) -> + Right ((fun, lhs), loc) -> P.lift . throw $ ErrNamedApplicationMissingAt NamedApplicationMissingAt { _namedApplicationMissingAtLoc = loc, - _namedApplicationMissingAtLhs = lhs + _namedApplicationMissingAtLhs = lhs, + _namedApplicationMissingAtFun = fun } patternAtomAnon :: (Members '[ParserResultBuilder, PragmasStash, Error ParserError, JudocStash] r) => ParsecS r (PatternAtom 'Parsed) diff --git a/src/Juvix/Data/CodeAnn.hs b/src/Juvix/Data/CodeAnn.hs index 37cfb4f358..01225bc041 100644 --- a/src/Juvix/Data/CodeAnn.hs +++ b/src/Juvix/Data/CodeAnn.hs @@ -245,7 +245,7 @@ kwDot :: Doc Ann kwDot = delimiter "." kwAt :: Doc Ann -kwAt = delimiter Str.at_ +kwAt = keyword Str.at_ code :: Doc Ann -> Doc Ann code = annotate AnnCode diff --git a/src/Juvix/Parser/Error.hs b/src/Juvix/Parser/Error.hs index 1eb8ea58ff..a59d1ae607 100644 --- a/src/Juvix/Parser/Error.hs +++ b/src/Juvix/Parser/Error.hs @@ -205,20 +205,30 @@ instance ToGenericError DanglingJudoc where data NamedApplicationMissingAt = NamedApplicationMissingAt { _namedApplicationMissingAtLoc :: Interval, - _namedApplicationMissingAtLhs :: FunctionLhs + _namedApplicationMissingAtFun :: Symbol, + _namedApplicationMissingAtLhs :: FunctionLhs 'Parsed } instance ToGenericError NamedApplicationMissingAt where genericError NamedApplicationMissingAt {..} = do - let lhs :: FunctionLhs = _namedApplicationMissingAtLhs - let funWord :: Text + opts <- fromGenericOptions <$> ask @GenericOptions + let lhs :: FunctionLhs 'Parsed = _namedApplicationMissingAtLhs + funWord :: Text | null (lhs ^. funLhsArgs) = "assignment" | otherwise = "function definition" - - let msg = + fun' = ppCode opts _namedApplicationMissingAtFun + msg :: Doc CodeAnn = "Unexpected " - <> funWord - <> ".\nPerhaps you intended to use the @{ .. } syntax for named applications?" + <> pretty funWord + <+> ppCode opts _namedApplicationMissingAtLhs + <+> kwAssign + <> "\nPerhaps you intended to write a named application and missed the" + <+> kwAt + <+> "symbol? That would be something like" + <> line + <> fun' + <> kwAt + <> "{arg1 := ...; arg2 := ...; ... }" return GenericError { _genericErrorLoc = i,