Fix named application bug (#3075)

- Fixes #3074

- Merge after #3076

---------

Co-authored-by: Łukasz Czajka <62751+lukaszcz@users.noreply.github.com>

src/Juvix/Compiler/Concrete/Data/NameSignature/Builder.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE FunctionalDependencies #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# OPTIONS_GHC -Wno-unused-type-patterns #-}
 
+{-# HLINT ignore "Avoid restricted flags" #-}
+
 module Juvix.Compiler.Concrete.Data.NameSignature.Builder
   ( mkNameSignature,
     mkRecordNameSignature,
@@ -32,7 +35,8 @@ data BuilderState (s :: Stage) = BuilderState
     -- | maps to itself
     _stateSymbols :: HashMap Symbol (SymbolType s),
     _stateReverseClosedBlocks :: [NameBlock s],
-    _stateCurrentBlock :: HashMap Symbol (NameItem s)
+    -- | Items stored in reverse order
+    _stateCurrentBlockReverse :: [NameItem s]
   }
 
 makeLenses ''BuilderState
@@ -116,7 +120,7 @@ iniBuilderState =
       _stateNextIx = 0,
       _stateSymbols = mempty,
       _stateReverseClosedBlocks = [],
-      _stateCurrentBlock = mempty
+      _stateCurrentBlockReverse = mempty
     }
 
 fromBuilderState :: forall s. BuilderState s -> NameSignature s
@@ -126,11 +130,16 @@ fromBuilderState b =
     }
   where
     addCurrent :: [NameBlock s] -> [NameBlock s]
-    addCurrent
-      | null (b ^. stateCurrentBlock) = id
-      | Just i <- b ^. stateCurrentImplicit =
-          (NameBlock (b ^. stateCurrentBlock) i :)
-      | otherwise = id
+    addCurrent = case (nonEmpty (reverse (b ^. stateCurrentBlockReverse)), b ^. stateCurrentImplicit) of
+      (Just newBlock, Just i) -> (mkNameBlock newBlock i :)
+      _ -> id
+
+mkNameBlock :: NonEmpty (NameItem s) -> IsImplicit -> NameBlock s
+mkNameBlock items impl =
+  NameBlock
+    { _nameBlockItems = items,
+      _nameBlockImplicit = impl
+    }
 
 addExpression :: forall r. (Members '[NameSignatureBuilder 'Scoped] r) => Expression -> Sem r ()
 addExpression = \case
@@ -185,18 +194,19 @@ addSigArg a = case a ^. sigArgNames of
   SigArgNamesInstance {} -> addArg (ArgumentWildcard (Wildcard (getLoc a)))
   SigArgNames ns -> mapM_ addArg ns
   where
+    defaultType :: ExpressionType s
     defaultType = run (runReader (getLoc a) Gen.smallUniverseExpression)
 
     addArg :: Argument s -> Sem r ()
-    addArg arg =
+    addArg arg = do
       let sym :: Maybe (SymbolType s) = case arg of
             ArgumentSymbol sy -> Just sy
             ArgumentWildcard {} -> Nothing
-       in addArgument
-            (a ^. sigArgImplicit)
-            (a ^. sigArgDefault)
-            sym
-            (fromMaybe defaultType (a ^. sigArgType))
+      addArgument
+        (a ^. sigArgImplicit)
+        (a ^. sigArgDefault)
+        sym
+        (fromMaybe defaultType (a ^. sigArgType))
 
 type Re s r = State (BuilderState s) ': Error (BuilderState s) ': Error NameSignatureError ': r
 
@@ -244,28 +254,29 @@ addArgument' impl mdef msym ty = do
     addToCurrentBlock = do
       idx <- getNextIx
       whenJust msym $ \(sym :: SymbolType s) -> do
-        let itm =
-              NameItem
-                { _nameItemDefault = mdef,
-                  _nameItemSymbol = sym,
-                  _nameItemImplicit = impl,
-                  _nameItemIndex = idx,
-                  _nameItemType = ty
-                }
-            psym = symbolParsed sym
+        let psym = symbolParsed sym
         whenJustM (gets @(BuilderState s) (^. stateSymbols . at psym)) (errDuplicateName sym . symbolParsed)
         modify' @(BuilderState s) (set (stateSymbols . at psym) (Just sym))
