Remove old named application syntax

src/Juvix/Compiler/Concrete/Data/Name.hs

@@ -107,6 +107,9 @@ instance HasLoc TopModulePath where
       [] -> getLoc _modulePathName
       (x : _) -> getLoc x <> getLoc _modulePathName
 
+mkTopModulePath :: NonEmpty Symbol -> TopModulePath
+mkTopModulePath l = TopModulePath (NonEmpty.init l) (NonEmpty.last l)
+
 topModulePathToName :: TopModulePath -> Name
 topModulePathToName (TopModulePath ms m) = case nonEmpty ms of
   Nothing -> NameUnqualified m

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

@@ -11,7 +11,6 @@ module Juvix.Compiler.Concrete.Data.NameSignature.Builder
 where
 
 import Juvix.Compiler.Concrete.Data.NameSignature.Error
-import Juvix.Compiler.Concrete.Extra (symbolParsed)
 import Juvix.Compiler.Concrete.Gen qualified as Gen
 import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error
 import Juvix.Prelude

src/Juvix/Compiler/Concrete/Extra.hs

@@ -82,11 +82,6 @@ groupStatements = \case
                     ^. S.nameConcrete
                     : map (^. constructorName . S.nameConcrete) constructors
 
-symbolParsed :: forall s. (SingI s) => SymbolType s -> Symbol
-symbolParsed sym = case sing :: SStage s of
-  SParsed -> sym
-  SScoped -> sym ^. S.nameConcrete
-
 flattenStatement :: Statement s -> [Statement s]
 flattenStatement = \case
   StatementModule m -> concatMap flattenStatement (m ^. moduleBody)

src/Juvix/Compiler/Concrete/Gen.hs

@@ -18,6 +18,11 @@ kw k = do
         _keywordRefInterval = loc
       }
 
+simplestFunctionDefParsed :: (Member (Reader Interval) r) => Text -> NonEmpty (ExpressionAtom 'Parsed) -> Sem r (FunctionDef 'Parsed)
+simplestFunctionDefParsed funNameTxt funBody = do
+  funName <- symbol funNameTxt
+  return (simplestFunctionDef funName (mkExpressionAtoms funBody))
+
 simplestFunctionDef :: FunctionName s -> ExpressionType s -> FunctionDef s
 simplestFunctionDef funName funBody =
   FunctionDef
@@ -60,18 +65,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 +90,25 @@ 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
+mkIsExhaustive :: (Member (Reader Interval) r) => Bool -> Sem r IsExhaustive
+mkIsExhaustive _isExhaustive = do
+  keyw <-
+    if
+        | _isExhaustive -> kw kwAt
+        | otherwise -> kw kwAtQuestion
   return
-    ArgumentBlock
-      { _argBlockImplicit = i,
-        _argBlockDelims = Irrelevant (Just (parenL, parenR)),
-        _argBlockArgs = as
+    IsExhaustive
+      { _isExhaustiveKw = Irrelevant keyw,
+        _isExhaustive
       }
-  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 -> IsExhaustive -> [NamedArgumentNew 'Parsed] -> ExpressionAtom 'Parsed
+namedApplication n exh as =
+  AtomNamedApplicationNew
+    NamedApplicationNew
+      { _namedApplicationNewName = n,
+        _namedApplicationNewExhaustive = exh,
+        _namedApplicationNewArguments = as
       }
 
 literalInteger :: (Member (Reader Interval) r, Integral a) => a -> Sem r (ExpressionAtom 'Parsed)

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)
 
@@ -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)
 
@@ -2902,7 +2874,6 @@ makeLenses ''Initializer
 makeLenses ''Range
 makeLenses ''ArgumentBlock
 makeLenses ''NamedArgumentAssign
-makeLenses ''NamedApplication
 makeLenses ''NamedArgumentNew
 makeLenses ''NamedApplicationNew
 makeLenses ''AliasDef
@@ -2988,9 +2959,6 @@ instance (SingI s) => HasLoc (ArgumentBlock s) where
 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 +2986,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 +3068,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,8 +3136,13 @@ 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 (SingI s) => HasLoc (NamedArgumentFunctionDef s) where
+  getLoc (NamedArgumentFunctionDef f) = getLoc f
+
+instance (SingI s) => HasLoc (NamedArgumentNew s) where
+  getLoc = \case
+    NamedArgumentNewFunction f -> getLoc f
+    NamedArgumentItemPun f -> getLoc f
 
 instance HasLoc (NamedArgumentPun s) where
   getLoc NamedArgumentPun {..} = getLocSymbolType _namedArgumentPunSymbol
@@ -3220,7 +3195,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 +3249,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 +3398,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)
 
@@ -3462,6 +3463,16 @@ _RecordStatementField f x = case x of
   RecordStatementField p -> RecordStatementField <$> f p
   _ -> pure x
 
+symbolParsed :: forall s. (SingI s) => SymbolType s -> Symbol
+symbolParsed sym = case sing :: SStage s of
+  SParsed -> sym
+  SScoped -> sym ^. S.nameConcrete
+
+namedArgumentNewSymbolParsed :: (SingI s) => SimpleGetter (NamedArgumentNew s) Symbol
+namedArgumentNewSymbolParsed = to $ \case
+  NamedArgumentItemPun a -> a ^. namedArgumentPunSymbol
+  NamedArgumentNewFunction a -> symbolParsed (a ^. namedArgumentFunctionDef . signName)
+
 namedArgumentNewSymbol :: Lens' (NamedArgumentNew 'Parsed) Symbol
 namedArgumentNewSymbol f = \case
   NamedArgumentItemPun a -> NamedArgumentItemPun <$> namedArgumentPunSymbol f a

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