From 13ed3be94fa072eefd1d385429a16590af831089 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Thu, 12 Sep 2024 12:28:28 +0200 Subject: [PATCH] remove old named application syntax --- src/Juvix/Compiler/Concrete/Gen.hs | 50 ++--- src/Juvix/Compiler/Concrete/Language/Base.hs | 174 ++++++++---------- .../Concrete/Language/IsApeInstances.hs | 7 - .../Concrete/MigrateNamedApplication.hs | 29 --- src/Juvix/Compiler/Concrete/Print/Base.hs | 6 - .../FromParsed/Analysis/Scoping.hs | 27 --- .../Concrete/Translation/FromSource.hs | 56 +----- .../FromConcrete/NamedArguments.hs | 10 +- .../Pipeline/Package/Loader/Versions.hs | 22 +-- 9 files changed, 114 insertions(+), 267 deletions(-) delete mode 100644 src/Juvix/Compiler/Concrete/MigrateNamedApplication.hs diff --git a/src/Juvix/Compiler/Concrete/Gen.hs b/src/Juvix/Compiler/Concrete/Gen.hs index e6eb81960b..25dba89b64 100644 --- a/src/Juvix/Compiler/Concrete/Gen.hs +++ b/src/Juvix/Compiler/Concrete/Gen.hs @@ -60,18 +60,18 @@ symbol t = do l <- ask return (WithLoc l t) +mkExpressionAtoms :: NonEmpty (ExpressionAtom 'Parsed) -> ExpressionAtoms 'Parsed +mkExpressionAtoms _expressionAtoms = + ExpressionAtoms { + _expressionAtoms, + _expressionAtomsLoc = Irrelevant (getLocSpan _expressionAtoms) + } + expressionAtoms' :: (Member (Reader Interval) r) => NonEmpty (ExpressionAtom 'Parsed) -> Sem r (ExpressionAtoms 'Parsed) expressionAtoms' _expressionAtoms = do _expressionAtomsLoc <- Irrelevant <$> ask return ExpressionAtoms {..} -namedArgument :: (Member (Reader Interval) r) => Text -> NonEmpty (ExpressionAtom 'Parsed) -> Sem r (NamedArgumentAssign 'Parsed) -namedArgument n as = do - _namedArgValue <- expressionAtoms' as - _namedArgName <- symbol n - _namedArgAssignKw <- Irrelevant <$> kw kwAssign - return NamedArgumentAssign {..} - literalString :: (Member (Reader Interval) r) => Text -> Sem r (ExpressionAtom s) literalString t = do l <- ask @@ -85,35 +85,13 @@ braced a = do l <- ask AtomBraces . WithLoc l <$> expressionAtoms' a -argumentBlock :: (Member (Reader Interval) r) => IsImplicit -> NonEmpty (NamedArgumentAssign 'Parsed) -> Sem r (ArgumentBlock 'Parsed) -argumentBlock i as = do - parenL <- kw delimL - parenR <- kw delimR - return - ArgumentBlock - { _argBlockImplicit = i, - _argBlockDelims = Irrelevant (Just (parenL, parenR)), - _argBlockArgs = as - } - where - delimL :: Keyword - delimL = case i of - Explicit -> kwBracketL - Implicit -> delimBraceL - ImplicitInstance -> delimDoubleBraceL - - delimR :: Keyword - delimR = case i of - Explicit -> kwBracketR - Implicit -> delimBraceR - ImplicitInstance -> delimDoubleBraceR - -namedApplication :: Name -> NonEmpty (ArgumentBlock 'Parsed) -> ExpressionAtom 'Parsed -namedApplication n as = - AtomNamedApplication - NamedApplication - { _namedAppName = n, - _namedAppArgs = as +namedApplication :: Name -> [NamedArgumentNew 'Parsed] -> IsExhaustive -> ExpressionAtom 'Parsed +namedApplication n as exh = + AtomNamedApplicationNew + NamedApplicationNew + { _namedApplicationNewName = n, + _namedApplicationNewExhaustive = exh, + _namedApplicationNewArguments = 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 5db1329900..c955e189db 100644 --- a/src/Juvix/Compiler/Concrete/Language/Base.hs +++ b/src/Juvix/Compiler/Concrete/Language/Base.hs @@ -1502,7 +1502,6 @@ data Expression | ExpressionBraces (WithLoc Expression) | ExpressionDoubleBraces (DoubleBracesExpression 'Scoped) | ExpressionIterator (Iterator 'Scoped) - | ExpressionNamedApplication (NamedApplication 'Scoped) | ExpressionNamedApplicationNew (NamedApplicationNew 'Scoped) deriving stock (Show, Eq, Ord, Generic) @@ -2214,59 +2213,59 @@ deriving stock instance Ord (List 'Parsed) deriving stock instance Ord (List 'Scoped) -data NamedArgumentAssign (s :: Stage) = NamedArgumentAssign - { _namedArgName :: SymbolType s, - _namedArgAssignKw :: Irrelevant KeywordRef, - _namedArgValue :: ExpressionType s - } - deriving stock (Generic) +-- data NamedArgumentAssign (s :: Stage) = NamedArgumentAssign +-- { _namedArgName :: SymbolType s, +-- _namedArgAssignKw :: Irrelevant KeywordRef, +-- _namedArgValue :: ExpressionType s +-- } +-- deriving stock (Generic) -instance Serialize (NamedArgumentAssign 'Scoped) +-- instance Serialize (NamedArgumentAssign 'Scoped) -instance NFData (NamedArgumentAssign 'Scoped) +-- instance NFData (NamedArgumentAssign 'Scoped) -instance Serialize (NamedArgumentAssign 'Parsed) +-- instance Serialize (NamedArgumentAssign 'Parsed) -instance NFData (NamedArgumentAssign 'Parsed) +-- instance NFData (NamedArgumentAssign 'Parsed) -deriving stock instance Show (NamedArgumentAssign 'Parsed) +-- deriving stock instance Show (NamedArgumentAssign 'Parsed) -deriving stock instance Show (NamedArgumentAssign 'Scoped) +-- deriving stock instance Show (NamedArgumentAssign 'Scoped) -deriving stock instance Eq (NamedArgumentAssign 'Parsed) +-- deriving stock instance Eq (NamedArgumentAssign 'Parsed) -deriving stock instance Eq (NamedArgumentAssign 'Scoped) +-- deriving stock instance Eq (NamedArgumentAssign 'Scoped) -deriving stock instance Ord (NamedArgumentAssign 'Parsed) +-- deriving stock instance Ord (NamedArgumentAssign 'Parsed) -deriving stock instance Ord (NamedArgumentAssign 'Scoped) +-- deriving stock instance Ord (NamedArgumentAssign 'Scoped) -data ArgumentBlock (s :: Stage) = ArgumentBlock - { _argBlockDelims :: Irrelevant (Maybe (KeywordRef, KeywordRef)), - _argBlockImplicit :: IsImplicit, - _argBlockArgs :: NonEmpty (NamedArgumentAssign s) - } - deriving stock (Generic) +-- data ArgumentBlock (s :: Stage) = ArgumentBlock +-- { _argBlockDelims :: Irrelevant (Maybe (KeywordRef, KeywordRef)), +-- _argBlockImplicit :: IsImplicit, +-- _argBlockArgs :: NonEmpty (NamedArgumentAssign s) +-- } +-- deriving stock (Generic) -instance Serialize (ArgumentBlock 'Scoped) +-- instance Serialize (ArgumentBlock 'Scoped) -instance NFData (ArgumentBlock 'Scoped) +-- instance NFData (ArgumentBlock 'Scoped) -instance Serialize (ArgumentBlock 'Parsed) +-- instance Serialize (ArgumentBlock 'Parsed) -instance NFData (ArgumentBlock 'Parsed) +-- instance NFData (ArgumentBlock 'Parsed) -deriving stock instance Show (ArgumentBlock 'Parsed) +-- deriving stock instance Show (ArgumentBlock 'Parsed) -deriving stock instance Show (ArgumentBlock 'Scoped) +-- deriving stock instance Show (ArgumentBlock 'Scoped) -deriving stock instance Eq (ArgumentBlock 'Parsed) +-- deriving stock instance Eq (ArgumentBlock 'Parsed) -deriving stock instance Eq (ArgumentBlock 'Scoped) +-- deriving stock instance Eq (ArgumentBlock 'Scoped) -deriving stock instance Ord (ArgumentBlock 'Parsed) +-- deriving stock instance Ord (ArgumentBlock 'Parsed) -deriving stock instance Ord (ArgumentBlock 'Scoped) +-- deriving stock instance Ord (ArgumentBlock 'Scoped) data RecordUpdateExtra = RecordUpdateExtra { _recordUpdateExtraConstructor :: S.Symbol, @@ -2327,32 +2326,6 @@ instance Serialize RecordUpdateApp instance NFData RecordUpdateApp -data NamedApplication (s :: Stage) = NamedApplication - { _namedAppName :: IdentifierType s, - _namedAppArgs :: NonEmpty (ArgumentBlock s) - } - deriving stock (Generic) - -instance Serialize (NamedApplication 'Scoped) - -instance NFData (NamedApplication 'Scoped) - -instance Serialize (NamedApplication 'Parsed) - -instance NFData (NamedApplication 'Parsed) - -deriving stock instance Show (NamedApplication 'Parsed) - -deriving stock instance Show (NamedApplication 'Scoped) - -deriving stock instance Eq (NamedApplication 'Parsed) - -deriving stock instance Eq (NamedApplication 'Scoped) - -deriving stock instance Ord (NamedApplication 'Parsed) - -deriving stock instance Ord (NamedApplication 'Scoped) - newtype NamedArgumentFunctionDef (s :: Stage) = NamedArgumentFunctionDef { _namedArgumentFunctionDef :: FunctionDef s } @@ -2608,7 +2581,6 @@ data ExpressionAtom (s :: Stage) | AtomLiteral LiteralLoc | AtomParens (ExpressionType s) | AtomIterator (Iterator s) - | AtomNamedApplication (NamedApplication s) | AtomNamedApplicationNew (NamedApplicationNew s) deriving stock (Generic) @@ -2900,9 +2872,6 @@ makeLenses ''ExpressionAtoms makeLenses ''Iterator makeLenses ''Initializer makeLenses ''Range -makeLenses ''ArgumentBlock -makeLenses ''NamedArgumentAssign -makeLenses ''NamedApplication makeLenses ''NamedArgumentNew makeLenses ''NamedApplicationNew makeLenses ''AliasDef @@ -2975,22 +2944,6 @@ instance (SingI s) => HasLoc (SyntaxDef s) where SyntaxIterator t -> getLoc t SyntaxAlias t -> getLoc t -instance (SingI s) => HasLoc (NamedArgumentAssign s) where - getLoc NamedArgumentAssign {..} = getLocSymbolType _namedArgName <> getLocExpressionType _namedArgValue - -instance (SingI s) => HasLoc (ArgumentBlock s) where - getLoc ArgumentBlock {..} = case d of - Just (l, r) -> getLoc l <> getLoc r - Nothing -> getLocSpan _argBlockArgs - where - Irrelevant d = _argBlockDelims - -instance HasAtomicity (ArgumentBlock s) where - atomicity = const Atom - -instance HasAtomicity (NamedApplication s) where - atomicity = const (Aggregate appFixity) - instance HasAtomicity (NamedApplicationNew s) where atomicity = const (Aggregate updateFixity) @@ -3018,7 +2971,6 @@ instance HasAtomicity Expression where ExpressionCase c -> atomicity c ExpressionIf x -> atomicity x ExpressionIterator i -> atomicity i - ExpressionNamedApplication i -> atomicity i ExpressionNamedApplicationNew i -> atomicity i ExpressionRecordUpdate {} -> Aggregate updateFixity ExpressionParensRecordUpdate {} -> Atom @@ -3101,30 +3053,33 @@ instance HasLoc InfixApplication where instance HasLoc PostfixApplication where getLoc (PostfixApplication l o) = getLoc l <> getLoc o -instance HasLoc (LambdaClause 'Scoped) where +instance SingI s => HasLoc (LambdaClause s) where getLoc c = - fmap getLoc (c ^. lambdaPipe . unIrrelevant) - ?<> getLocSpan (c ^. lambdaParameters) - <> getLoc (c ^. lambdaBody) - -instance HasLoc (Lambda 'Scoped) where + let locparams = case sing :: SStage s of + SParsed -> getLocSpan (c ^. lambdaParameters) + SScoped -> getLocSpan (c ^. lambdaParameters) + in fmap getLoc (c ^. lambdaPipe . unIrrelevant) + ?<> locparams + <> getLocExpressionType (c ^. lambdaBody) + +instance HasLoc (Lambda s) where getLoc l = getLoc (l ^. lambdaKw) <> getLoc (l ^. lambdaBraces . unIrrelevant . _2) -instance HasLoc (FunctionParameter 'Scoped) where +instance SingI s => HasLoc (FunctionParameter s) where getLoc = \case - FunctionParameterName n -> getLoc n + FunctionParameterName n -> getLocSymbolType n FunctionParameterWildcard w -> getLoc w -instance HasLoc (FunctionParameters 'Scoped) where +instance SingI s => HasLoc (FunctionParameters s) where getLoc p = case p ^. paramDelims . unIrrelevant of - Nothing -> (getLoc <$> listToMaybe (p ^. paramNames)) ?<> getLoc (p ^. paramType) + Nothing -> (getLoc <$> listToMaybe (p ^. paramNames)) ?<> getLocExpressionType (p ^. paramType) Just (l, r) -> getLoc l <> getLoc r -instance HasLoc (Function 'Scoped) where - getLoc f = getLoc (f ^. funParameters) <> getLoc (f ^. funReturn) +instance SingI s => HasLoc (Function s) where + getLoc f = getLoc (f ^. funParameters) <> getLocExpressionType (f ^. funReturn) -instance HasLoc (Let 'Scoped) where - getLoc l = getLoc (l ^. letKw) <> getLoc (l ^. letExpression) +instance SingI s => HasLoc (Let s) where + getLoc l = getLoc (l ^. letKw) <> getLocExpressionType (l ^. letExpression) instance (SingI s) => HasLoc (SideIfBranch s k) where getLoc SideIfBranch {..} = @@ -3166,9 +3121,6 @@ instance (SingI s) => HasLoc (If s) where instance HasLoc (List s) where getLoc List {..} = getLoc _listBracketL <> getLoc _listBracketR -instance (SingI s) => HasLoc (NamedApplication s) where - getLoc NamedApplication {..} = getLocIdentifierType _namedAppName <> getLoc (last _namedAppArgs) - instance HasLoc (NamedArgumentPun s) where getLoc NamedArgumentPun {..} = getLocSymbolType _namedArgumentPunSymbol @@ -3220,7 +3172,6 @@ instance HasLoc Expression where ExpressionBraces i -> getLoc i ExpressionDoubleBraces i -> getLoc i ExpressionIterator i -> getLoc i - ExpressionNamedApplication i -> getLoc i ExpressionNamedApplicationNew i -> getLoc i ExpressionRecordUpdate i -> getLoc i ExpressionParensRecordUpdate i -> getLoc i @@ -3275,6 +3226,11 @@ getLocSymbolType = case sing :: SStage s of SParsed -> getLoc SScoped -> getLoc +getLocHoleType :: forall s. (SingI s) => HoleType s -> Interval +getLocHoleType = case sing :: SStage s of + SParsed -> getLoc + SScoped -> getLoc + getLocExpressionType :: forall s. (SingI s) => ExpressionType s -> Interval getLocExpressionType = case sing :: SStage s of SParsed -> getLoc @@ -3419,6 +3375,28 @@ instance HasLoc Pattern where PatternPostfixApplication i -> getLoc i PatternRecord i -> getLoc i +instance SingI s => HasLoc (ExpressionAtom s) where + getLoc = \case + AtomIdentifier i -> getLocIdentifierType i + AtomLambda x -> getLoc x + AtomList x -> getLoc x + AtomCase x -> getLoc x + AtomIf x -> getLoc x + AtomHole x -> getLocHoleType x + AtomInstanceHole x -> getLocHoleType x + AtomDoubleBraces x -> getLoc x + AtomBraces x -> getLoc x + AtomDo x -> getLoc x + AtomLet x -> getLoc x + AtomRecordUpdate x -> getLoc x + AtomUniverse x -> getLoc x + AtomFunction x -> getLoc x + AtomFunArrow x -> getLoc x + AtomLiteral x -> getLoc x + AtomParens x -> getLocExpressionType x + AtomIterator x -> getLoc x + AtomNamedApplicationNew x -> getLoc x + instance HasLoc (ExpressionAtoms s) where getLoc = getLoc . (^. expressionAtomsLoc) diff --git a/src/Juvix/Compiler/Concrete/Language/IsApeInstances.hs b/src/Juvix/Compiler/Concrete/Language/IsApeInstances.hs index cb7a551f20..064754798f 100644 --- a/src/Juvix/Compiler/Concrete/Language/IsApeInstances.hs +++ b/src/Juvix/Compiler/Concrete/Language/IsApeInstances.hs @@ -4,7 +4,6 @@ module Juvix.Compiler.Concrete.Language.IsApeInstances where import Juvix.Compiler.Concrete.Data.ScopedName qualified as S import Juvix.Compiler.Concrete.Language.Base -import Juvix.Compiler.Concrete.MigrateNamedApplication import Juvix.Data.Ape.Base as Ape import Juvix.Data.NameKind import Juvix.Parser.Lexer (isDelimiterStr) @@ -82,11 +81,6 @@ instance IsApe Name ApeLeaf where _leafExpr = ApeLeafAtom (sing :&: AtomIdentifier n) } -instance (SingI s) => IsApe (NamedApplication s) ApeLeaf where - toApe = toApe . migrateNamedApplication - --- f = toApeIdentifierType _namedAppName - instance (SingI s) => IsApe (NamedApplicationNew s) ApeLeaf where toApe a = ApeLeaf $ @@ -150,7 +144,6 @@ instance IsApe Expression ApeLeaf where ExpressionInfixApplication a -> toApe a ExpressionPostfixApplication a -> toApe a ExpressionFunction a -> toApe a - ExpressionNamedApplication a -> toApe a ExpressionNamedApplicationNew a -> toApe a ExpressionRecordUpdate a -> toApe a ExpressionParensRecordUpdate {} -> leaf diff --git a/src/Juvix/Compiler/Concrete/MigrateNamedApplication.hs b/src/Juvix/Compiler/Concrete/MigrateNamedApplication.hs deleted file mode 100644 index 95cf80b506..0000000000 --- a/src/Juvix/Compiler/Concrete/MigrateNamedApplication.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Juvix.Compiler.Concrete.MigrateNamedApplication where - -import Juvix.Compiler.Concrete.Gen qualified as Gen -import Juvix.Compiler.Concrete.Keywords -import Juvix.Compiler.Concrete.Language.Base -import Juvix.Prelude - -migrateNamedApplication :: forall s. (SingI s) => NamedApplication s -> NamedApplicationNew s -migrateNamedApplication old@NamedApplication {..} = run . runReader (getLoc old) $ do - _namedApplicationNewAtKw <- Irrelevant <$> Gen.kw kwAt - _namedApplicationNewExhaustive <- Gen.isExhaustive False - return - NamedApplicationNew - { _namedApplicationNewName = _namedAppName, - _namedApplicationNewArguments = migrateNamedApplicationArguments (toList _namedAppArgs), - _namedApplicationNewExhaustive - } - where - migrateNamedApplicationArguments :: [ArgumentBlock s] -> [NamedArgumentNew s] - migrateNamedApplicationArguments = concatMap goBlock - where - goBlock :: ArgumentBlock s -> [NamedArgumentNew s] - goBlock ArgumentBlock {..} = map goArg (toList _argBlockArgs) - where - goArg :: NamedArgumentAssign s -> NamedArgumentNew s - goArg = NamedArgumentNewFunction . NamedArgumentFunctionDef . toFun - - toFun :: NamedArgumentAssign s -> FunctionDef s - toFun NamedArgumentAssign {..} = Gen.simplestFunctionDef _namedArgName _namedArgValue diff --git a/src/Juvix/Compiler/Concrete/Print/Base.hs b/src/Juvix/Compiler/Concrete/Print/Base.hs index ec0bcc501e..8824e85130 100644 --- a/src/Juvix/Compiler/Concrete/Print/Base.hs +++ b/src/Juvix/Compiler/Concrete/Print/Base.hs @@ -17,7 +17,6 @@ import Juvix.Compiler.Concrete.Gen qualified as Gen import Juvix.Compiler.Concrete.Keywords import Juvix.Compiler.Concrete.Keywords qualified as Kw import Juvix.Compiler.Concrete.Language.Base -import Juvix.Compiler.Concrete.MigrateNamedApplication import Juvix.Compiler.Concrete.Pretty.Options import Juvix.Compiler.Concrete.Translation.ImportScanner.Base import Juvix.Compiler.Pipeline.Loader.PathResolver.Data @@ -333,9 +332,6 @@ instance (SingI s) => PrettyPrint (ArgumentBlock s) where where Irrelevant d = _argBlockDelims -instance (SingI s) => PrettyPrint (NamedApplication s) where - ppCode = ppCode . migrateNamedApplication - instance PrettyPrint IsExhaustive where ppCode IsExhaustive {..} = ppCode _isExhaustiveKw @@ -460,7 +456,6 @@ instance (SingI s) => PrettyPrint (ExpressionAtom s) where AtomHole w -> ppHoleType w AtomInstanceHole w -> ppHoleType w AtomIterator i -> ppIterator NotTop i - AtomNamedApplication i -> ppCode i AtomNamedApplicationNew i -> ppCode i instance PrettyPrint PatternScopedIden where @@ -978,7 +973,6 @@ instance PrettyPrint Expression where ExpressionCase c -> ppCase NotTop c ExpressionIf c -> ppIf NotTop c ExpressionIterator i -> ppIterator NotTop i - ExpressionNamedApplication i -> ppCode i ExpressionNamedApplicationNew 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 7dbf00d567..82ab0a7ada 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs @@ -2697,7 +2697,6 @@ checkExpressionAtom e = case e of AtomLiteral l -> return (pure (AtomLiteral l)) AtomList l -> pure . AtomList <$> checkList l AtomIterator i -> pure . AtomIterator <$> checkIterator i - AtomNamedApplication i -> pure . AtomNamedApplication <$> checkNamedApplication i AtomNamedApplicationNew i -> pure . AtomNamedApplicationNew <$> checkNamedApplicationNew i AtomRecordUpdate i -> pure . AtomRecordUpdate <$> checkRecordUpdate i @@ -2832,23 +2831,6 @@ checkUpdateField sig f = do unexpectedField :: ScoperError unexpectedField = ErrUnexpectedField (UnexpectedField (f ^. fieldUpdateName)) -checkNamedApplication :: - forall r. - (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => - NamedApplication 'Parsed -> - Sem r (NamedApplication 'Scoped) -checkNamedApplication napp = do - _namedAppName <- checkScopedIden (napp ^. namedAppName) - _namedAppArgs <- mapM checkArgumentBlock (napp ^. namedAppArgs) - return NamedApplication {..} - where - checkArgumentBlock :: ArgumentBlock 'Parsed -> Sem r (ArgumentBlock 'Scoped) - checkArgumentBlock b = do - let _argBlockDelims = b ^. argBlockDelims - _argBlockImplicit = b ^. argBlockImplicit - _argBlockArgs <- mapM checkNamedArgumentAssign (b ^. argBlockArgs) - return ArgumentBlock {..} - checkNamedArgumentAssign :: forall r. (Members '[HighlightBuilder, Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => @@ -3291,7 +3273,6 @@ parseTerm = <|> parseIterator <|> parseDoubleBraces <|> parseBraces - <|> parseNamedApplication <|> parseNamedApplicationNew where parseHole :: Parse Expression @@ -3366,14 +3347,6 @@ parseTerm = AtomFunction u -> Just u _ -> Nothing - parseNamedApplication :: Parse Expression - parseNamedApplication = ExpressionNamedApplication <$> P.token namedApp mempty - where - namedApp :: ExpressionAtom 'Scoped -> Maybe (NamedApplication 'Scoped) - namedApp s = case s of - AtomNamedApplication u -> Just u - _ -> Nothing - parseNamedApplicationNew :: Parse Expression parseNamedApplicationNew = ExpressionNamedApplicationNew <$> P.token namedApp mempty where diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs index fc16dc02ef..8239326f82 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs @@ -829,9 +829,8 @@ expressionAtom :: (Members '[ParserResultBuilder, PragmasStash, JudocStash] r) = expressionAtom = P.label "" $ AtomLiteral <$> P.try literal - <|> either AtomIterator AtomNamedApplication <$> iterator + <|> AtomIterator <$> iterator <|> AtomNamedApplicationNew <$> namedApplicationNew - <|> AtomNamedApplication <$> namedApplication <|> AtomList <$> parseList <|> AtomIf <$> multiwayIf <|> AtomIdentifier <$> name @@ -881,9 +880,8 @@ pdoubleBracesExpression = do iterator :: forall r. (Members '[ParserResultBuilder, PragmasStash, JudocStash] r) => - ParsecS r (Either (Iterator 'Parsed) (NamedApplication 'Parsed)) + ParsecS r (Iterator 'Parsed) iterator = do - off <- P.getOffset (firstIsInit, keywordRef, _iteratorName, pat) <- P.try $ do n <- name lparen @@ -926,26 +924,12 @@ iterator = do rngs <- (r :) <$> many (semicolon >> range) rparen return rngs - if - | null _iteratorRanges -> do - args <- nonEmpty' <$> mapM (mkNamedArgument off) _iteratorInitializers - tailBlocks <- many argumentBlock - let firstBlock = - ArgumentBlock - { _argBlockDelims = Irrelevant Nothing, - _argBlockImplicit = Explicit, - _argBlockArgs = args - } - _namedAppName = _iteratorName - _namedAppArgs = firstBlock :| tailBlocks - _namedAppSignature = Irrelevant () - return $ Right NamedApplication {..} - | otherwise -> do - (_iteratorBody, _iteratorBodyBraces) <- - (,True) <$> braces parseExpressionAtoms - <|> (,False) <$> parseExpressionAtoms - let _iteratorParens = False - return $ Left Iterator {..} + do + (_iteratorBody, _iteratorBodyBraces) <- + (,True) <$> braces parseExpressionAtoms + <|> (,False) <$> parseExpressionAtoms + let _iteratorParens = False + return $ Iterator {..} where initializer :: ParsecS r (Initializer 'Parsed) initializer = do @@ -972,15 +956,6 @@ iterator = do s <- P.try rangeStart rangeCont s - mkNamedArgument :: Int -> Initializer 'Parsed -> ParsecS r (NamedArgumentAssign 'Parsed) - mkNamedArgument off Initializer {..} = do - let _namedArgAssignKw = _initializerAssignKw - _namedArgValue = _initializerExpression - _namedArgName <- case _initializerPattern ^. patternAtoms of - PatternAtomIden (NameUnqualified n) :| [] -> return n - _ -> parseFailure off "an iterator must have at least one range" - return NamedArgumentAssign {..} - pnamedArgumentFunctionDef :: forall r. (Members '[ParserResultBuilder, PragmasStash, JudocStash] r) => @@ -1067,21 +1042,6 @@ namedApplicationNew = P.label "" $ do let _namedApplicationNewExtra = Irrelevant () return NamedApplicationNew {..} -namedApplication :: - forall r. - (Members '[ParserResultBuilder, PragmasStash, JudocStash] r) => - ParsecS r (NamedApplication 'Parsed) -namedApplication = P.label "" $ do - (_namedAppName, firstBlockStart) <- P.try $ do - n <- name - bs <- argumentBlockStart - return (n, bs) - firstBlock <- argumentBlockCont firstBlockStart - tailBlocks <- many argumentBlock - let _namedAppArgs = firstBlock :| tailBlocks - _namedAppSignature = Irrelevant () - return NamedApplication {..} - namedArgumentAssign :: forall r. (Members '[ParserResultBuilder, PragmasStash, JudocStash] r) => diff --git a/src/Juvix/Compiler/Internal/Translation/FromConcrete/NamedArguments.hs b/src/Juvix/Compiler/Internal/Translation/FromConcrete/NamedArguments.hs index 1c1cfd8296..edc9cd8ed5 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromConcrete/NamedArguments.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromConcrete/NamedArguments.hs @@ -24,7 +24,7 @@ import Juvix.Prelude type NameSignatures = HashMap S.NameId (NameSignature 'Scoped) data BuilderState = BuilderState - { _stateRemainingArgs :: [ArgumentBlock 'Scoped], + { _stateRemainingArgs :: [NamedArgumentNew 'Scoped], _stateRemainingNames :: [NameBlock 'Scoped] } @@ -50,7 +50,7 @@ makeLenses ''DesugaredNamedApplication runNamedArguments :: forall r. (Members '[NameIdGen, Error ScoperError, Reader NameSignatures] r) => - NamedApplication 'Scoped -> + NamedApplicationNew 'Scoped -> [Internal.ApplicationArg] -> Sem r DesugaredNamedApplication runNamedArguments napp extraArgs = do @@ -63,21 +63,21 @@ runNamedArguments napp extraArgs = do $ helper (getLoc napp) return DesugaredNamedApplication - { _dnamedAppIdentifier = napp ^. namedAppName, + { _dnamedAppIdentifier = napp ^. namedApplicationNewName, _dnamedAppArgs = namedArgs, _dnamedExtraArgs = extraArgs } where mkIniBuilderState :: Sem r BuilderState mkIniBuilderState = do - let name = napp ^. namedAppName . scopedIdenFinal + let name = napp ^. namedApplicationNewName . scopedIdenFinal msig <- asks @NameSignatures (^. at (name ^. S.nameId)) let sig = fromMaybe err msig where err = error ("impossible: could not find name signature for " <> prettyText name) return BuilderState - { _stateRemainingArgs = toList (napp ^. namedAppArgs), + { _stateRemainingArgs = toList (napp ^. namedApplicationNewArguments), _stateRemainingNames = sig ^. nameSignatureArgs } diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader/Versions.hs b/src/Juvix/Compiler/Pipeline/Package/Loader/Versions.hs index 9eb15b7a3b..ba70e8f135 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Loader/Versions.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Loader/Versions.hs @@ -110,7 +110,7 @@ v1v2FromPackage p = run . runReader l $ do defaultPackageNoArgs :: (Member (Reader Interval) r) => Sem r (NonEmpty (ExpressionAtom 'Parsed)) defaultPackageNoArgs = NEL.singleton <$> identifier defaultPackageStr - defaultPackageWithArgs :: (Member (Reader Interval) r) => NonEmpty (NamedArgumentAssign 'Parsed) -> Sem r (NonEmpty (ExpressionAtom 'Parsed)) + defaultPackageWithArgs :: (Member (Reader Interval) r) => NonEmpty (FunctionDef 'Parsed) -> Sem r (NonEmpty (ExpressionAtom 'Parsed)) defaultPackageWithArgs as = do defaultPackageName' <- NameUnqualified <$> symbol defaultPackageStr argBlock <- argumentBlock Implicit as @@ -120,18 +120,18 @@ v1v2FromPackage p = run . runReader l $ do l :: Interval l = singletonInterval (mkInitialLoc (p ^. packageFile)) - mkNamedArgs :: forall r. (Member (Reader Interval) r) => Sem r [NamedArgumentAssign 'Parsed] + mkNamedArgs :: forall r. (Member (Reader Interval) r) => Sem r [FunctionDef 'Parsed] mkNamedArgs = do catMaybes <$> sequence [mkNameArg, mkVersionArg, mkDependenciesArg, mkMainArg, mkBuildDirArg] where - mkNameArg :: Sem r (Maybe (NamedArgumentAssign 'Parsed)) + mkNameArg :: Sem r (Maybe (FunctionDef 'Parsed)) mkNameArg | defaultPackageName == p ^. packageName = return Nothing | otherwise = do n <- literalString (p ^. packageName) - Just <$> namedArgument "name" (n :| []) + return (Just (simplestFunctionDef "name" (ExpressionAtoms (n :| [])))) - mkDependenciesArg :: Sem r (Maybe (NamedArgumentAssign 'Parsed)) + mkDependenciesArg :: Sem r (Maybe (FunctionDef 'Parsed)) mkDependenciesArg = do let deps = p ^. packageDependencies dependenciesArg = Just <$> mkDependenciesArg' (p ^. packageDependencies) @@ -142,7 +142,7 @@ v1v2FromPackage p = run . runReader l $ do | otherwise -> dependenciesArg _ -> dependenciesArg where - mkDependenciesArg' :: [Dependency] -> Sem r (NamedArgumentAssign 'Parsed) + mkDependenciesArg' :: [Dependency] -> Sem r (FunctionDef 'Parsed) mkDependenciesArg' ds = do deps <- mkList =<< mapM mkDependencyArg ds namedArgument "dependencies" (deps :| []) @@ -165,15 +165,15 @@ v1v2FromPackage p = run . runReader l $ do ) ) - mkMainArg :: Sem r (Maybe (NamedArgumentAssign 'Parsed)) + mkMainArg :: Sem r (Maybe (FunctionDef 'Parsed)) mkMainArg = do arg <- mapM mainArg (p ^. packageMain) - mapM (namedArgument "main") arg + mapM (simplestFunctionDef "main") arg where mainArg :: Prepath File -> Sem r (NonEmpty (ExpressionAtom 'Parsed)) mainArg p' = mkJust =<< literalString (pack (unsafePrepathToFilePath p')) - mkBuildDirArg :: Sem r (Maybe (NamedArgumentAssign 'Parsed)) + mkBuildDirArg :: Sem r (Maybe (FunctionDef 'Parsed)) mkBuildDirArg = do arg <- mapM buildDirArg (p ^. packageBuildDir) mapM (namedArgument "buildDir") arg @@ -181,12 +181,12 @@ v1v2FromPackage p = run . runReader l $ do buildDirArg :: SomeBase Dir -> Sem r (NonEmpty (ExpressionAtom 'Parsed)) buildDirArg d = mkJust =<< literalString (pack (fromSomeDir d)) - mkVersionArg :: Sem r (Maybe (NamedArgumentAssign 'Parsed)) + mkVersionArg :: Sem r (Maybe (FunctionDef 'Parsed)) mkVersionArg | p ^. packageVersion == defaultVersion = return Nothing | otherwise = Just <$> mkVersionArg' where - mkVersionArg' :: Sem r (NamedArgumentAssign 'Parsed) + mkVersionArg' :: Sem r (FunctionDef 'Parsed) mkVersionArg' = do mkVersionArgs <- liftM2 (++) explicitArgs implicitArgs mkVersionName <- identifier "mkVersion"