puns for named application

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)

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 :: SymbolType s,
+    _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 (SingI s) => 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

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 (SingI s) => PrettyPrint (NamedArgumentPun s) where
+  ppCode = ppSymbolType . (^. 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

src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs

@@ -1563,8 +1563,8 @@ checkSections sec = topBindings helper
                                 failMaybe $
                                   mkRec
                                     ^? constructorRhs
-                                    . _ConstructorRhsRecord
-                                    . to mkRecordNameSignature
+                                      . _ConstructorRhsRecord
+                                      . to mkRecordNameSignature
                               let info =
                                     RecordInfo
                                       { _recordInfoSignature = fs,
@@ -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,50 @@ 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 -> NamedArgumentItemPun <$> checkNamedArgumentItemPun puns f
+
+checkNamedArgumentItemPun ::
+  (Members '[Error ScoperError, NameIdGen, State Scope, InfoTableBuilder, Reader InfoTable, State ScoperState] r) =>
+  HashMap Symbol ScopedIden ->
+  NamedArgumentPun 'Parsed ->
+  Sem r (NamedArgumentPun 'Scoped)
+checkNamedArgumentItemPun puns NamedArgumentPun {..} = localBindings . ignoreSyntax $ do
+  sym' <- getReservedDefinitionSymbol _namedArgumentPunSymbol
+  return
+    NamedArgumentPun
+      { _namedArgumentPunSymbol = sym',
+        _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

src/Juvix/Compiler/Concrete/Translation/FromSource.hs

@@ -983,11 +983,25 @@ pnamedArgumentFunctionDef = do
       { _namedArgumentFunctionDef = fun
       }
 
+pnamedArgumentItemPun ::
+  forall r.
+  (Members '[ParserResultBuilder, PragmasStash, JudocStash] r) =>
+  ParsecS r (NamedArgumentPun 'Parsed)
+pnamedArgumentItemPun = do
+  sym <- symbol
+  return
+    NamedArgumentPun
+      { _namedArgumentPunSymbol = sym,
+        _namedArgumentReferencedSymbol = ()
+      }
+
 namedArgumentNew ::
   forall r.
   (Members '[ParserResultBuilder, PragmasStash, JudocStash] r) =>
   ParsecS r (NamedArgumentNew 'Parsed)
-namedArgumentNew = NamedArgumentNewFunction <$> pnamedArgumentFunctionDef
+namedArgumentNew =
+  P.try (NamedArgumentItemPun <$> pnamedArgumentItemPun)
+    <|> NamedArgumentNewFunction <$> pnamedArgumentFunctionDef
 
 pisExhaustive ::
   forall r.

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