Puns for named application (#2890)

Since it is common to want to assign a named argument a variable of the same name, we add special syntax for it. E.g. ``` f (fieldA : A) (fieldB : B) : S := mkS@{ fieldC := fieldA; -- normal named argument fieldA; -- pun fieldB -- pun }; ```
anoma · Jul 16, 2024 · 2793514 · 2793514
1 parent 5a76e5d
commit 2793514
Show file tree

Hide file tree

Showing 10 changed files with 189 additions and 38 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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 "<named application>" $ 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
@@ -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
@@ -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
@@ -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
+  };