Refactor deriving statements in Concrete.Language (#2256)

Deriving instances was a pita because of the extensive use of type
families. I have refactored the code to make it easier to work with

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

@@ -0,0 +1,9 @@
+module Juvix.Compiler.Concrete.Data.IsConcrete where
+
+import Juvix.Prelude
+
+data IsConcrete
+  = NotConcrete
+  | Concrete
+
+$(genSingletons [''IsConcrete])

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

@@ -1,10 +1,12 @@
 module Juvix.Compiler.Concrete.Data.ScopedName
   ( module Juvix.Compiler.Concrete.Data.ScopedName,
+    module Juvix.Compiler.Concrete.Data.IsConcrete,
     module Juvix.Data.NameKind,
     module Juvix.Data.NameId,
   )
 where
 
+import Juvix.Compiler.Concrete.Data.IsConcrete
 import Juvix.Compiler.Concrete.Data.Name qualified as C
 import Juvix.Compiler.Concrete.Data.VisibilityAnn
 import Juvix.Data.Fixity qualified as C
@@ -14,16 +16,6 @@ import Juvix.Data.NameKind
 import Juvix.Prelude
 import Juvix.Prelude.Pretty
 
---------------------------------------------------------------------------------
--- Names
---------------------------------------------------------------------------------
-
-data IsConcrete
-  = NotConcrete
-  | Concrete
-
-$(genSingletons [''IsConcrete])
-
 data AbsModulePath = AbsModulePath
   { _absTopModulePath :: C.TopModulePath,
     _absLocalPath :: [C.Symbol]

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

@@ -0,0 +1,14 @@
+module Juvix.Compiler.Concrete.Data.Stage where
+
+import Data.Kind qualified as GHC
+import Juvix.Prelude
+
+data Stage
+  = Parsed
+  | Scoped
+  deriving stock (Eq, Show)
+
+type AnyStage (k :: Stage -> GHC.Type) =
+  Σ Stage (TyCon1 k)
+
+$(genSingletons [''Stage])

src/Juvix/Compiler/Concrete/Extra.hs

@@ -206,14 +206,14 @@ fromAmbiguousIterator AmbiguousIterator {..} =
     mkInitializer a@NamedArgument {..} =
       Initializer
         { _initializerAssignKw = _namedArgAssignKw,
-          _initializerPattern = PatternAtoms (pure (PatternAtomIden (NameUnqualified _namedArgName))) (getLoc a),
+          _initializerPattern = PatternAtoms (pure (PatternAtomIden (NameUnqualified _namedArgName))) (Irrelevant (getLoc a)),
           _initializerExpression = _namedArgValue
         }
 
 ambiguousIteratorToAtoms :: AmbiguousIterator -> ExpressionAtoms 'Parsed
 ambiguousIteratorToAtoms AmbiguousIterator {..} =
   ExpressionAtoms
-    { _expressionAtomsLoc = getLoc napp,
+    { _expressionAtomsLoc = Irrelevant (getLoc napp),
       _expressionAtoms = pure (AtomNamedApplication napp) <> body
     }
   where

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

@@ -2311,7 +2311,7 @@ parsePatternAtom ::
 parsePatternAtom = parsePatternAtoms . singletonAtom
   where
     singletonAtom :: PatternAtom 'Scoped -> PatternAtoms 'Scoped
-    singletonAtom a = PatternAtoms (NonEmpty.singleton a) (getLoc a)
+    singletonAtom a = PatternAtoms (NonEmpty.singleton a) (Irrelevant (getLoc a))
 
 parsePatternAtoms ::
   (Members '[Error ScoperError, State Scope] r) =>

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

@@ -613,7 +613,7 @@ parseExpressionAtoms ::
   (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) =>
   ParsecS r (ExpressionAtoms 'Parsed)
 parseExpressionAtoms = do
-  (_expressionAtoms, _expressionAtomsLoc) <- interval (P.some expressionAtom)
+  (_expressionAtoms, _expressionAtomsLoc) <- second Irrelevant <$> interval (P.some expressionAtom)
   return ExpressionAtoms {..}
 
 --------------------------------------------------------------------------------
@@ -1081,12 +1081,12 @@ patternAtom' nested = P.label "<pattern>" $ patternAtomNamed nested <|> patternA
 
 parsePatternAtoms :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (PatternAtoms 'Parsed)
 parsePatternAtoms = do
-  (_patternAtoms, _patternAtomsLoc) <- interval (P.some patternAtom)
+  (_patternAtoms, _patternAtomsLoc) <- second Irrelevant <$> interval (P.some patternAtom)
   return PatternAtoms {..}
 
 parsePatternAtomsNested :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (PatternAtoms 'Parsed)
 parsePatternAtomsNested = do
-  (_patternAtoms, _patternAtomsLoc) <- interval (P.some patternAtomNested)
+  (_patternAtoms, _patternAtomsLoc) <- second Irrelevant <$> interval (P.some patternAtomNested)
   return PatternAtoms {..}
 
 --------------------------------------------------------------------------------
@@ -1133,7 +1133,7 @@ atomicExpression = do
   case atom of
     AtomFunArrow {} -> P.failure Nothing mempty
     _ -> return ()
-  return $ ExpressionAtoms (NonEmpty.singleton atom) loc
+  return $ ExpressionAtoms (NonEmpty.singleton atom) (Irrelevant loc)
 
 openModule :: forall r. (Members '[Error ParserError, PathResolver, Files, InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (OpenModule 'Parsed)
 openModule = do