diff --git a/src/Juvix/Compiler/Concrete/Gen.hs b/src/Juvix/Compiler/Concrete/Gen.hs index 828f67bfeb..0c145247cb 100644 --- a/src/Juvix/Compiler/Concrete/Gen.hs +++ b/src/Juvix/Compiler/Concrete/Gen.hs @@ -67,16 +67,6 @@ smallUniverseExpression = do _expressionAtoms = pure (AtomUniverse (smallUniverse loc)) } -isExhaustive :: (Member (Reader Interval) r) => Bool -> Sem r IsExhaustive -isExhaustive _isExhaustive = do - _isExhaustiveKw <- - Irrelevant - <$> if - | _isExhaustive -> kw kwAt - | otherwise -> kw kwAtQuestion - - return IsExhaustive {..} - symbol :: (Member (Reader Interval) r) => Text -> Sem r Symbol symbol t = do l <- ask @@ -107,25 +97,13 @@ braced a = do l <- ask AtomBraces . WithLoc l <$> expressionAtoms' a -mkIsExhaustive :: (Member (Reader Interval) r) => Bool -> Sem r IsExhaustive -mkIsExhaustive _isExhaustive = do - keyw <- - if - | _isExhaustive -> kw kwAt - | otherwise -> kw kwAtQuestion - return - IsExhaustive - { _isExhaustiveKw = Irrelevant keyw, - _isExhaustive - } - -namedApplication :: Name -> IsExhaustive -> [NamedArgumentNew 'Parsed] -> ExpressionAtom 'Parsed -namedApplication n exh as = - AtomNamedApplicationNew - NamedApplicationNew - { _namedApplicationNewName = n, - _namedApplicationNewExhaustive = exh, - _namedApplicationNewArguments = as +namedApplication :: Name -> Irrelevant KeywordRef -> [NamedArgument 'Parsed] -> ExpressionAtom 'Parsed +namedApplication n kwd as = + AtomNamedApplication + NamedApplication + { _namedApplicationName = n, + _namedApplicationAtKw = kwd, + _namedApplicationArguments = as } literalInteger :: (Member (Reader Interval) r, Integral a) => a -> Sem r (ExpressionAtom 'Parsed) diff --git a/src/Juvix/Compiler/Concrete/Language/Base.hs b/src/Juvix/Compiler/Concrete/Language/Base.hs index 357d393bc9..c61e9c583a 100644 --- a/src/Juvix/Compiler/Concrete/Language/Base.hs +++ b/src/Juvix/Compiler/Concrete/Language/Base.hs @@ -1635,7 +1635,7 @@ data Expression | ExpressionBraces (WithLoc Expression) | ExpressionDoubleBraces (DoubleBracesExpression 'Scoped) | ExpressionIterator (Iterator 'Scoped) - | ExpressionNamedApplicationNew (NamedApplicationNew 'Scoped) + | ExpressionNamedApplication (NamedApplication 'Scoped) deriving stock (Show, Eq, Ord, Generic) instance Serialize Expression @@ -2537,67 +2537,57 @@ deriving stock instance Ord (NamedArgumentPun 'Parsed) deriving stock instance Ord (NamedArgumentPun 'Scoped) -data NamedArgumentNew (s :: Stage) - = NamedArgumentNewFunction (NamedArgumentFunctionDef s) +data NamedArgument (s :: Stage) + = NamedArgumentFunction (NamedArgumentFunctionDef s) | NamedArgumentItemPun (NamedArgumentPun s) deriving stock (Generic) -instance Serialize (NamedArgumentNew 'Scoped) +instance Serialize (NamedArgument 'Scoped) -instance NFData (NamedArgumentNew 'Scoped) +instance NFData (NamedArgument 'Scoped) -instance Serialize (NamedArgumentNew 'Parsed) +instance Serialize (NamedArgument 'Parsed) -instance NFData (NamedArgumentNew 'Parsed) +instance NFData (NamedArgument 'Parsed) -deriving stock instance Show (NamedArgumentNew 'Parsed) +deriving stock instance Show (NamedArgument 'Parsed) -deriving stock instance Show (NamedArgumentNew 'Scoped) +deriving stock instance Show (NamedArgument 'Scoped) -deriving stock instance Eq (NamedArgumentNew 'Parsed) +deriving stock instance Eq (NamedArgument 'Parsed) -deriving stock instance Eq (NamedArgumentNew 'Scoped) +deriving stock instance Eq (NamedArgument 'Scoped) -deriving stock instance Ord (NamedArgumentNew 'Parsed) +deriving stock instance Ord (NamedArgument 'Parsed) -deriving stock instance Ord (NamedArgumentNew 'Scoped) +deriving stock instance Ord (NamedArgument 'Scoped) -data IsExhaustive = IsExhaustive - { _isExhaustive :: Bool, - _isExhaustiveKw :: Irrelevant KeywordRef - } - deriving stock (Eq, Show, Ord, Generic) - -instance Serialize IsExhaustive - -instance NFData IsExhaustive - -data NamedApplicationNew (s :: Stage) = NamedApplicationNew - { _namedApplicationNewName :: IdentifierType s, - _namedApplicationNewExhaustive :: IsExhaustive, - _namedApplicationNewArguments :: [NamedArgumentNew s] +data NamedApplication (s :: Stage) = NamedApplication + { _namedApplicationName :: IdentifierType s, + _namedApplicationAtKw :: Irrelevant KeywordRef, + _namedApplicationArguments :: [NamedArgument s] } deriving stock (Generic) -instance Serialize (NamedApplicationNew 'Scoped) +instance Serialize (NamedApplication 'Scoped) -instance NFData (NamedApplicationNew 'Scoped) +instance NFData (NamedApplication 'Scoped) -instance Serialize (NamedApplicationNew 'Parsed) +instance Serialize (NamedApplication 'Parsed) -instance NFData (NamedApplicationNew 'Parsed) +instance NFData (NamedApplication 'Parsed) -deriving stock instance Show (NamedApplicationNew 'Parsed) +deriving stock instance Show (NamedApplication 'Parsed) -deriving stock instance Show (NamedApplicationNew 'Scoped) +deriving stock instance Show (NamedApplication 'Scoped) -deriving stock instance Eq (NamedApplicationNew 'Parsed) +deriving stock instance Eq (NamedApplication 'Parsed) -deriving stock instance Eq (NamedApplicationNew 'Scoped) +deriving stock instance Eq (NamedApplication 'Scoped) -deriving stock instance Ord (NamedApplicationNew 'Parsed) +deriving stock instance Ord (NamedApplication 'Parsed) -deriving stock instance Ord (NamedApplicationNew 'Scoped) +deriving stock instance Ord (NamedApplication 'Scoped) data RecordSyntaxDef (s :: Stage) = RecordSyntaxOperator (OperatorSyntaxDef s) @@ -2741,7 +2731,7 @@ data ExpressionAtom (s :: Stage) | AtomLiteral LiteralLoc | AtomParens (ExpressionType s) | AtomIterator (Iterator s) - | AtomNamedApplicationNew (NamedApplicationNew s) + | AtomNamedApplication (NamedApplication s) deriving stock (Generic) instance Serialize (ExpressionAtom 'Parsed) @@ -3000,7 +2990,6 @@ makeLenses ''FunctionLhs makeLenses ''Statements makeLenses ''NamedArgumentFunctionDef makeLenses ''NamedArgumentPun -makeLenses ''IsExhaustive makeLenses ''SideIfBranch makeLenses ''RhsExpression makeLenses ''PatternArg @@ -3069,8 +3058,8 @@ makeLenses ''Initializer makeLenses ''Range makeLenses ''ArgumentBlock makeLenses ''NamedArgumentAssign -makeLenses ''NamedArgumentNew -makeLenses ''NamedApplicationNew +makeLenses ''NamedArgument +makeLenses ''NamedApplication makeLenses ''AliasDef makeLenses ''FixitySyntaxDef makeLenses ''ParsedFixityInfo @@ -3083,7 +3072,7 @@ makeLenses ''RecordInfo makeLenses ''MarkdownInfo makeLenses ''Deriving -makePrisms ''NamedArgumentNew +makePrisms ''NamedArgument makePrisms ''ConstructorRhs makePrisms ''FunctionDefNameParsed @@ -3176,7 +3165,7 @@ instance (SingI s) => HasLoc (ArgumentBlock s) where instance HasAtomicity (ArgumentBlock s) where atomicity = const Atom -instance HasAtomicity (NamedApplicationNew s) where +instance HasAtomicity (NamedApplication s) where atomicity = const (Aggregate updateFixity) instance HasAtomicity (Do s) where @@ -3203,7 +3192,7 @@ instance HasAtomicity Expression where ExpressionCase c -> atomicity c ExpressionIf x -> atomicity x ExpressionIterator i -> atomicity i - ExpressionNamedApplicationNew i -> atomicity i + ExpressionNamedApplication i -> atomicity i ExpressionRecordUpdate {} -> Aggregate updateFixity ExpressionParensRecordUpdate {} -> Atom @@ -3414,9 +3403,9 @@ instance HasLoc (List s) where instance (SingI s) => HasLoc (NamedArgumentFunctionDef s) where getLoc (NamedArgumentFunctionDef f) = getLoc f -instance (SingI s) => HasLoc (NamedArgumentNew s) where +instance (SingI s) => HasLoc (NamedArgument s) where getLoc = \case - NamedArgumentNewFunction f -> getLoc f + NamedArgumentFunction f -> getLoc f NamedArgumentItemPun f -> getLoc f instance HasLoc (RecordUpdatePun s) where @@ -3425,8 +3414,8 @@ instance HasLoc (RecordUpdatePun s) where instance HasLoc (NamedArgumentPun s) where getLoc NamedArgumentPun {..} = getLocSymbolType _namedArgumentPunSymbol -instance (SingI s) => HasLoc (NamedApplicationNew s) where - getLoc NamedApplicationNew {..} = getLocIdentifierType _namedApplicationNewName +instance (SingI s) => HasLoc (NamedApplication s) where + getLoc NamedApplication {..} = getLocIdentifierType _namedApplicationName instance (SingI s) => HasLoc (RecordUpdateField s) where getLoc = \case @@ -3478,7 +3467,7 @@ instance HasLoc Expression where ExpressionBraces i -> getLoc i ExpressionDoubleBraces i -> getLoc i ExpressionIterator i -> getLoc i - ExpressionNamedApplicationNew i -> getLoc i + ExpressionNamedApplication i -> getLoc i ExpressionRecordUpdate i -> getLoc i ExpressionParensRecordUpdate i -> getLoc i @@ -3707,7 +3696,7 @@ instance (SingI s) => HasLoc (ExpressionAtom s) where AtomLiteral x -> getLoc x AtomParens x -> getLocExpressionType x AtomIterator x -> getLoc x - AtomNamedApplicationNew x -> getLoc x + AtomNamedApplication x -> getLoc x instance HasLoc (ExpressionAtoms s) where getLoc = getLoc . (^. expressionAtomsLoc) @@ -3769,17 +3758,17 @@ withFunctionSymbol a f sym = case sing :: SStage s of SParsed -> maybe a f (sym ^? _FunctionDefName) SScoped -> f (sym ^. functionDefNameScoped) -namedArgumentNewSymbolParsed :: (SingI s) => SimpleGetter (NamedArgumentNew s) Symbol -namedArgumentNewSymbolParsed = to $ \case +namedArgumentSymbolParsed :: (SingI s) => SimpleGetter (NamedArgument s) Symbol +namedArgumentSymbolParsed = to $ \case NamedArgumentItemPun a -> a ^. namedArgumentPunSymbol - NamedArgumentNewFunction a -> symbolParsed (getFunctionSymbol (a ^. namedArgumentFunctionDef . functionDefName)) + NamedArgumentFunction a -> symbolParsed (getFunctionSymbol (a ^. namedArgumentFunctionDef . functionDefName)) -namedArgumentNewSymbol :: Lens' (NamedArgumentNew 'Parsed) Symbol -namedArgumentNewSymbol f = \case +namedArgumentSymbol :: Lens' (NamedArgument 'Parsed) Symbol +namedArgumentSymbol f = \case NamedArgumentItemPun a -> NamedArgumentItemPun <$> (namedArgumentPunSymbol f a) - NamedArgumentNewFunction a -> do + NamedArgumentFunction a -> do a' <- f (a ^?! namedArgumentFunctionDef . functionDefName . _FunctionDefName) - return $ NamedArgumentNewFunction (over namedArgumentFunctionDef (set functionDefName (FunctionDefName a')) a) + return $ NamedArgumentFunction (over namedArgumentFunctionDef (set functionDefName (FunctionDefName a')) a) scopedIdenSrcName :: Lens' ScopedIden S.Name scopedIdenSrcName f n = case n ^. scopedIdenAlias of diff --git a/src/Juvix/Compiler/Concrete/Language/IsApeInstances.hs b/src/Juvix/Compiler/Concrete/Language/IsApeInstances.hs index 064754798f..2f253b6b23 100644 --- a/src/Juvix/Compiler/Concrete/Language/IsApeInstances.hs +++ b/src/Juvix/Compiler/Concrete/Language/IsApeInstances.hs @@ -81,12 +81,12 @@ instance IsApe Name ApeLeaf where _leafExpr = ApeLeafAtom (sing :&: AtomIdentifier n) } -instance (SingI s) => IsApe (NamedApplicationNew s) ApeLeaf where +instance (SingI s) => IsApe (NamedApplication s) ApeLeaf where toApe a = ApeLeaf $ Leaf { _leafAtomicity = atomicity a, - _leafExpr = ApeLeafAtom (sing :&: AtomNamedApplicationNew a) + _leafExpr = ApeLeafAtom (sing :&: AtomNamedApplication a) } instance IsApe Application ApeLeaf where @@ -144,7 +144,7 @@ instance IsApe Expression ApeLeaf where ExpressionInfixApplication a -> toApe a ExpressionPostfixApplication a -> toApe a ExpressionFunction a -> toApe a - ExpressionNamedApplicationNew a -> toApe a + ExpressionNamedApplication a -> toApe a ExpressionRecordUpdate a -> toApe a ExpressionParensRecordUpdate {} -> leaf ExpressionParensIdentifier {} -> leaf diff --git a/src/Juvix/Compiler/Concrete/Print/Base.hs b/src/Juvix/Compiler/Concrete/Print/Base.hs index 8913d7db27..b240cda263 100644 --- a/src/Juvix/Compiler/Concrete/Print/Base.hs +++ b/src/Juvix/Compiler/Concrete/Print/Base.hs @@ -347,18 +347,15 @@ instance (SingI s) => PrettyPrint (ArgumentBlock s) where where Irrelevant d = _argBlockDelims -instance PrettyPrint IsExhaustive where - ppCode IsExhaustive {..} = ppCode _isExhaustiveKw - -instance (SingI s) => PrettyPrint (NamedApplicationNew s) where - ppCode NamedApplicationNew {..} = do +instance (SingI s) => PrettyPrint (NamedApplication s) where + ppCode NamedApplication {..} = do let args' - | null _namedApplicationNewArguments = mempty - | otherwise = ppBlock _namedApplicationNewArguments + | null _namedApplicationArguments = mempty + | otherwise = ppBlock _namedApplicationArguments grouped ( align - ( ppIdentifierType _namedApplicationNewName - <> ppCode _namedApplicationNewExhaustive + ( ppIdentifierType _namedApplicationName + <> ppCode _namedApplicationAtKw <> braces args' ) ) @@ -372,9 +369,9 @@ instance PrettyPrint (RecordUpdatePun s) where instance PrettyPrint (NamedArgumentPun s) where ppCode = ppCode . (^. namedArgumentPunSymbol) -instance (SingI s) => PrettyPrint (NamedArgumentNew s) where +instance (SingI s) => PrettyPrint (NamedArgument s) where ppCode = \case - NamedArgumentNewFunction f -> ppCode f + NamedArgumentFunction f -> ppCode f NamedArgumentItemPun f -> ppCode f instance (SingI s) => PrettyPrint (RecordSyntaxDef s) where @@ -472,7 +469,7 @@ instance (SingI s) => PrettyPrint (ExpressionAtom s) where AtomHole w -> ppHoleType w AtomInstanceHole w -> ppHoleType w AtomIterator i -> ppIterator NotTop i - AtomNamedApplicationNew i -> ppCode i + AtomNamedApplication i -> ppCode i instance PrettyPrint PatternScopedIden where ppCode = \case @@ -1006,7 +1003,7 @@ instance PrettyPrint Expression where ExpressionCase c -> ppCase NotTop c ExpressionIf c -> ppIf NotTop c ExpressionIterator i -> ppIterator NotTop i - ExpressionNamedApplicationNew i -> ppCode i + ExpressionNamedApplication i -> ppCode i ExpressionRecordUpdate i -> ppCode i ExpressionParensRecordUpdate i -> ppCode i diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs index b847e6ff8a..006144e12a 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs @@ -2911,22 +2911,22 @@ checkExpressionAtom e = case e of AtomLiteral l -> return (pure (AtomLiteral l)) AtomList l -> pure . AtomList <$> checkList l AtomIterator i -> pure . AtomIterator <$> checkIterator i - AtomNamedApplicationNew i -> pure . AtomNamedApplicationNew <$> checkNamedApplicationNew i + AtomNamedApplication i -> pure . AtomNamedApplication <$> checkNamedApplication i AtomRecordUpdate i -> pure . AtomRecordUpdate <$> checkRecordUpdate i -reserveNamedArgumentName :: (Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder, Reader InfoTable] r) => NamedArgumentNew 'Parsed -> Sem r () +reserveNamedArgumentName :: (Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder, Reader InfoTable] r) => NamedArgument 'Parsed -> Sem r () reserveNamedArgumentName a = case a of - NamedArgumentNewFunction f -> reserveFunctionLikeSymbol (f ^. namedArgumentFunctionDef) + NamedArgumentFunction f -> reserveFunctionLikeSymbol (f ^. namedArgumentFunctionDef) NamedArgumentItemPun {} -> return () -checkNamedApplicationNew :: +checkNamedApplication :: forall r. (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => - NamedApplicationNew 'Parsed -> - Sem r (NamedApplicationNew 'Scoped) -checkNamedApplicationNew napp = do - let nargs = napp ^. namedApplicationNewArguments - aname <- checkScopedIden (napp ^. namedApplicationNewName) + NamedApplication 'Parsed -> + Sem r (NamedApplication 'Scoped) +checkNamedApplication napp = do + let nargs = napp ^. namedApplicationArguments + aname <- checkScopedIden (napp ^. namedApplicationName) sig :: NameSignature 'Parsed <- if | null nargs -> return (NameSignature []) @@ -2937,25 +2937,25 @@ checkNamedApplicationNew napp = do ^.. nameSignatureArgs . each . nameBlockSymbols - forM_ nargs (checkNameInSignature namesInSignature . (^. namedArgumentNewSymbol)) - puns <- scopePuns (napp ^.. namedApplicationNewArguments . each . _NamedArgumentItemPun) + forM_ nargs (checkNameInSignature namesInSignature . (^. namedArgumentSymbol)) + puns <- scopePuns (napp ^.. namedApplicationArguments . each . _NamedArgumentItemPun) args' <- withLocalScope . localBindings . ignoreSyntax $ do mapM_ reserveNamedArgumentName nargs - mapM (checkNamedArgumentNew puns) nargs + mapM (checkNamedArgument puns) nargs let signatureExplicitNames = hashSet . concatMap (^.. nameBlockSymbols) . filter (not . isImplicitOrInstance . (^. nameBlockImplicit)) $ sig ^. nameSignatureArgs - givenNames :: HashSet Symbol = hashSet (map (^. namedArgumentNewSymbol) nargs) + givenNames :: HashSet Symbol = hashSet (map (^. namedArgumentSymbol) nargs) missingArgs = HashSet.difference signatureExplicitNames givenNames - unless (null missingArgs || not (napp ^. namedApplicationNewExhaustive . isExhaustive)) $ + unless (null missingArgs) $ throw (ErrMissingArgs (MissingArgs (aname ^. scopedIdenFinal . nameConcrete) missingArgs)) return - NamedApplicationNew - { _namedApplicationNewName = aname, - _namedApplicationNewArguments = args', - _namedApplicationNewExhaustive = napp ^. namedApplicationNewExhaustive + NamedApplication + { _namedApplicationName = aname, + _namedApplicationArguments = args', + _namedApplicationAtKw = napp ^. namedApplicationAtKw } where checkNameInSignature :: HashSet Symbol -> Symbol -> Sem r () @@ -2969,13 +2969,13 @@ checkNamedApplicationNew napp = do scopePun :: Symbol -> Sem r ScopedIden scopePun = checkScopedIden . NameUnqualified -checkNamedArgumentNew :: +checkNamedArgument :: (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader PackageId] r) => HashMap Symbol ScopedIden -> - NamedArgumentNew 'Parsed -> - Sem r (NamedArgumentNew 'Scoped) -checkNamedArgumentNew puns = \case - NamedArgumentNewFunction f -> NamedArgumentNewFunction <$> checkNamedArgumentFunctionDef f + NamedArgument 'Parsed -> + Sem r (NamedArgument 'Scoped) +checkNamedArgument puns = \case + NamedArgumentFunction f -> NamedArgumentFunction <$> checkNamedArgumentFunctionDef f NamedArgumentItemPun f -> return (NamedArgumentItemPun (checkNamedArgumentItemPun puns f)) checkNamedArgumentItemPun :: @@ -3599,11 +3599,11 @@ parseTerm = _ -> Nothing parseNamedApplicationNew :: Parse Expression - parseNamedApplicationNew = ExpressionNamedApplicationNew <$> P.token namedApp mempty + parseNamedApplicationNew = ExpressionNamedApplication <$> P.token namedApp mempty where - namedApp :: ExpressionAtom 'Scoped -> Maybe (NamedApplicationNew 'Scoped) + namedApp :: ExpressionAtom 'Scoped -> Maybe (NamedApplication 'Scoped) namedApp s = case s of - AtomNamedApplicationNew u -> Just u + AtomNamedApplication u -> Just u _ -> Nothing parseLet :: Parse Expression diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs index 19a5003b26..47d485b522 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs @@ -882,7 +882,7 @@ expressionAtom = P.label "" $ AtomLiteral <$> P.try literal <|> AtomIterator <$> iterator - <|> AtomNamedApplicationNew <$> namedApplicationNew + <|> AtomNamedApplication <$> namedApplication <|> AtomList <$> parseList <|> AtomIf <$> multiwayIf <|> AtomIdentifier <$> name @@ -1041,19 +1041,19 @@ pnamedArgumentItemPun = do -- | Parses zero or more named arguments. This function is necessary to avoid -- using excessive backtracking. -manyNamedArgumentNewRBrace :: +manyNamedArgumentRBrace :: forall r. (Members '[ParserResultBuilder, PragmasStash, Error ParserError, JudocStash] r) => - ParsecS r [NamedArgumentNew 'Parsed] -manyNamedArgumentNewRBrace = reverse <$> go [] + ParsecS r [NamedArgument 'Parsed] +manyNamedArgumentRBrace = reverse <$> go [] where - go :: [NamedArgumentNew 'Parsed] -> ParsecS r [NamedArgumentNew 'Parsed] + go :: [NamedArgument 'Parsed] -> ParsecS r [NamedArgument 'Parsed] go acc = rbrace $> acc <|> itemHelper (P.try (withIsLast (NamedArgumentItemPun <$> pnamedArgumentItemPun))) - <|> itemHelper (withIsLast (NamedArgumentNewFunction <$> pnamedArgumentFunctionDef)) + <|> itemHelper (withIsLast (NamedArgumentFunction <$> pnamedArgumentFunctionDef)) where - itemHelper :: ParsecS r (Bool, NamedArgumentNew 'Parsed) -> ParsecS r [NamedArgumentNew 'Parsed] + itemHelper :: ParsecS r (Bool, NamedArgument 'Parsed) -> ParsecS r [NamedArgument 'Parsed] itemHelper p = do (isLast, item) <- p let acc' = item : acc @@ -1072,34 +1072,20 @@ manyNamedArgumentNewRBrace = reverse <$> go [] isLast <- pIsLast return (isLast, res) -pisExhaustive :: - forall r. - (Members '[ParserResultBuilder] r) => - ParsecS r IsExhaustive -pisExhaustive = do - (keyword, exh) <- - (,False) <$> kw kwAtQuestion - <|> (,True) <$> kw kwAt - return - IsExhaustive - { _isExhaustiveKw = Irrelevant keyword, - _isExhaustive = exh - } - -namedApplicationNew :: +namedApplication :: forall r. (Members '[ParserResultBuilder, PragmasStash, Error ParserError, JudocStash] r) => - ParsecS r (NamedApplicationNew 'Parsed) -namedApplicationNew = P.label "" $ do + ParsecS r (NamedApplication 'Parsed) +namedApplication = P.label "" $ do checkNoNamedApplicationMissingAt - (_namedApplicationNewName, _namedApplicationNewExhaustive) <- P.try $ do + (_namedApplicationName, _namedApplicationAtKw) <- P.try $ do n <- name - exhaustive <- pisExhaustive + kwd <- Irrelevant <$> kw kwAt lbrace - return (n, exhaustive) - _namedApplicationNewArguments <- manyNamedArgumentNewRBrace - let _namedApplicationNewExtra = Irrelevant () - return NamedApplicationNew {..} + return (n, kwd) + _namedApplicationArguments <- manyNamedArgumentRBrace + let _namedApplicationExtra = Irrelevant () + return NamedApplication {..} hole :: (Members '[ParserResultBuilder, PragmasStash, Error ParserError, JudocStash] r) => ParsecS r (HoleType 'Parsed) hole = kw kwHole diff --git a/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs b/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs index 505f9678b1..a88d4116af 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs @@ -1309,7 +1309,7 @@ goListPattern l = localBuiltins $ do where loc = getLoc l -createArgumentBlocks :: NonEmpty (NamedArgumentNew 'Scoped) -> [NameBlock 'Scoped] -> NonEmpty (ArgumentBlock 'Scoped) +createArgumentBlocks :: NonEmpty (NamedArgument 'Scoped) -> [NameBlock 'Scoped] -> NonEmpty (ArgumentBlock 'Scoped) createArgumentBlocks appargs = nonEmpty' . run @@ -1317,9 +1317,9 @@ createArgumentBlocks appargs = . evalState args0 . mapM_ goBlock where - namedArgumentRefSymbol :: NamedArgumentNew 'Scoped -> S.Symbol + namedArgumentRefSymbol :: NamedArgument 'Scoped -> S.Symbol namedArgumentRefSymbol = \case - NamedArgumentNewFunction p -> p ^. namedArgumentFunctionDef . functionDefName . functionDefNameScoped + NamedArgumentFunction p -> p ^. namedArgumentFunctionDef . functionDefName . functionDefNameScoped NamedArgumentItemPun p -> over S.nameConcrete fromUnqualified' (p ^. namedArgumentReferencedSymbol . scopedIdenFinal) args0 :: HashSet S.Symbol = hashSet (namedArgumentRefSymbol <$> appargs) goBlock :: @@ -1387,7 +1387,7 @@ goExpression = \case ExpressionHole h -> return (Internal.ExpressionHole h) ExpressionInstanceHole h -> return (Internal.ExpressionInstanceHole (fromHole h)) ExpressionIterator i -> goIterator i - ExpressionNamedApplicationNew i -> goNamedApplicationNew i [] + ExpressionNamedApplication i -> goNamedApplication i [] ExpressionRecordUpdate i -> goRecordUpdateApp i ExpressionParensRecordUpdate i -> Internal.ExpressionLambda <$> goRecordUpdate (i ^. parensRecordUpdate) where @@ -1396,19 +1396,19 @@ goExpression = \case s <- asks (^. S.infoNameSigs) runReader s (runNamedArguments fun blocks extraArgs) >>= goDesugaredNamedApplication - goNamedApplicationNew :: - Concrete.NamedApplicationNew 'Scoped -> + goNamedApplication :: + Concrete.NamedApplication 'Scoped -> [Internal.ApplicationArg] -> Sem r Internal.Expression - goNamedApplicationNew napp extraArgs = case nonEmpty (napp ^. namedApplicationNewArguments) of - Nothing -> return (goIden (napp ^. namedApplicationNewName)) + goNamedApplication napp extraArgs = case nonEmpty (napp ^. namedApplicationArguments) of + Nothing -> return (goIden (napp ^. namedApplicationName)) Just appargs -> do - let name = napp ^. namedApplicationNewName . scopedIdenFinal + let name = napp ^. namedApplicationName . scopedIdenFinal sig <- fromJust <$> asks (^. S.infoNameSigs . at (name ^. S.nameId)) - let fun = napp ^. namedApplicationNewName + let fun = napp ^. namedApplicationName blocks = createArgumentBlocks appargs (sig ^. nameSignatureArgs) compiledNameApp <- goNamedApplication' fun blocks extraArgs - case nonEmpty (appargs ^.. each . _NamedArgumentNewFunction) of + case nonEmpty (appargs ^.. each . _NamedArgumentFunction) of Nothing -> return compiledNameApp Just funs -> do cls <- funDefsToClauses funs @@ -1650,7 +1650,7 @@ goExpression = \case let (f, args) = unfoldApp a args' <- toList <$> mapM goApplicationArg args case f of - ExpressionNamedApplicationNew n -> goNamedApplicationNew n args' + ExpressionNamedApplication n -> goNamedApplication n args' _ -> do f' <- goExpression f return (Internal.foldApplication f' args') diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader/Versions.hs b/src/Juvix/Compiler/Pipeline/Package/Loader/Versions.hs index 6f70e8e374..9f63205073 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Loader/Versions.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Loader/Versions.hs @@ -116,9 +116,9 @@ v1v2FromPackage p = run . runReader l $ do Sem r (NonEmpty (ExpressionAtom 'Parsed)) defaultPackageWithArgs as = do defaultPackageName' <- NameUnqualified <$> symbol defaultPackageStr - exhaustive <- mkIsExhaustive False - let args = fmap (NamedArgumentNewFunction . NamedArgumentFunctionDef) as - defaultPackageArg = namedApplication defaultPackageName' exhaustive (toList args) + kwd <- kw kwAt + let args = fmap (NamedArgumentFunction . NamedArgumentFunctionDef) as + defaultPackageArg = namedApplication defaultPackageName' (Irrelevant kwd) (toList args) return (defaultPackageArg :| []) l :: Interval