[scoper] use atoms information instead of scope to parse infix operators

package.yaml

@@ -43,6 +43,7 @@ dependencies:
 - template-haskell == 2.17.*
 - text == 1.2.*
 - th-utilities == 0.2.*
+- uniplate
 - unordered-containers == 0.2.*
 
 # the tasty dependencies are here to avoid having to recompile minijuvix
@@ -61,6 +62,7 @@ ghc-options:
 
 default-extensions:
 - DataKinds
+- DeriveDataTypeable
 - DeriveLift
 - DerivingStrategies
 - FlexibleContexts

src/MiniJuvix/Syntax/Concrete/Fixity.hs

@@ -1,13 +1,13 @@
+
 module MiniJuvix.Syntax.Concrete.Fixity where
 
-import Language.Haskell.TH.Syntax (Lift)
 import MiniJuvix.Prelude
 
 data Precedence =
   PrecMinusOmega
   | PrecNat Natural
   | PrecOmega
-  deriving stock (Show, Eq, Lift)
+  deriving stock (Show, Eq, Data)
 
 instance Ord Precedence where
   compare a b = case (a, b) of
@@ -21,10 +21,10 @@ instance Ord Precedence where
 
 
 data UnaryAssoc = AssocPostfix
-  deriving stock (Show, Eq, Ord, Lift)
+  deriving stock (Show, Eq, Ord, Data)
 
 data BinaryAssoc = AssocNone | AssocLeft | AssocRight
-  deriving stock (Show, Eq, Ord, Lift)
+  deriving stock (Show, Eq, Ord, Data)
 
 data OperatorArity
   = Unary
@@ -33,10 +33,10 @@ data OperatorArity
   | Binary
       { binaryAssoc :: BinaryAssoc
       }
-  deriving stock (Show, Eq, Ord, Lift)
+  deriving stock (Show, Eq, Ord, Data)
 
 data Fixity = Fixity
   { fixityPrecedence :: Precedence,
     fixityArity :: OperatorArity
   }
-  deriving stock (Show, Eq, Ord, Lift)
+  deriving stock (Show, Eq, Ord, Data)

src/MiniJuvix/Syntax/Concrete/Language.hs

@@ -1,3 +1,4 @@
+
 {-# LANGUAGE UndecidableInstances #-}
 
 module MiniJuvix.Syntax.Concrete.Language
@@ -139,7 +140,7 @@ data Usage
   = UsageNone
   | UsageOnce
   | UsageOmega
-  deriving stock (Show, Eq, Ord)
+  deriving stock (Show, Eq, Ord, Data)
 
 -------------------------------------------------------------------------------
 -- Type signature declaration
@@ -156,6 +157,8 @@ deriving stock instance (Eq (ExpressionType s), Eq (SymbolType s)) => Eq (TypeSi
 
 deriving stock instance (Ord (ExpressionType s), Ord (SymbolType s)) => Ord (TypeSignature s)
 
+deriving stock instance (Data (ExpressionType s), Data (SymbolType s), Typeable s) => Data (TypeSignature s)
+
 -------------------------------------------------------------------------------
 -- Axioms
 -------------------------------------------------------------------------------
@@ -224,14 +227,14 @@ data PatternInfixApp = PatternInfixApp
     patInfixConstructor :: NameType 'Scoped,
     patInfixRight :: Pattern
   }
-  deriving stock (Show, Eq, Ord)
+  deriving stock (Show, Eq, Ord, Data)
 
 data PatternPostfixApp = PatternPostfixApp
   {
     patPostfixParameter :: Pattern,
     patPostfixConstructor :: NameType 'Scoped
   }
-  deriving stock (Show, Eq, Ord)
+  deriving stock (Show, Eq, Ord, Data)
 
 data Pattern
   = PatternVariable (SymbolType 'Scoped)
@@ -241,7 +244,7 @@ data Pattern
   | PatternPostfixApplication PatternPostfixApp
   | PatternWildcard
   | PatternEmpty
-  deriving stock (Show, Eq, Ord)
+  deriving stock (Show, Eq, Ord, Data)
 
 --------------------------------------------------------------------------------
 -- Pattern section
@@ -274,6 +277,14 @@ deriving stock instance
   ) =>
   Ord (PatternAtom s)
 
+deriving stock instance
+  ( Data (ExpressionType s),
+    Data (NameType s),
+    Data (PatternType s),
+    Typeable s
+  ) =>
+  Data (PatternAtom s)
+
 newtype PatternAtoms (s :: Stage)
   = PatternAtoms (NonEmpty (PatternAtom s))
 
@@ -298,6 +309,14 @@ deriving stock instance
   ) =>
   Ord (PatternAtoms s)
 
