diff --git a/include/package/PackageDescription/V1.juvix b/include/package/PackageDescription/V1.juvix index 85dae9ea3b..a73b15a9ab 100644 --- a/include/package/PackageDescription/V1.juvix +++ b/include/package/PackageDescription/V1.juvix @@ -55,16 +55,16 @@ defaultPackage --- Construct a ;SemVer; with useful default arguments. mkVersion - (major' minor' patch' : Nat) - {release' : Maybe String := nothing} - {meta' : Maybe String := nothing} + (major minor patch : Nat) + {release : Maybe String := nothing} + {meta : Maybe String := nothing} : SemVer := mkSemVer@?{ - major := major'; - minor := minor'; - patch := patch'; - release := release'; - meta := meta' + major; + minor; + patch; + release; + meta; }; --- The default version used in `defaultPackage`. diff --git a/include/package/PackageDescription/V2.juvix b/include/package/PackageDescription/V2.juvix index 44d27e471f..005c861642 100644 --- a/include/package/PackageDescription/V2.juvix +++ b/include/package/PackageDescription/V2.juvix @@ -55,16 +55,16 @@ defaultPackage --- Construct a ;SemVer; with useful default arguments. mkVersion - (major' minor' patch' : Nat) - {release' : Maybe String := nothing} - {meta' : Maybe String := nothing} + (major minor patch : Nat) + {release : Maybe String := nothing} + {meta : Maybe String := nothing} : SemVer := mkSemVer@?{ - major := major'; - minor := minor'; - patch := patch'; - release := release'; - meta := meta' + major; + minor; + patch; + release; + meta; }; --- The default version used in `defaultPackage`. diff --git a/src/Juvix/Compiler/Concrete/Data/Name.hs b/src/Juvix/Compiler/Concrete/Data/Name.hs index 9729563d96..7a6a62ba38 100644 --- a/src/Juvix/Compiler/Concrete/Data/Name.hs +++ b/src/Juvix/Compiler/Concrete/Data/Name.hs @@ -123,6 +123,11 @@ moduleNameToTopModulePath = \case NameUnqualified s -> TopModulePath [] s NameQualified (QualifiedName (SymbolPath p) s) -> TopModulePath (toList p) s +fromUnqualified' :: Name -> Symbol +fromUnqualified' = \case + NameUnqualified s -> s + NameQualified {} -> impossible + splitName :: Name -> ([Symbol], Symbol) splitName = \case NameQualified (QualifiedName (SymbolPath p) s) -> (toList p, s) diff --git a/src/Juvix/Compiler/Concrete/Language/Base.hs b/src/Juvix/Compiler/Concrete/Language/Base.hs index 29109f3225..47fab4eaf6 100644 --- a/src/Juvix/Compiler/Concrete/Language/Base.hs +++ b/src/Juvix/Compiler/Concrete/Language/Base.hs @@ -71,6 +71,11 @@ type family ModuleIdType s t = res where ModuleIdType 'Scoped 'ModuleLocal = () ModuleIdType 'Scoped 'ModuleTop = ModuleId +type PunSymbolType :: Stage -> GHCType +type family PunSymbolType s = res | res -> s where + PunSymbolType 'Parsed = () + PunSymbolType 'Scoped = ScopedIden + type SymbolType :: Stage -> GHCType type family SymbolType s = res | res -> s where SymbolType 'Parsed = Symbol @@ -2304,8 +2309,35 @@ deriving stock instance Ord (NamedArgumentFunctionDef 'Parsed) deriving stock instance Ord (NamedArgumentFunctionDef 'Scoped) -newtype NamedArgumentNew (s :: Stage) +data NamedArgumentPun (s :: Stage) = NamedArgumentPun + { _namedArgumentPunSymbol :: Symbol, + _namedArgumentReferencedSymbol :: PunSymbolType s + } + deriving stock (Generic) + +instance Serialize (NamedArgumentPun 'Scoped) + +instance NFData (NamedArgumentPun 'Scoped) + +instance Serialize (NamedArgumentPun 'Parsed) + +instance NFData (NamedArgumentPun 'Parsed) + +deriving stock instance Show (NamedArgumentPun 'Parsed) + +deriving stock instance Show (NamedArgumentPun 'Scoped) + +deriving stock instance Eq (NamedArgumentPun 'Parsed) + +deriving stock instance Eq (NamedArgumentPun 'Scoped) + +deriving stock instance Ord (NamedArgumentPun 'Parsed) + +deriving stock instance Ord (NamedArgumentPun 'Scoped) + +data NamedArgumentNew (s :: Stage) = NamedArgumentNewFunction (NamedArgumentFunctionDef s) + | NamedArgumentItemPun (NamedArgumentPun s) deriving stock (Generic) instance Serialize (NamedArgumentNew 'Scoped) @@ -2628,6 +2660,7 @@ deriving stock instance Ord (JudocAtom 'Scoped) makeLenses ''SideIfs makeLenses ''NamedArgumentFunctionDef +makeLenses ''NamedArgumentPun makeLenses ''IsExhaustive makeLenses ''SideIfBranch makeLenses ''RhsExpression @@ -2938,6 +2971,9 @@ instance HasLoc (List s) where instance (SingI s) => HasLoc (NamedApplication s) where getLoc NamedApplication {..} = getLocIdentifierType _namedAppName <> getLoc (last _namedAppArgs) +instance HasLoc (NamedArgumentPun s) where + getLoc NamedArgumentPun {..} = getLocSymbolType _namedArgumentPunSymbol + instance (SingI s) => HasLoc (NamedApplicationNew s) where getLoc NamedApplicationNew {..} = getLocIdentifierType _namedApplicationNewName @@ -3223,8 +3259,9 @@ _RecordStatementField f x = case x of RecordStatementField p -> RecordStatementField <$> f p _ -> pure x -namedArgumentNewSymbol :: Lens' (NamedArgumentNew s) (SymbolType s) +namedArgumentNewSymbol :: Lens' (NamedArgumentNew 'Parsed) Symbol namedArgumentNewSymbol f = \case + NamedArgumentItemPun a -> NamedArgumentItemPun <$> namedArgumentPunSymbol f a NamedArgumentNewFunction a -> NamedArgumentNewFunction <$> (namedArgumentFunctionDef . signName) f a diff --git a/src/Juvix/Compiler/Concrete/Print/Base.hs b/src/Juvix/Compiler/Concrete/Print/Base.hs index a409d85f2c..9f72243353 100644 --- a/src/Juvix/Compiler/Concrete/Print/Base.hs +++ b/src/Juvix/Compiler/Concrete/Print/Base.hs @@ -334,9 +334,13 @@ instance (SingI s) => PrettyPrint (NamedApplicationNew s) where instance (SingI s) => PrettyPrint (NamedArgumentFunctionDef s) where ppCode (NamedArgumentFunctionDef f) = ppCode f +instance PrettyPrint (NamedArgumentPun s) where + ppCode = ppCode . (^. namedArgumentPunSymbol) + instance (SingI s) => PrettyPrint (NamedArgumentNew s) where ppCode = \case NamedArgumentNewFunction f -> ppCode f + NamedArgumentItemPun f -> ppCode f instance (SingI s) => PrettyPrint (RecordStatement s) where ppCode = \case diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs index 0aecdb2810..6e94de77ad 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs @@ -2573,16 +2573,23 @@ checkExpressionAtom e = case e of reserveNamedArgumentName :: (Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder, Reader InfoTable] r) => NamedArgumentNew 'Parsed -> Sem r () reserveNamedArgumentName a = case a of NamedArgumentNewFunction f -> void (reserveFunctionSymbol (f ^. namedArgumentFunctionDef)) + NamedArgumentItemPun {} -> return () -checkNamedApplicationNew :: forall r. (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => NamedApplicationNew 'Parsed -> Sem r (NamedApplicationNew 'Scoped) +checkNamedApplicationNew :: + forall r. + (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => + NamedApplicationNew 'Parsed -> + Sem r (NamedApplicationNew 'Scoped) checkNamedApplicationNew napp = do let nargs = napp ^. namedApplicationNewArguments aname <- checkScopedIden (napp ^. namedApplicationNewName) sig <- if null nargs then return $ NameSignature [] else getNameSignature aname - let snames = HashSet.fromList (concatMap (HashMap.keys . (^. nameBlock)) (sig ^. nameSignatureArgs)) + let namesInSignature = hashSet (concatMap (HashMap.keys . (^. nameBlock)) (sig ^. nameSignatureArgs)) + forM_ nargs (checkNameInSignature namesInSignature . (^. namedArgumentNewSymbol)) + puns <- scopePuns args' <- withLocalScope . localBindings . ignoreSyntax $ do mapM_ reserveNamedArgumentName nargs - mapM (checkNamedArgumentNew snames) nargs + mapM (checkNamedArgumentNew puns) nargs let enames = HashSet.fromList . concatMap (HashMap.keys . (^. nameBlock)) @@ -2598,25 +2605,47 @@ checkNamedApplicationNew napp = do _namedApplicationNewArguments = args', _namedApplicationNewExhaustive = napp ^. namedApplicationNewExhaustive } + where + checkNameInSignature :: HashSet Symbol -> Symbol -> Sem r () + checkNameInSignature namesInSig fname = + unless (HashSet.member fname namesInSig) $ + throw (ErrUnexpectedArgument (UnexpectedArgument fname)) + + scopePuns :: Sem r (HashMap Symbol ScopedIden) + scopePuns = + hashMap + <$> mapWithM + scopePun + (napp ^.. namedApplicationNewArguments . each . _NamedArgumentItemPun . namedArgumentPunSymbol) + where + scopePun :: Symbol -> Sem r ScopedIden + scopePun = checkScopedIden . NameUnqualified checkNamedArgumentNew :: (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => - HashSet Symbol -> + HashMap Symbol ScopedIden -> NamedArgumentNew 'Parsed -> Sem r (NamedArgumentNew 'Scoped) -checkNamedArgumentNew snames = \case - NamedArgumentNewFunction f -> NamedArgumentNewFunction <$> checkNamedArgumentFunctionDef snames f +checkNamedArgumentNew puns = \case + NamedArgumentNewFunction f -> NamedArgumentNewFunction <$> checkNamedArgumentFunctionDef f + NamedArgumentItemPun f -> return (NamedArgumentItemPun (checkNamedArgumentItemPun puns f)) + +checkNamedArgumentItemPun :: + HashMap Symbol ScopedIden -> + NamedArgumentPun 'Parsed -> + (NamedArgumentPun 'Scoped) +checkNamedArgumentItemPun puns NamedArgumentPun {..} = + NamedArgumentPun + { _namedArgumentPunSymbol = _namedArgumentPunSymbol, + _namedArgumentReferencedSymbol = fromJust (puns ^. at _namedArgumentPunSymbol) + } checkNamedArgumentFunctionDef :: (Members '[HighlightBuilder, Error ScoperError, State Scope, State ScoperState, Reader ScopeParameters, InfoTableBuilder, Reader InfoTable, NameIdGen, Reader Package] r) => - HashSet Symbol -> NamedArgumentFunctionDef 'Parsed -> Sem r (NamedArgumentFunctionDef 'Scoped) -checkNamedArgumentFunctionDef snames NamedArgumentFunctionDef {..} = do +checkNamedArgumentFunctionDef NamedArgumentFunctionDef {..} = do def <- localBindings . ignoreSyntax $ checkFunctionDef _namedArgumentFunctionDef - let fname = def ^. signName . nameConcrete - unless (HashSet.member fname snames) $ - throw (ErrUnexpectedArgument (UnexpectedArgument fname)) return NamedArgumentFunctionDef { _namedArgumentFunctionDef = def diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs index 6f7a61000b..7834e071ff 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs @@ -983,11 +983,50 @@ pnamedArgumentFunctionDef = do { _namedArgumentFunctionDef = fun } -namedArgumentNew :: +pnamedArgumentItemPun :: forall r. (Members '[ParserResultBuilder, PragmasStash, JudocStash] r) => - ParsecS r (NamedArgumentNew 'Parsed) -namedArgumentNew = NamedArgumentNewFunction <$> pnamedArgumentFunctionDef + ParsecS r (NamedArgumentPun 'Parsed) +pnamedArgumentItemPun = do + sym <- symbol + return + NamedArgumentPun + { _namedArgumentPunSymbol = sym, + _namedArgumentReferencedSymbol = () + } + +-- | Parses zero or more named arguments. This function is necessary to avoid +-- using excessive backtracking. +manyNamedArgumentNewRBrace :: + forall r. + (Members '[ParserResultBuilder, PragmasStash, JudocStash] r) => + ParsecS r [NamedArgumentNew 'Parsed] +manyNamedArgumentNewRBrace = reverse <$> go [] + where + go :: [NamedArgumentNew 'Parsed] -> ParsecS r [NamedArgumentNew 'Parsed] + go acc = + rbrace $> acc + <|> itemHelper (P.try (withIsLast (NamedArgumentItemPun <$> pnamedArgumentItemPun))) + <|> itemHelper (withIsLast (NamedArgumentNewFunction <$> pnamedArgumentFunctionDef)) + where + itemHelper :: ParsecS r (Bool, NamedArgumentNew 'Parsed) -> ParsecS r [NamedArgumentNew 'Parsed] + itemHelper p = do + (isLast, item) <- p + let acc' = item : acc + if + | isLast -> return acc' + | otherwise -> go acc' + + pIsLast :: ParsecS r Bool + pIsLast = + rbrace $> True + <|> semicolon $> False + + withIsLast :: ParsecS r a -> ParsecS r (Bool, a) + withIsLast p = do + res <- p + isLast <- pIsLast + return (isLast, res) pisExhaustive :: forall r. @@ -1013,8 +1052,7 @@ namedApplicationNew = P.label "" $ do exhaustive <- pisExhaustive lbrace return (n, exhaustive) - _namedApplicationNewArguments <- P.sepEndBy namedArgumentNew semicolon - rbrace + _namedApplicationNewArguments <- manyNamedArgumentNewRBrace let _namedApplicationNewExtra = Irrelevant () return NamedApplicationNew {..} diff --git a/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs b/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs index a42e934821..b1df8feac2 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs @@ -726,7 +726,11 @@ createArgumentBlocks appargs = . evalState args0 . mapM_ goBlock where - args0 :: HashSet S.Symbol = hashSet ((^. namedArgumentNewSymbol) <$> appargs) + namedArgumentRefSymbol :: NamedArgumentNew 'Scoped -> S.Symbol + namedArgumentRefSymbol = \case + NamedArgumentNewFunction p -> p ^. namedArgumentFunctionDef . signName + NamedArgumentItemPun p -> over S.nameConcrete fromUnqualified' (p ^. namedArgumentReferencedSymbol . scopedIdenFinal) + args0 :: HashSet S.Symbol = hashSet (namedArgumentRefSymbol <$> appargs) goBlock :: forall r. (Members '[State (HashSet S.Symbol), Output (ArgumentBlock 'Scoped)] r) => @@ -738,7 +742,7 @@ createArgumentBlocks appargs = HashSet.intersection (HashMap.keysSet _nameBlock) (HashSet.map (^. S.nameConcrete) args) - argNames :: HashMap Symbol S.Symbol = hashMap . map (\n -> (n ^. S.nameConcrete, n)) $ toList args + argNames :: HashMap Symbol S.Symbol = indexedByHash (^. S.nameConcrete) args getName sym = fromJust (argNames ^. at sym) whenJust (nonEmpty namesInBlock) $ \(namesInBlock1 :: NonEmpty Symbol) -> do let block' = @@ -755,7 +759,12 @@ createArgumentBlocks appargs = NamedArgumentAssign { _namedArgName = sym, _namedArgAssignKw = Irrelevant dummyKw, - _namedArgValue = Concrete.ExpressionIdentifier (ScopedIden name Nothing) + _namedArgValue = + Concrete.ExpressionIdentifier + ScopedIden + { _scopedIdenFinal = name, + _scopedIdenAlias = Nothing + } } where name :: S.Name = over S.nameConcrete NameUnqualified sym diff --git a/test/Scope/Positive.hs b/test/Scope/Positive.hs index a635689a05..3691452f49 100644 --- a/test/Scope/Positive.hs +++ b/test/Scope/Positive.hs @@ -245,5 +245,9 @@ tests = posTest "Public import" $(mkRelDir "PublicImports") - $(mkRelFile "Main.juvix") + $(mkRelFile "Main.juvix"), + posTest + "Named argument puns" + $(mkRelDir ".") + $(mkRelFile "Puns.juvix") ] diff --git a/tests/positive/Puns.juvix b/tests/positive/Puns.juvix new file mode 100644 index 0000000000..6f8bf4df9a --- /dev/null +++ b/tests/positive/Puns.juvix @@ -0,0 +1,25 @@ +module Puns; + +type A := a; + +type B := b; + +type S := + mkS { + fieldA : A; + fieldB : B; + fieldC : A; + fieldD : B; + fieldE : B + }; + +f (fieldA : A) (fieldB : B) : S := + let + fieldD := b; + in mkS@{ + fieldC := fieldA; + fieldA; + fieldB; + fieldE := b; + fieldD + };