-        modify' @(BuilderState s) (set (stateCurrentBlock . at psym) (Just itm))
+      let itm =
+            NameItem
+              { _nameItemDefault = mdef,
+                _nameItemSymbol = msym,
+                _nameItemImplicit = impl,
+                _nameItemIndex = idx,
+                _nameItemType = ty
+              }
+      modify' @(BuilderState s) (over (stateCurrentBlockReverse) (itm :))
 
     startNewBlock :: Sem (Re s r) ()
     startNewBlock = do
-      curBlock <- gets @(BuilderState s) (^. stateCurrentBlock)
+      curBlock <- nonEmpty' . reverse <$> gets @(BuilderState s) (^. stateCurrentBlockReverse)
       mcurImpl <- gets @(BuilderState s) (^. stateCurrentImplicit)
       modify' @(BuilderState s) (set stateCurrentImplicit (Just impl))
-      modify' @(BuilderState s) (set stateCurrentBlock mempty)
+      modify' @(BuilderState s) (set stateCurrentBlockReverse mempty)
       modify' @(BuilderState s) (set stateNextIx 0)
       whenJust mcurImpl $ \curImpl ->
-        modify' (over stateReverseClosedBlocks (NameBlock curBlock curImpl :))
+        let newBlock = mkNameBlock curBlock curImpl
+         in modify' (over stateReverseClosedBlocks (newBlock :))
       addArgument' impl mdef msym ty
 
 endBuild' :: forall s r a. Sem (Re s r) a
@@ -275,15 +286,15 @@ mkRecordNameSignature :: forall s. (SingI s) => RhsRecord s -> RecordNameSignatu
 mkRecordNameSignature rhs =
   RecordNameSignature $
     hashMap