+deriving stock instance
+  ( Data (ExpressionType s),
+    Data (NameType s),
+    Data (PatternType s),
+    Typeable s
+  ) =>
+  Data (PatternAtoms s)
+
 --------------------------------------------------------------------------------
 -- Function binding declaration
 --------------------------------------------------------------------------------
@@ -335,6 +354,15 @@ deriving stock instance
   ) =>
   Ord (FunctionClause s)
 
+deriving stock instance
+  ( Data (PatternType s),
+    Data (NameType s),
+    Data (SymbolType s),
+    Data (ExpressionType s),
+    Typeable s
+  ) =>
+  Data (FunctionClause s)
+
 --------------------------------------------------------------------------------
 -- Module declaration
 --------------------------------------------------------------------------------
@@ -399,7 +427,7 @@ deriving stock instance
 data UsingHiding
   = Using (NonEmpty Symbol)
   | Hiding (NonEmpty Symbol)
-  deriving stock (Show, Eq, Ord)
+  deriving stock (Show, Eq, Ord, Data)
 
 data OpenModule (s :: Stage) = OpenModule
   { openModuleName :: NameType s,
@@ -415,6 +443,7 @@ deriving stock instance
     Eq (ExpressionType s)
   ) =>
   Eq (OpenModule s)
+
 deriving stock instance
   (
     Ord (NameType s),
@@ -423,6 +452,17 @@ deriving stock instance
     Ord (ExpressionType s)
   ) =>
   Ord (OpenModule s)
+
+deriving stock instance
+  (
+    Data (NameType s),
+    Data (SymbolType s),
+    Data (PatternType s),
+    Data (ExpressionType s),
+    Typeable s
+  ) =>
+  Data (OpenModule s)
+
 deriving stock instance
   (
     Show (NameType s),
@@ -445,7 +485,7 @@ data Expression
   | ExpressionLetBlock (LetBlock 'Scoped)
   | ExpressionUniverse Universe
   | ExpressionFunction (Function 'Scoped)
-  deriving stock (Show, Eq, Ord)
+  deriving stock (Show, Eq, Ord, Data)
 
 --------------------------------------------------------------------------------
 -- Expression section
@@ -486,6 +526,15 @@ deriving stock instance
   ) =>
   Ord (ExpressionAtom s)
 
+deriving stock instance
+  ( Data (ExpressionType s),
+    Data (NameType s),
+    Data (SymbolType s),
+    Data (PatternType s),
+    Typeable s
+  ) =>
+  Data (ExpressionAtom s)
+
 -- | Expressions without application
 newtype ExpressionAtoms (s :: Stage)
   = ExpressionAtoms (NonEmpty (ExpressionAtom s))
@@ -514,6 +563,16 @@ deriving stock instance
   ) =>
   Ord (ExpressionAtoms s)
 
+deriving stock instance
+  ( Data (ExpressionType s),
+    Data (NameType s),
+    Data (SymbolType s),
+    Data (PatternType s),
+   Typeable s
+  ) =>
+  Data (ExpressionAtoms s)
+
+
 --------------------------------------------------------------------------------
 -- Match expression
 --------------------------------------------------------------------------------
@@ -541,6 +600,14 @@ deriving stock instance
   ) =>
   Ord (MatchAlt s)
 
