From 73e2cf0fa88e1d508442907751140d7e8985fd9e Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Fri, 8 Sep 2023 17:22:21 +0200 Subject: [PATCH] Small refactor for traits (#2345) This pr simplifies parsing by removing `FunctionParameterUnnamed`. It also removes ghost wildcards introduced during parsing. It also introduces an error for double braced atoms `{{x}}` that are not on the left of an arrow `->` --- .../Concrete/Data/NameSignature/Builder.hs | 1 - src/Juvix/Compiler/Concrete/Language.hs | 41 ++++++++++-- src/Juvix/Compiler/Concrete/Print/Base.hs | 13 ++-- .../FromParsed/Analysis/Scoping.hs | 35 ++++++---- .../FromParsed/Analysis/Scoping/Error.hs | 2 + .../Analysis/Scoping/Error/Types.hs | 28 ++++++++ .../Concrete/Translation/FromSource.hs | 67 ++++++++----------- .../Internal/Translation/FromConcrete.hs | 45 +++++++------ .../FromConcrete/NamedArguments.hs | 21 ++++-- test/Scope/Negative.hs | 7 ++ .../Internal/DanglingDoubleBrace.juvix | 3 + tests/positive/Format.juvix | 54 ++++++++++++++- 12 files changed, 226 insertions(+), 91 deletions(-) create mode 100644 tests/negative/Internal/DanglingDoubleBrace.juvix diff --git a/src/Juvix/Compiler/Concrete/Data/NameSignature/Builder.hs b/src/Juvix/Compiler/Concrete/Data/NameSignature/Builder.hs index 817492e8f..fc8837033 100644 --- a/src/Juvix/Compiler/Concrete/Data/NameSignature/Builder.hs +++ b/src/Juvix/Compiler/Concrete/Data/NameSignature/Builder.hs @@ -123,7 +123,6 @@ addAtoms atoms = addAtom . (^. expressionAtoms . _head1) $ atoms addParameter = \case FunctionParameterName s -> addSymbol _paramImplicit s FunctionParameterWildcard {} -> endBuild - FunctionParameterUnnamed {} -> endBuild addInductiveParams' :: (Members '[NameSignatureBuilder] r) => IsImplicit -> InductiveParameters 'Parsed -> Sem r () addInductiveParams' i a = forM_ (a ^. inductiveParametersNames) (addSymbol i) diff --git a/src/Juvix/Compiler/Concrete/Language.hs b/src/Juvix/Compiler/Concrete/Language.hs index 30b7355e0..2dc9e64b9 100644 --- a/src/Juvix/Compiler/Concrete/Language.hs +++ b/src/Juvix/Compiler/Concrete/Language.hs @@ -342,7 +342,8 @@ instance HasLoc IteratorSyntaxDef where data SigArg (s :: Stage) = SigArg { _sigArgDelims :: Irrelevant (KeywordRef, KeywordRef), _sigArgImplicit :: IsImplicit, - _sigArgNames :: NonEmpty (Argument s), + -- | Allowed to be empty only for Instance arguments + _sigArgNames :: [Argument s], _sigArgColon :: Maybe (Irrelevant KeywordRef), -- | The type is only optional for implicit arguments. Omitting the rhs is -- equivalent to writing `: Type`. @@ -1069,19 +1070,34 @@ data Expression | ExpressionRecordUpdate RecordUpdateApp | ExpressionParensRecordUpdate ParensRecordUpdate | ExpressionBraces (WithLoc Expression) - | ExpressionDoubleBraces (WithLoc Expression) + | ExpressionDoubleBraces (DoubleBracesExpression 'Scoped) | ExpressionIterator (Iterator 'Scoped) | ExpressionNamedApplication (NamedApplication 'Scoped) deriving stock (Show, Eq, Ord) +data DoubleBracesExpression (s :: Stage) = DoubleBracesExpression + { _doubleBracesExpression :: ExpressionType s, + _doubleBracesDelims :: Irrelevant (KeywordRef, KeywordRef) + } + +deriving stock instance Show (DoubleBracesExpression 'Parsed) + +deriving stock instance Show (DoubleBracesExpression 'Scoped) + +deriving stock instance Eq (DoubleBracesExpression 'Parsed) + +deriving stock instance Eq (DoubleBracesExpression 'Scoped) + +deriving stock instance Ord (DoubleBracesExpression 'Parsed) + +deriving stock instance Ord (DoubleBracesExpression 'Scoped) + instance HasAtomicity (Lambda s) where atomicity = const Atom data FunctionParameter (s :: Stage) = FunctionParameterName (SymbolType s) | FunctionParameterWildcard KeywordRef - | -- | Used for traits - FunctionParameterUnnamed Interval deriving stock instance Show (FunctionParameter 'Parsed) @@ -1443,7 +1459,7 @@ data ExpressionAtom (s :: Stage) | AtomList (List s) | AtomCase (Case s) | AtomHole (HoleType s) - | AtomDoubleBraces (WithLoc (ExpressionType s)) + | AtomDoubleBraces (DoubleBracesExpression s) | AtomBraces (WithLoc (ExpressionType s)) | AtomLet (Let s) | AtomRecordUpdate (RecordUpdate s) @@ -1607,6 +1623,7 @@ newtype ModuleIndex = ModuleIndex } makeLenses ''PatternArg +makeLenses ''DoubleBracesExpression makeLenses ''Alias makeLenses ''FieldPun makeLenses ''RecordPatternAssign @@ -1753,7 +1770,10 @@ instance HasAtomicity (PatternAtom 'Parsed) where instance (SingI s) => HasAtomicity (FunctionParameters s) where atomicity p - | not (null (p ^. paramNames)) || p ^. paramImplicit == Implicit = Atom + | not (null (p ^. paramNames)) + || p ^. paramImplicit == Implicit + || p ^. paramImplicit == ImplicitInstance = + Atom | otherwise = case sing :: SStage s of SParsed -> atomicity (p ^. paramType) SScoped -> atomicity (p ^. paramType) @@ -1819,7 +1839,6 @@ instance HasLoc (FunctionParameter 'Scoped) where getLoc = \case FunctionParameterName n -> getLoc n FunctionParameterWildcard w -> getLoc w - FunctionParameterUnnamed i -> i instance HasLoc (FunctionParameters 'Scoped) where getLoc p = case p ^. paramDelims . unIrrelevant of @@ -1856,6 +1875,14 @@ instance HasLoc RecordUpdateApp where instance HasLoc ParensRecordUpdate where getLoc = getLoc . (^. parensRecordUpdate) +instance HasLoc (DoubleBracesExpression s) where + getLoc DoubleBracesExpression {..} = + let (l, r) = _doubleBracesDelims ^. unIrrelevant + in getLoc l <> getLoc r + +instance HasAtomicity (DoubleBracesExpression s) where + atomicity = const Atom + instance HasLoc Expression where getLoc = \case ExpressionIdentifier i -> getLoc i diff --git a/src/Juvix/Compiler/Concrete/Print/Base.hs b/src/Juvix/Compiler/Concrete/Print/Base.hs index cf6bb7ebe..5179c4724 100644 --- a/src/Juvix/Compiler/Concrete/Print/Base.hs +++ b/src/Juvix/Compiler/Concrete/Print/Base.hs @@ -301,6 +301,11 @@ instance (SingI s) => PrettyPrint (RecordUpdate s) where <> fields' <> ppCode r +instance (SingI s) => PrettyPrint (DoubleBracesExpression s) where + ppCode DoubleBracesExpression {..} = do + let (l, r) = _doubleBracesDelims ^. unIrrelevant + ppCode l <> ppExpressionType _doubleBracesExpression <> ppCode r + instance (SingI s) => PrettyPrint (ExpressionAtom s) where ppCode = \case AtomIdentifier n -> ppIdentifierType n @@ -314,7 +319,7 @@ instance (SingI s) => PrettyPrint (ExpressionAtom s) where AtomLiteral lit -> ppCode lit AtomFunArrow a -> ppCode a AtomParens e -> parens (ppExpressionType e) - AtomDoubleBraces e -> doubleBraces (ppExpressionType (e ^. withLocParam)) + AtomDoubleBraces e -> ppCode e AtomBraces e -> braces (ppExpressionType (e ^. withLocParam)) AtomHole w -> ppHoleType w AtomIterator i -> ppCode i @@ -520,7 +525,8 @@ instance (SingI s) => PrettyPrint (FunctionParameters s) where ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => FunctionParameters s -> Sem r () ppCode FunctionParameters {..} = do case _paramNames of - [] -> ppLeftExpression' funFixity _paramType + [] + | _paramImplicit == Explicit -> ppLeftExpression' funFixity _paramType _ -> do let paramNames' = map ppCode _paramNames paramType' = ppExpressionType _paramType @@ -539,7 +545,6 @@ instance (SingI s) => PrettyPrint (FunctionParameter s) where ppCode = \case FunctionParameterName n -> annDef n (ppSymbolType n) FunctionParameterWildcard w -> ppCode w - FunctionParameterUnnamed {} -> return () instance (SingI s) => PrettyPrint (Function s) where ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => Function s -> Sem r () @@ -658,7 +663,7 @@ instance PrettyPrint Expression where ExpressionInstanceHole w -> ppCode w ExpressionParensIdentifier n -> parens (ppCode n) ExpressionBraces b -> braces (ppCode b) - ExpressionDoubleBraces b -> doubleBraces (ppCode b) + ExpressionDoubleBraces b -> ppCode b ExpressionApplication a -> ppCode a ExpressionList a -> ppCode a ExpressionInfixApplication a -> ppCode a diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs index 11a0cb43a..6ee2d302a 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs @@ -1633,7 +1633,6 @@ checkFunction f = do _paramNames <- forM (f ^. funParameters . paramNames) $ \case FunctionParameterWildcard w -> return (FunctionParameterWildcard w) FunctionParameterName p -> FunctionParameterName <$> bindVariableSymbol p - FunctionParameterUnnamed i -> return (FunctionParameterUnnamed i) _funReturn <- checkParseExpressionAtoms (f ^. funReturn) let _paramImplicit = f ^. funParameters . paramImplicit _paramColon = f ^. funParameters . paramColon @@ -2024,7 +2023,7 @@ checkExpressionAtom e = case e of AtomUniverse uni -> return (pure (AtomUniverse uni)) AtomFunction fun -> pure . AtomFunction <$> checkFunction fun AtomParens par -> pure . AtomParens <$> checkParens par - AtomDoubleBraces br -> pure . AtomDoubleBraces <$> traverseOf withLocParam checkParseExpressionAtoms br + AtomDoubleBraces br -> pure . AtomDoubleBraces <$> traverseOf doubleBracesExpression checkParseExpressionAtoms br AtomBraces br -> pure . AtomBraces <$> traverseOf withLocParam checkParseExpressionAtoms br AtomFunArrow a -> return (pure (AtomFunArrow a)) AtomHole h -> pure . AtomHole <$> checkHole h @@ -2443,23 +2442,31 @@ makeExpressionTable (ExpressionAtoms atoms _) = [recordUpdate] : [appOpExplicit] getArrow = \case AtomFunArrow r -> return r _ -> Nothing + nonDepFun :: KeywordRef -> Expression -> Expression -> Expression - nonDepFun _funKw a b = + nonDepFun _funKw l r = ExpressionFunction Function - { _funParameters = param, - _funReturn = b, + { _funParameters = params, + _funReturn = r, _funKw } where - param = - FunctionParameters - { _paramNames = [], - _paramDelims = Irrelevant Nothing, - _paramColon = Irrelevant Nothing, - _paramImplicit = Explicit, - _paramType = a - } + params = + let (l', explicitOrInstance, delims') = case l of + ExpressionDoubleBraces i -> + ( i ^. doubleBracesExpression, + ImplicitInstance, + Just (i ^. doubleBracesDelims . unIrrelevant) + ) + _ -> (l, Explicit, Nothing) + in FunctionParameters + { _paramNames = [], + _paramDelims = Irrelevant delims', + _paramColon = Irrelevant Nothing, + _paramImplicit = explicitOrInstance, + _paramType = l' + } parseExpressionAtoms :: forall r. @@ -2604,7 +2611,7 @@ parseTerm = parseDoubleBraces :: Parse Expression parseDoubleBraces = ExpressionDoubleBraces <$> P.token bracedExpr mempty where - bracedExpr :: ExpressionAtom 'Scoped -> Maybe (WithLoc Expression) + bracedExpr :: ExpressionAtom 'Scoped -> Maybe (DoubleBracesExpression 'Scoped) bracedExpr = \case AtomDoubleBraces l -> Just l _ -> Nothing diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error.hs index c791f06ae..5ccfc4739 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error.hs @@ -14,6 +14,7 @@ import Juvix.Compiler.Internal.Translation.FromConcrete.NamedArguments.Error data ScoperError = ErrInfixParser InfixError | ErrAppLeftImplicit AppLeftImplicit + | ErrDanglingDoubleBrace DanglingDoubleBrace | ErrInfixPattern InfixErrorP | ErrMultipleDeclarations MultipleDeclarations | ErrImportCycle ImportCycle @@ -53,6 +54,7 @@ instance ToGenericError ScoperError where ErrCaseBranchImplicitPattern e -> genericError e ErrInfixParser e -> genericError e ErrAppLeftImplicit e -> genericError e + ErrDanglingDoubleBrace e -> genericError e ErrInfixPattern e -> genericError e ErrMultipleDeclarations e -> genericError e ErrImportCycle e -> genericError e diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs index dd068213c..ea5de5701 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs @@ -312,6 +312,34 @@ instance ToGenericError AppLeftImplicit where <> line <> "It needs to be the argument of a function expecting an implicit argument." +newtype DanglingDoubleBrace = DanglingDoubleBrace + { _danglingDoubleBrace :: DoubleBracesExpression 'Scoped + } + deriving stock (Show) + +makeLenses ''DanglingDoubleBrace + +instance ToGenericError DanglingDoubleBrace where + genericError e = ask >>= generr + where + generr opts = + return + GenericError + { _genericErrorLoc = i, + _genericErrorMessage = prettyError msg, + _genericErrorIntervals = [i] + } + where + opts' = fromGenericOptions opts + expr = e ^. danglingDoubleBrace + i = getLoc expr + msg = + "The expression" + <+> ppCode opts' expr + <+> "cannot appear by itself." + <> line + <> "It needs to be on the left of a function arrow." + newtype ModuleNotInScope = ModuleNotInScope { _moduleNotInScopeName :: Name } diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs index 19b3611d0..d6655e4ad 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs @@ -612,11 +612,12 @@ expressionAtom = <|> AtomUniverse <$> universe <|> AtomLambda <$> lambda <|> AtomCase <$> case_ - <|> either AtomFunction AtomDoubleBraces <$> functionOrDoubleBraces + <|> AtomFunction <$> function <|> AtomLet <$> letBlock <|> AtomFunArrow <$> kw kwRightArrow <|> AtomHole <$> hole <|> AtomParens <$> parens parseExpressionAtoms + <|> AtomDoubleBraces <$> pdoubleBracesExpression <|> AtomBraces <$> withLoc (braces parseExpressionAtoms) <|> AtomRecordUpdate <$> recordUpdate @@ -627,6 +628,19 @@ parseExpressionAtoms = do (_expressionAtoms, _expressionAtomsLoc) <- second Irrelevant <$> interval (P.some expressionAtom) return ExpressionAtoms {..} +pdoubleBracesExpression :: + (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => + ParsecS r (DoubleBracesExpression 'Parsed) +pdoubleBracesExpression = do + l <- kw delimDoubleBraceL + _doubleBracesExpression <- parseExpressionAtoms + r <- kw delimDoubleBraceR + return + DoubleBracesExpression + { _doubleBracesDelims = Irrelevant (l, r), + .. + } + -------------------------------------------------------------------------------- -- Iterators -------------------------------------------------------------------------------- @@ -919,22 +933,22 @@ functionDefinition _signBuiltin = P.label "" $ do let parseArgumentName :: ParsecS r (Argument 'Parsed) = ArgumentSymbol <$> symbol <|> ArgumentWildcard <$> wildcard - let parseArgumentNameColon :: ParsecS r (Argument 'Parsed, Maybe (Irrelevant KeywordRef)) = P.try $ do + let parseArgumentNameColon :: ParsecS r (Argument 'Parsed, Irrelevant KeywordRef) = P.try $ do n <- parseArgumentName - c <- Just . Irrelevant <$> kw kwColon + c <- Irrelevant <$> kw kwColon return (n, c) (ns, c) <- case impl of - ImplicitInstance -> - first NonEmpty.singleton - <$> ( parseArgumentNameColon - <|> return (ArgumentWildcard (Wildcard (getLoc opn)), Nothing) - ) + ImplicitInstance -> do + ma <- optional parseArgumentNameColon + return $ case ma of + Just (ns', c') -> ([ns'], Just c') + Nothing -> ([], Nothing) Implicit -> do - ns <- some1 parseArgumentName + ns <- some parseArgumentName c <- optional (Irrelevant <$> kw kwColon) return (ns, c) Explicit -> do - ns <- some1 parseArgumentName + ns <- some parseArgumentName c <- Just . Irrelevant <$> kw kwColon return (ns, c) return (opn, ns, impl, c) @@ -1002,8 +1016,8 @@ functionParams = do (opn, impl) <- implicitOpen case impl of ImplicitInstance -> do - n <- optional pNameColon - return (opn, [fromMaybe (FunctionParameterUnnamed (getLoc opn)) n], impl, Irrelevant Nothing) + n <- pName <* kw kwColon + return (opn, [n], impl, Irrelevant Nothing) _ -> do n <- some pName c <- Irrelevant . Just <$> kw kwColon @@ -1018,36 +1032,13 @@ functionParams = do FunctionParameterName <$> symbol <|> FunctionParameterWildcard <$> kw kwWildcard - pNameColon :: ParsecS r (FunctionParameter 'Parsed) - pNameColon = P.try $ do - n <- pName - kw kwColon - return n - -functionOrDoubleBraces :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (Either (Function 'Parsed) (WithLoc (ExpressionAtoms 'Parsed))) -functionOrDoubleBraces = do - params <- functionParams - (Left <$> function params) <|> (Right <$> atomDoubleBraces params) - -function :: - (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => - FunctionParameters 'Parsed -> - ParsecS r (Function 'Parsed) -function _funParameters = do +function :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (Function 'Parsed) +function = do + _funParameters <- functionParams _funKw <- kw kwRightArrow _funReturn <- parseExpressionAtoms return Function {..} -atomDoubleBraces :: - FunctionParameters 'Parsed -> - ParsecS r (WithLoc (ExpressionAtoms 'Parsed)) -atomDoubleBraces FunctionParameters {..} - | _paramImplicit == ImplicitInstance && isNothing (_paramColon ^. unIrrelevant) = do - return $ WithLoc (getLoc _paramType) _paramType - | otherwise = do - off <- P.getOffset - parseFailure off "Expected: ->" - -------------------------------------------------------------------------------- -- Lambda expression -------------------------------------------------------------------------------- diff --git a/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs b/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs index b06bb0ae6..5ac941229 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs @@ -12,7 +12,6 @@ where import Data.HashMap.Strict qualified as HashMap import Data.IntMap.Strict qualified as IntMap -import Data.List.NonEmpty qualified as NonEmpty import Juvix.Compiler.Builtins import Juvix.Compiler.Concrete.Data.NameSignature.Base import Juvix.Compiler.Concrete.Data.ScopedName qualified as S @@ -466,29 +465,34 @@ goTopFunctionDef FunctionDef {..} = do _paramType <- case _sigArgType of Nothing -> return (Internal.smallUniverseE (getLoc a)) Just ty -> goExpression ty + let _paramImpligoExpressioncit = _sigArgImplicit - mk :: Concrete.Argument 'Scoped -> Sem r Internal.FunctionParameter - mk = \case - Concrete.ArgumentSymbol s -> - let _paramName = Just (goSymbol s) - in return Internal.FunctionParameter {..} - Concrete.ArgumentWildcard {} -> - return Internal.FunctionParameter {_paramName = Nothing, ..} - mapM mk _sigArgNames + noName = Internal.FunctionParameter {_paramName = Nothing, ..} + mk :: Concrete.Argument 'Scoped -> Internal.FunctionParameter + mk ma = + let _paramName = + case ma of + Concrete.ArgumentSymbol s -> Just (goSymbol s) + Concrete.ArgumentWildcard {} -> Nothing + in Internal.FunctionParameter {..} + + return . fromMaybe (pure noName) $ nonEmpty (mk <$> _sigArgNames) argToPattern :: SigArg 'Scoped -> Sem r (NonEmpty Internal.PatternArg) - argToPattern SigArg {..} = do + argToPattern arg@SigArg {..} = do let _patternArgIsImplicit = _sigArgImplicit _patternArgName :: Maybe Internal.Name = Nothing + noName = goWidlcard (Wildcard (getLoc arg)) + goWidlcard w = do + _patternArgPattern <- Internal.PatternVariable <$> varFromWildcard w + return Internal.PatternArg {..} mk :: Concrete.Argument 'Scoped -> Sem r Internal.PatternArg mk = \case Concrete.ArgumentSymbol s -> let _patternArgPattern = Internal.PatternVariable (goSymbol s) in return Internal.PatternArg {..} - Concrete.ArgumentWildcard w -> do - _patternArgPattern <- Internal.PatternVariable <$> varFromWildcard w - return Internal.PatternArg {..} - mapM mk _sigArgNames + Concrete.ArgumentWildcard w -> goWidlcard w + maybe (pure <$> noName) (mapM mk) (nonEmpty _sigArgNames) goExamples :: forall r. @@ -745,7 +749,7 @@ goExpression = \case ExpressionLiteral l -> return (Internal.ExpressionLiteral (goLiteral l)) ExpressionLambda l -> Internal.ExpressionLambda <$> goLambda l ExpressionBraces b -> throw (ErrAppLeftImplicit (AppLeftImplicit b)) - ExpressionDoubleBraces b -> throw (ErrAppLeftImplicit (AppLeftImplicit b)) + ExpressionDoubleBraces b -> throw (ErrDanglingDoubleBrace (DanglingDoubleBrace b)) ExpressionLet l -> goLet l ExpressionList l -> goList l ExpressionUniverse uni -> return (Internal.ExpressionUniverse (goUniverse uni)) @@ -889,7 +893,7 @@ goExpression = \case where (r, i) = case arg of ExpressionBraces b -> (b ^. withLocParam, Implicit) - ExpressionDoubleBraces b -> (b ^. withLocParam, ImplicitInstance) + ExpressionDoubleBraces b -> (b ^. doubleBracesExpression, ImplicitInstance) _ -> (arg, Explicit) goPostfix :: PostfixApplication -> Sem r Internal.Application @@ -968,11 +972,13 @@ goUniverse u goFunction :: (Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r) => Function 'Scoped -> Sem r Internal.Function goFunction f = do - params <- goFunctionParameters (f ^. funParameters) + headParam :| tailParams <- goFunctionParameters (f ^. funParameters) ret <- goExpression (f ^. funReturn) return $ - Internal.Function (head params) $ - foldr (\param acc -> Internal.ExpressionFunction $ Internal.Function param acc) ret (NonEmpty.tail params) + Internal.Function + { _functionLeft = headParam, + _functionRight = foldr (\param acc -> Internal.ExpressionFunction $ Internal.Function param acc) ret tailParams + } goFunctionParameters :: (Members '[Builtins, NameIdGen, Error ScoperError, Reader Pragmas] r) => @@ -997,7 +1003,6 @@ goFunctionParameters FunctionParameters {..} = do goFunctionParameter = \case FunctionParameterName n -> Just n FunctionParameterWildcard {} -> Nothing - FunctionParameterUnnamed {} -> Nothing mkConstructorApp :: Internal.ConstrName -> [Internal.PatternArg] -> Internal.ConstructorApp mkConstructorApp a b = Internal.ConstructorApp a b Nothing diff --git a/src/Juvix/Compiler/Internal/Translation/FromConcrete/NamedArguments.hs b/src/Juvix/Compiler/Internal/Translation/FromConcrete/NamedArguments.hs index 6aa81eedf..d9271704f 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromConcrete/NamedArguments.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromConcrete/NamedArguments.hs @@ -6,6 +6,8 @@ where import Data.HashMap.Strict qualified as HashMap import Data.IntMap.Strict qualified as IntMap import Juvix.Compiler.Concrete.Data.NameSignature.Base +import Juvix.Compiler.Concrete.Gen qualified as Gen +import Juvix.Compiler.Concrete.Keywords import Juvix.Compiler.Concrete.Language import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error import Juvix.Prelude @@ -130,14 +132,14 @@ helper loc = do missingErr :: NonEmpty Symbol -> Sem r () missingErr = throw . ErrMissingArguments . MissingArguments loc - emitImplicit' :: + emitImplicitHelper :: (WithLoc Expression -> Expression) -> (HoleType 'Scoped -> Expression) -> Bool -> HashMap Symbol Int -> IntMap Expression -> Sem r () - emitImplicit' exprBraces exprHole lastBlock omittedArgs args = go 0 (IntMap.toAscList args) + emitImplicitHelper exprBraces exprHole lastBlock omittedArgs args = go 0 (IntMap.toAscList args) where go :: Int -> [(Int, Expression)] -> Sem r () go n = \case @@ -156,10 +158,21 @@ helper loc = do maxIx = fmap maximum1 . nonEmpty . toList $ omittedArgs emitImplicit :: Bool -> HashMap Symbol Int -> IntMap Expression -> Sem r () - emitImplicit = emitImplicit' ExpressionBraces ExpressionHole + emitImplicit = emitImplicitHelper ExpressionBraces ExpressionHole emitImplicitInstance :: Bool -> HashMap Symbol Int -> IntMap Expression -> Sem r () - emitImplicitInstance = emitImplicit' ExpressionDoubleBraces ExpressionInstanceHole + emitImplicitInstance = emitImplicitHelper mkDoubleBraces ExpressionInstanceHole + where + mkDoubleBraces :: WithLoc Expression -> Expression + mkDoubleBraces (WithLoc eloc e) = run . runReader eloc $ do + l <- Gen.kw delimDoubleBraceL + r <- Gen.kw delimDoubleBraceR + return $ + ExpressionDoubleBraces + DoubleBracesExpression + { _doubleBracesExpression = e, + _doubleBracesDelims = Irrelevant (l, r) + } scanGroup :: IsImplicit -> diff --git a/test/Scope/Negative.hs b/test/Scope/Negative.hs index 7bb4e8691..c74883741 100644 --- a/test/Scope/Negative.hs +++ b/test/Scope/Negative.hs @@ -329,5 +329,12 @@ scoperErrorTests = $(mkRelFile "AliasCycle.juvix") $ \case ErrAliasCycle {} -> Nothing + _ -> wrongError, + NegTest + "Dangling double brace" + $(mkRelDir "Internal") + $(mkRelFile "DanglingDoubleBrace.juvix") + $ \case + ErrDanglingDoubleBrace {} -> Nothing _ -> wrongError ] diff --git a/tests/negative/Internal/DanglingDoubleBrace.juvix b/tests/negative/Internal/DanglingDoubleBrace.juvix new file mode 100644 index 000000000..3b207bd1a --- /dev/null +++ b/tests/negative/Internal/DanglingDoubleBrace.juvix @@ -0,0 +1,3 @@ +module DanglingDoubleBrace; + +id {A} : A -> {{A}} := A; diff --git a/tests/positive/Format.juvix b/tests/positive/Format.juvix index 6e2aa0409..bbb53e010 100644 --- a/tests/positive/Format.juvix +++ b/tests/positive/Format.juvix @@ -10,7 +10,7 @@ hiding -- Hide some names {-- like this ,; -- don't want , here -- Bool either -Bool; true; false}; +Bool; true; false; mkShow}; import Stdlib.Data.Nat.Ord open; @@ -171,8 +171,6 @@ module Patterns; | (a, b, c, d) := a; end; -import Stdlib.Prelude open using {Nat as Natural}; - module UnicodeStrings; a : String := "λ"; end; @@ -237,4 +235,54 @@ module Comments; type list (A : Type) : Type := cons A (list A); end; +--- Traits +module Traits; + import Stdlib.Prelude open hiding {Show; mkShow; show}; + + trait + type Show A := mkShow {show : A → String}; + + instance + showStringI : Show String := mkShow (show := id); + + instance + showBoolI : Show Bool := + mkShow (show := λ {x := if x "true" "false"}); + + instance + showNatI : Show Nat := mkShow (show := natToString); + + showList {A} : {{Show A}} → List A → String + | nil := "nil" + | (h :: t) := Show.show h ++str " :: " ++str showList t; + + g : {A : Type} → {{Show A}} → Nat := 5; + + instance + showListI {A} {{Show A}} : Show (List A) := + mkShow (show := showList); + + showMaybe {A} {{Show A}} : Maybe A → String + | (just x) := "just (" ++str Show.show x ++str ")" + | nothing := "nothing"; + + instance + showMaybeI {A} {{Show A}} : Show (Maybe A) := + mkShow (show := showMaybe); + + f {A} {{Show A}} : A → String + | x := Show.show x; + + f' {A} : {{Show A}} → A → String + | {{mkShow s}} x := s x; + + f'' {A} : {{Show A}} → A → String + | {{M}} x := Show.show {{M}} x; + + f'3 {A} {{M : Show A}} : A → String := Show.show {{M}}; + + f'4 {A} {{_ : Show A}} : A → String := Show.show; + +end; + -- Comment at the end of a module