-      [ ( symbolParsed _nameItemSymbol,
+      [ ( symbolParsed sym,
           NameItem
-            { _nameItemSymbol,
+            { _nameItemSymbol = Just sym,
               _nameItemIndex,
               _nameItemType = field ^. fieldType,
               _nameItemImplicit = fromIsImplicitField (field ^. fieldIsImplicit),
               _nameItemDefault = Nothing
             }
         )
         | (Indexed _nameItemIndex field) <- indexFrom 0 (toList (rhs ^.. rhsRecordStatements . each . _RecordStatementField)),
-          let _nameItemSymbol :: SymbolType s = field ^. fieldName
+          let sym :: SymbolType s = field ^. fieldName
       ]

src/Juvix/Compiler/Concrete/Language/Base.hs

@@ -156,7 +156,9 @@ type family ModuleEndType t = res | res -> t where
 type ParsedPragmas = WithLoc (WithSource Pragmas)
 
 data NameItem (s :: Stage) = NameItem
-  { _nameItemSymbol :: SymbolType s,
+  { -- | The symbol cannot be omitted for explicit arguments
+    _nameItemSymbol :: Maybe (SymbolType s),
+    -- | NOTE the index is wrt to the block, not the whole signature
     _nameItemIndex :: Int,
     _nameItemImplicit :: IsImplicit,
     _nameItemType :: ExpressionType s,
@@ -173,10 +175,8 @@ instance Serialize (NameItem 'Parsed)
 instance NFData (NameItem 'Parsed)
 
 data NameBlock (s :: Stage) = NameBlock
-  { -- | Symbols map to themselves so we can retrieve the location
-    -- | NOTE the index is wrt to the block, not the whole signature.
-    _nameBlock :: HashMap Symbol (NameItem s),
-    _nameImplicit :: IsImplicit
+  { _nameBlockItems :: NonEmpty (NameItem s),
+    _nameBlockImplicit :: IsImplicit
   }
   deriving stock (Generic)
 
@@ -3519,6 +3519,9 @@ fromParsedIteratorInfo ParsedIteratorInfo {..} =
       _iteratorInfoRangeNum = (^. withLocParam) <$> _parsedIteratorInfoRangeNum
     }
 
+nameBlockSymbols :: forall s. Traversal' (NameBlock s) (SymbolType s)
+nameBlockSymbols = nameBlockItems . each . nameItemSymbol . _Just
+
 instance HasFixity PostfixApplication where
   getFixity (PostfixApplication _ op) = fromMaybe impossible (op ^. scopedIdenSrcName . S.nameFixity)
 

src/Juvix/Compiler/Concrete/Print/Base.hs

@@ -195,15 +195,23 @@ instance (SingI s) => PrettyPrint (ListPattern s) where
 instance PrettyPrint Interval where
   ppCode = noLoc . pretty
 
+instance PrettyPrint Int where
+  ppCode = noLoc . pretty
+
 instance PrettyPrint Void where
   ppCode = absurd
 
 instance (SingI s) => PrettyPrint (NameItem s) where
+  ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => NameItem s -> Sem r ()
   ppCode NameItem {..} = do
     let defaultVal = do
           d <- _nameItemDefault
           return (noLoc C.kwAssign <+> ppExpressionType (d ^. argDefaultValue))
-    isImplicitDelims _nameItemImplicit (ppSymbolType _nameItemSymbol)
+        ppSym :: Maybe (SymbolType s) -> Sem r ()
+        ppSym = \case
+          Nothing -> ppCode Kw.kwWildcard
+          Just s -> ppSymbolType s
+    isImplicitDelims _nameItemImplicit (ppSym _nameItemSymbol)
       <> ppCode Kw.kwExclamation
       <> noLoc (pretty _nameItemIndex)
       <+> ppCode Kw.kwColon
@@ -218,7 +226,10 @@ isImplicitDelims = \case
 
 instance (SingI s) => PrettyPrint (NameBlock s) where
   ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => NameBlock s -> Sem r ()
-  ppCode NameBlock {..} = isImplicitDelims _nameImplicit (vsepSemicolon (map ppCode (toList _nameBlock)))
+  ppCode NameBlock {..} =
+    isImplicitDelims _nameBlockImplicit
+      . vsepSemicolon
+      $ fmap ppCode _nameBlockItems
 
 instance (PrettyPrint a, PrettyPrint b) => PrettyPrint (HashMap a b) where
   ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => HashMap a b -> Sem r ()

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

@@ -2715,16 +2715,21 @@ checkNamedApplicationNew napp = do
     if
         | null nargs -> return (NameSignature [])
         | otherwise -> getNameSignatureParsed aname
-  let namesInSignature = hashSet (concatMap (HashMap.keys . (^. nameBlock)) (sig ^. nameSignatureArgs))
+  let namesInSignature =
+        hashSet $
+          sig
+            ^.. nameSignatureArgs
+              . each
+              . nameBlockSymbols
   forM_ nargs (checkNameInSignature namesInSignature . (^. namedArgumentNewSymbol))
   puns <- scopePuns
   args' <- withLocalScope . localBindings . ignoreSyntax $ do
     mapM_ reserveNamedArgumentName nargs
     mapM (checkNamedArgumentNew puns) nargs
   let signatureExplicitNames =
         hashSet
-          . concatMap (HashMap.keys . (^. nameBlock))
-          . filter (not . isImplicitOrInstance . (^. nameImplicit))
+          . concatMap (^.. nameBlockSymbols)
+          . filter (not . isImplicitOrInstance . (^. nameBlockImplicit))
           $ sig ^. nameSignatureArgs
       givenNames :: HashSet Symbol = hashSet (map (^. namedArgumentNewSymbol) nargs)
       missingArgs = HashSet.difference signatureExplicitNames givenNames
@@ -2807,7 +2812,8 @@ checkRecordUpdate RecordUpdate {..} = do
   where
     bindRecordUpdateVariable :: NameItem 'Parsed -> Sem r (IsImplicit, S.Symbol)
     bindRecordUpdateVariable NameItem {..} = do
-      v <- bindVariableSymbol _nameItemSymbol
+      -- all fields have names so it is safe to use fromJust
+      v <- bindVariableSymbol (fromJust _nameItemSymbol)
       return (_nameItemImplicit, v)
 
 checkUpdateField ::