+deriving stock instance
+  ( Data (ExpressionType s),
+    Data (PatternType s),
+    Typeable s
+  ) =>
+  Data (MatchAlt s)
+
+
 data Match (s :: Stage) = Match
   { matchExpression :: ExpressionType s,
     matchAlts :: [MatchAlt s]
@@ -564,6 +631,14 @@ deriving stock instance
   ) =>
   Ord (Match s)
 
+deriving stock instance
+  ( Data (ExpressionType s),
+    Data (PatternType s),
+    Typeable s
+  ) =>
+  Data (Match s)
+
+
 --------------------------------------------------------------------------------
 -- Universe expression
 --------------------------------------------------------------------------------
@@ -571,7 +646,7 @@ deriving stock instance
 newtype Universe = Universe
   { universeLevel :: Maybe Natural
   }
-  deriving stock (Show, Eq, Ord)
+  deriving stock (Show, Eq, Ord, Data)
 
 --------------------------------------------------------------------------------
 -- Function expression
@@ -589,6 +664,8 @@ deriving stock instance (Eq (ExpressionType s), Eq (SymbolType s)) => Eq (Functi
 
 deriving stock instance (Ord (ExpressionType s), Ord (SymbolType s)) => Ord (FunctionParameter s)
 
+deriving stock instance (Data (ExpressionType s), Data (SymbolType s), Typeable s) => Data (FunctionParameter s)
+
 data Function (s :: Stage) = Function
   { funParameter :: FunctionParameter s,
     funReturn :: ExpressionType s
@@ -600,6 +677,8 @@ deriving stock instance (Eq (ExpressionType s), Eq (SymbolType s)) => Eq (Functi
 
 deriving stock instance (Ord (ExpressionType s), Ord (SymbolType s)) => Ord (Function s)
 
+deriving stock instance (Data (ExpressionType s), Data (SymbolType s), Typeable s) => Data (Function s)
+
 --------------------------------------------------------------------------------
 -- Where block clauses
 --------------------------------------------------------------------------------
@@ -632,6 +711,15 @@ deriving stock instance
   ) =>
   Ord (WhereBlock s)
 
+deriving stock instance
+  ( Data (PatternType s),
+    Data (NameType s),
+    Data (SymbolType s),
+    Data (ExpressionType s),
+    Typeable s
+  ) =>
+  Data (WhereBlock s)
+
 data WhereClause (s :: Stage)
   = WhereOpenModule (OpenModule s)
   | WhereTypeSig (TypeSignature s)
@@ -661,6 +749,15 @@ deriving stock instance
   ) =>
   Ord (WhereClause s)
 
+deriving stock instance
+  ( Data (PatternType s),
+    Data (NameType s),
+    Data (SymbolType s),
+    Data (ExpressionType s),
+    Typeable s
+  ) =>
+  Data (WhereClause s)
+
 --------------------------------------------------------------------------------
 -- Lambda expression
 --------------------------------------------------------------------------------
@@ -689,6 +786,13 @@ deriving stock instance
   ) =>
   Ord (Lambda s)
 
+deriving stock instance
+  ( Data (PatternType s),
+    Data (ExpressionType s),
+    Typeable s
+  ) =>
+  Data (Lambda s)
+
 data LambdaClause (s :: Stage) = LambdaClause
   { lambdaParameters :: NonEmpty (PatternType s),
     lambdaBody :: ExpressionType s
@@ -712,6 +816,13 @@ deriving stock instance
   ) =>
   Ord (LambdaClause s)
 
+deriving stock instance
+  ( Data (PatternType s),
+    Data (ExpressionType s),
+    Typeable s
+  ) =>
+  Data (LambdaClause s)
+
 --------------------------------------------------------------------------------
 -- Application expression
 --------------------------------------------------------------------------------
@@ -720,21 +831,21 @@ data Application = Application
   { applicationFunction :: ExpressionType 'Scoped,
     applicationParameter :: ExpressionType 'Scoped
   }
-  deriving stock (Show, Eq, Ord)
+  deriving stock (Show, Eq, Ord, Data)
 
 data InfixApplication = InfixApplication
   { infixAppLeft :: ExpressionType 'Scoped,
     infixAppOperator :: NameType 'Scoped,
     infixAppRight :: ExpressionType 'Scoped
   }
-  deriving stock (Show, Eq, Ord)
+  deriving stock (Show, Eq, Ord, Data)
 
 data PostfixApplication = PostfixApplication
   {
     postfixAppParameter :: ExpressionType 'Scoped,
     postfixAppOperator :: NameType 'Scoped
   }
-  deriving stock (Show, Eq, Ord)
+  deriving stock (Show, Eq, Ord, Data)
 
 --------------------------------------------------------------------------------
 -- Let block expression
@@ -769,6 +880,15 @@ deriving stock instance
   ) =>
   Ord (LetBlock s)
 
+deriving stock instance
+  ( Data (PatternType s),
+    Data (NameType s),
+    Data (SymbolType s),
+    Data (ExpressionType s),
+    Typeable s
+  ) =>
+  Data (LetBlock s)
+
 data LetClause (s :: Stage)
   = LetTypeSig (TypeSignature s)
   | LetFunClause (FunctionClause s)
@@ -797,6 +917,15 @@ deriving stock instance
   ) =>
   Ord (LetClause s)
 
+deriving stock instance
+  ( Data (PatternType s),
+    Data (NameType s),
+    Data (SymbolType s),
+    Data (ExpressionType s),
+    Typeable s
+  ) =>
+  Data (LetClause s)
+
 --------------------------------------------------------------------------------
 -- Debugging statements
 --------------------------------------------------------------------------------

src/MiniJuvix/Syntax/Concrete/Language/Stage.hs

@@ -1,3 +1,4 @@
+
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE StandaloneKindSignatures #-}
 module MiniJuvix.Syntax.Concrete.Language.Stage where
@@ -7,7 +8,7 @@ import MiniJuvix.Prelude
 data Stage
   = Parsed
   | Scoped
-  deriving stock (Show)
+  deriving stock (Show, Data)
 
 $(genSingletons [''Stage])
 

src/MiniJuvix/Syntax/Concrete/Loc.hs

@@ -1,11 +1,11 @@
+
 module MiniJuvix.Syntax.Concrete.Loc where
 
 import MiniJuvix.Prelude
 import Prettyprinter
-import Language.Haskell.TH.Syntax (Lift)
 
 newtype Pos = Pos Word64
-  deriving stock (Show, Eq, Ord, Lift)
+  deriving stock (Show, Eq, Ord, Data)
 
 instance Semigroup Pos where
   Pos x <> Pos y = Pos (x + y)
@@ -19,7 +19,7 @@ data FileLoc = FileLoc {
     -- | Column number
     _locCol :: !Pos
   }
-  deriving stock (Show, Eq, Lift)
+  deriving stock (Show, Eq, Data)
 
 instance Ord FileLoc where
   compare (FileLoc l c) (FileLoc l' c') = compare (l, c) (l', c')
@@ -30,7 +30,7 @@ data Loc = Loc
     -- | Position within the file
     _locFileLoc :: !FileLoc
   }
-  deriving stock (Show, Eq, Ord, Lift)
+  deriving stock (Show, Eq, Ord, Data)
 
 -- | Inclusive interval
 data Interval = Interval {
@@ -38,7 +38,7 @@ data Interval = Interval {
   _intStart :: FileLoc,
   _intEnd :: FileLoc
   }
-  deriving stock (Show, Ord, Eq, Lift)
+  deriving stock (Show, Ord, Eq, Data)
 
 class HasLoc t where
   getLoc :: t -> Interval

src/MiniJuvix/Syntax/Concrete/Name.hs

@@ -1,10 +1,10 @@
+
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module MiniJuvix.Syntax.Concrete.Name where
 
-import Language.Haskell.TH.Syntax (Lift)
 import MiniJuvix.Prelude
 import MiniJuvix.Syntax.Concrete.Loc
 import qualified Data.List.NonEmpty.Extra as NonEmpty
@@ -13,7 +13,7 @@ data Symbol = Symbol {
   _symbolText :: Text,
   _symbolLoc :: Interval
   }
-  deriving stock (Show, Lift)
+  deriving stock (Show, Data)
 
 instance Eq Symbol where
   (==) = (==) `on` _symbolText
@@ -30,7 +30,7 @@ instance Hashable Symbol where
 data Name
   = NameQualified QualifiedName
   | NameUnqualified Symbol
-  deriving stock (Show, Eq, Ord, Lift)
+  deriving stock (Show, Eq, Ord, Data)
 
 instance HasLoc Name where
   getLoc n = case n of
@@ -40,13 +40,13 @@ instance HasLoc Name where
 newtype Path = Path
   { pathParts :: NonEmpty Symbol
   }
-  deriving stock (Show, Eq, Ord, Lift)
+  deriving stock (Show, Eq, Ord, Data)
 
 data QualifiedName = QualifiedName
   { _qualifiedPath :: Path,
     _qualifiedSymbol :: Symbol
   }
-  deriving stock (Show, Eq, Ord, Generic, Lift)
+  deriving stock (Show, Eq, Ord, Generic, Data)
 
 instance HasLoc QualifiedName where
   getLoc QualifiedName {..} =
@@ -66,7 +66,7 @@ data TopModulePath = TopModulePath
   { modulePathDir :: [Symbol],
     modulePathName :: Symbol
   }
-  deriving stock (Show, Eq, Ord, Generic, Lift)
+  deriving stock (Show, Eq, Ord, Generic, Data)
 
 instance HasLoc TopModulePath where
   getLoc TopModulePath {..} =

src/MiniJuvix/Syntax/Concrete/PublicAnn.hs

@@ -1,3 +1,4 @@
+
 module MiniJuvix.Syntax.Concrete.PublicAnn where
 
 import MiniJuvix.Prelude
@@ -7,4 +8,4 @@ data PublicAnn =
   Public
   -- | No annotation. Do not confuse this with 'not public' or 'private'.
   | NoPublic
-  deriving stock (Show, Eq, Ord)
+  deriving stock (Show, Eq, Ord, Data)

src/MiniJuvix/Syntax/Concrete/Scoped/Name.hs

@@ -1,3 +1,4 @@
+
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TemplateHaskell #-}
 
@@ -21,13 +22,13 @@ import qualified Data.Kind as GHC
 --------------------------------------------------------------------------------
 
 newtype NameId = NameId Word64
-  deriving stock (Show, Eq, Ord, Generic)
+  deriving stock (Show, Eq, Ord, Generic, Data)
 
 data AbsModulePath = AbsModulePath
   { absTopModulePath :: C.TopModulePath,
     absLocalPath :: [C.Symbol]
   }
-  deriving stock (Show, Eq, Generic)
+  deriving stock (Show, Eq, Generic, Data)
 
 topModulePathToAbsPath :: C.TopModulePath -> AbsModulePath
 topModulePathToAbsPath p = AbsModulePath p []
@@ -60,7 +61,7 @@ instance Hashable NameId
 data NameFixity
   = NoFixity
   | SomeFixity C.Fixity
-  deriving stock (Show, Eq)
+  deriving stock (Show, Eq, Data)
 
 data NameInfo = NameIndo {
 
@@ -76,7 +77,7 @@ data WhyInScope =
   | BecauseImportedOpened
   -- | Defined in this module.
   | BecauseDefined
-  deriving stock (Show)
+  deriving stock (Show, Data)
 
 type Name = Name' C.Name
 
@@ -97,7 +98,7 @@ data Name' n = Name'
     _nameWhyInScope :: WhyInScope,
     _namePublicAnn :: PublicAnn
   }
-  deriving stock (Show)
+  deriving stock (Show, Data)
 makeLenses ''Name'
 
 instance HasLoc n => HasLoc (Name' n) where

src/MiniJuvix/Syntax/Concrete/Scoped/Name/NameKind.hs

@@ -19,7 +19,7 @@ data NameKind
     KNameLocalModule
   | -- | An top module name.
     KNameTopModule
-  deriving stock (Show, Eq)
+  deriving stock (Show, Eq, Data)
 
 $(genSingletons [''NameKind])
 

src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs

@@ -17,6 +17,7 @@ import qualified MiniJuvix.Syntax.Concrete.Scoped.Name as S
 import MiniJuvix.Syntax.Concrete.Scoped.Scope
 import MiniJuvix.Syntax.Concrete.Scoped.Error
 import MiniJuvix.Prelude
+import Data.Generics.Uniplate.Data
 import qualified Data.List.NonEmpty as NonEmpty
 import MiniJuvix.Syntax.Concrete.Scoped.Name (WhyInScope(BecauseDefined))
 import Test.Tasty.Patterns.Parser (ParseResult(Ambiguous))
@@ -977,109 +978,98 @@ checkStatement s = case s of
 -------------------------------------------------------------------------------
 -- Infix Expression
 -------------------------------------------------------------------------------
-
-makeExpressionTable ::
-  forall r.
-  (Members '[State Scope] r) =>
-  Sem r [[P.Operator Parse Expression]]
-makeExpressionTable = do
-  symbolTable <- mkSymbolTable . toList <$> gets _scopeSymbols
-  -- application has the highest precedence. Arrow has the lowest.
-  return $ [appOp] : symbolTable ++ [[functionOp]]
+makeExpressionTable2 ::
+  ExpressionAtoms 'Scoped -> [[P.Operator Parse Expression]]
+makeExpressionTable2 atoms = [appOp] : symbolTable ++ [[functionOp]]
   where
-    -- TODO think what to do with qualified symbols
-    mkSymbolTable :: [SymbolInfo] -> [[P.Operator Parse Expression]]
-    mkSymbolTable = map (map snd) . groupSortOn fst . mapMaybe (getEntry >=> unqualifiedSymbolOp)
-      where
-        getEntry :: SymbolInfo -> Maybe SymbolEntry
-        getEntry (SymbolInfo m) = case toList m of
-          [] -> impossible
-          [e] -> Just e
-          _ -> Nothing -- ambiguous symbol, will result in an error if found
-        unqualifiedSymbolOp :: SymbolEntry -> Maybe (Precedence, P.Operator Parse Expression)
-        unqualifiedSymbolOp S.Name' {..}
-          | S.SomeFixity Fixity {..} <- _nameFixity = Just $
-            case fixityArity of
-              Unary u -> (fixityPrecedence, P.Postfix (unaryApp <$> parseSymbolId _nameId))
-                where
-                  unaryApp :: S.Name -> Expression -> Expression
-                  unaryApp funName arg = case u of
-                    AssocPostfix -> ExpressionPostfixApplication (PostfixApplication arg funName)
-              Binary b -> (fixityPrecedence, infixLRN (binaryApp <$> parseSymbolId _nameId))
-                where
-                  binaryApp :: S.Name -> Expression -> Expression -> Expression
-                  binaryApp infixAppOperator infixAppLeft infixAppRight =
-                    ExpressionInfixApplication InfixApplication {..}
-                  infixLRN :: Parse (Expression -> Expression -> Expression) -> P.Operator Parse Expression
-                  infixLRN = case b of
-                    AssocLeft -> P.InfixL
-                    AssocRight -> P.InfixR
-                    AssocNone -> P.InfixN
-          | otherwise = Nothing
-        parseSymbolId :: S.NameId -> Parse S.Name
-        parseSymbolId uid = P.token getName mempty
-          where
-            getName :: ExpressionAtom 'Scoped -> Maybe S.Name
-            getName s = case s of
-              AtomIdentifier n'
-                | uid == S._nameId n' -> Just n'
-              _ -> Nothing
+  symbolTable = mkSymbolTable names
+  names :: [S.Name]
+  names = [ s | s@S.Name' {} <- universeBi atoms ]
+  mkSymbolTable :: [S.Name] -> [[P.Operator Parse Expression]]
+  mkSymbolTable = map (map snd) . groupSortOn fst . mapMaybe unqualifiedSymbolOp
+    where
+      unqualifiedSymbolOp :: S.Name -> Maybe (Precedence, P.Operator Parse Expression)
+      unqualifiedSymbolOp S.Name' {..}
+        | S.SomeFixity Fixity {..} <- _nameFixity = Just $
+          case fixityArity of
+            Unary u -> (fixityPrecedence, P.Postfix (unaryApp <$> parseSymbolId _nameId))
+              where
+                unaryApp :: S.Name -> Expression -> Expression
+                unaryApp funName arg = case u of
+                  AssocPostfix -> ExpressionPostfixApplication (PostfixApplication arg funName)
+            Binary b -> (fixityPrecedence, infixLRN (binaryApp <$> parseSymbolId _nameId))
+              where
+                binaryApp :: S.Name -> Expression -> Expression -> Expression
+                binaryApp infixAppOperator infixAppLeft infixAppRight =
+                  ExpressionInfixApplication InfixApplication {..}
+                infixLRN :: Parse (Expression -> Expression -> Expression) -> P.Operator Parse Expression
+                infixLRN = case b of
+                  AssocLeft -> P.InfixL
+                  AssocRight -> P.InfixR
+                  AssocNone -> P.InfixN
+        | otherwise = Nothing
+      parseSymbolId :: S.NameId -> Parse S.Name
+      parseSymbolId uid = P.token getName mempty
+        where
+          getName :: ExpressionAtom 'Scoped -> Maybe S.Name
+          getName s = case s of
+            AtomIdentifier n'
+              | uid == S._nameId n' -> Just n'
+            _ -> Nothing
 
-    -- Application by juxtaposition.
-    appOp :: P.Operator Parse Expression
-    appOp = P.InfixL (app <$ notFollowedByInfix)
-      where
-        notFollowedByInfix :: Parse ()
-        notFollowedByInfix = P.notFollowedBy (P.token infixName mempty)
-          where
-            infixName :: ExpressionAtom 'Scoped -> Maybe S.Name
-            infixName s = case s of
-              AtomIdentifier n
-                | S.hasFixity n -> Just n
-              _ -> Nothing
+  -- Application by juxtaposition.
+  appOp :: P.Operator Parse Expression
+  appOp = P.InfixL (app <$ notFollowedByInfix)
+    where
+      notFollowedByInfix :: Parse ()
+      notFollowedByInfix = P.notFollowedBy (P.token infixName mempty)
+        where
+          infixName :: ExpressionAtom 'Scoped -> Maybe S.Name
+          infixName s = case s of
+            AtomIdentifier n
+              | S.hasFixity n -> Just n
+            _ -> Nothing
 
-        app :: Expression -> Expression -> Expression
-        app f x =
-          ExpressionApplication
-            Application
-              { applicationFunction = f,
-                applicationParameter = x
+      app :: Expression -> Expression -> Expression
+      app f x =
+        ExpressionApplication
+          Application
+            { applicationFunction = f,
+              applicationParameter = x
+            }
+  -- Non-dependent function type: A → B
+  functionOp :: P.Operator Parse Expression
+  functionOp = P.InfixR (nonDepFun <$ P.single AtomFunArrow)
+    where
+      nonDepFun :: Expression -> Expression -> Expression
+      nonDepFun a b =
+        ExpressionFunction
+          Function
+            { funParameter = param,
+              funReturn = b
+            }
+        where
+          param =
+            FunctionParameter
+              { paramName = Nothing,
+                paramUsage = Nothing,
+                paramType = a
               }
-    -- Non-dependent function type: A → B
-    functionOp :: P.Operator Parse Expression
-    functionOp = P.InfixR (nonDepFun <$ P.single AtomFunArrow)
-      where
-        nonDepFun :: Expression -> Expression -> Expression
-        nonDepFun a b =
-          ExpressionFunction
-            Function
-              { funParameter = param,
-                funReturn = b
-              }
-          where
-            param =
-              FunctionParameter
-                { paramName = Nothing,
-                  paramUsage = Nothing,
-                  paramType = a
-                }
 
 parseExpressionAtoms ::
   Members '[Error ScopeError, State Scope] r =>
   ExpressionAtoms 'Scoped ->
   Sem r Expression
 parseExpressionAtoms a@(ExpressionAtoms sections) = do
-  tbl <- makeExpressionTable
-  let parser :: Parse Expression
-      parser = runM (mkExpressionParser tbl) <* P.eof
-      res = P.parse parser filePath (toList sections)
   case res of
     Left {} -> throw (ErrInfixParser
-                       InfixError {
-                        _infixErrAtoms = a
-          })
+                       InfixError {_infixErrAtoms = a})
     Right r -> return r
   where
+  parser :: Parse Expression
+  parser = runM (mkExpressionParser tbl) <* P.eof
+  res = P.parse parser filePath (toList sections)
+  tbl = makeExpressionTable2 a
   filePath = ""
 
 -- | Monad for parsing expression sections.
@@ -1168,24 +1158,16 @@ parseTerm =
 type ParsePat = P.Parsec () [PatternAtom 'Scoped]
 
 makePatternTable ::
-  forall r.
-  (Members '[State Scope] r) =>
-  Sem r [[P.Operator ParsePat Pattern]]
-makePatternTable = do
-  symbolTable <- mkSymbolTable . toList <$> gets _scopeSymbols
-  -- application has the highest precedence.
-  return $ [appOp] : symbolTable
+  PatternAtom 'Scoped -> [[P.Operator ParsePat Pattern]]
+makePatternTable atom = [appOp] : operators
   where
+    operators = mkSymbolTable names
+    names = [ s | s@S.Name' {} <- universeBi atom ]
     -- TODO think what to do with qualified symbols
-    mkSymbolTable :: [SymbolInfo] -> [[P.Operator ParsePat Pattern]]
-    mkSymbolTable = map (map snd) . groupSortOn fst . mapMaybe (getEntry >=> unqualifiedSymbolOp)
+    mkSymbolTable :: [S.Name] -> [[P.Operator ParsePat Pattern]]
+    mkSymbolTable = map (map snd) . groupSortOn fst . mapMaybe unqualifiedSymbolOp
       where
-        getEntry :: SymbolInfo -> Maybe SymbolEntry
-        getEntry (SymbolInfo m) = case toList m of
-          [] -> impossible
-          [e] -> Just e
-          _ -> Nothing -- if this symbol es found will result in an ambiguity error.
-        unqualifiedSymbolOp :: SymbolEntry -> Maybe (Precedence, P.Operator ParsePat Pattern)
+        unqualifiedSymbolOp :: S.Name -> Maybe (Precedence, P.Operator ParsePat Pattern)
         unqualifiedSymbolOp S.Name' {..}
           | S.SomeFixity Fixity {..} <- _nameFixity,
             _nameKind == S.KNameConstructor = Just $
@@ -1314,12 +1296,13 @@ mkPatternParser table = embed @ParsePat pPattern
 parsePatternAtom ::
   Members '[Error ScopeError, State Scope] r => PatternAtom 'Scoped -> Sem r Pattern
 parsePatternAtom sec = do
-  tbl <- makePatternTable
-  let parser :: ParsePat Pattern
-      parser = runM (mkPatternParser tbl) <* P.eof
-      res = P.parse parser filePath [sec]
   case res of
     Left {} -> throw (ErrInfixPattern (InfixErrorP sec))
     Right r -> return r
   where
+    tbl = makePatternTable sec
+    parser :: ParsePat Pattern
+    parser = runM (mkPatternParser tbl) <* P.eof
+    res = P.parse parser filePath [sec]
+
     filePath = "tmp"