From 4651906e32273d4f132c7406974a5fd421f13ca6 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Fri, 18 Feb 2022 01:53:10 +0100 Subject: [PATCH] [scoper] use atoms information instead of scope to parse infix operators --- package.yaml | 2 + src/MiniJuvix/Syntax/Concrete/Fixity.hs | 12 +- src/MiniJuvix/Syntax/Concrete/Language.hs | 149 ++++++++++++- .../Syntax/Concrete/Language/Stage.hs | 3 +- src/MiniJuvix/Syntax/Concrete/Loc.hs | 10 +- src/MiniJuvix/Syntax/Concrete/Name.hs | 12 +- src/MiniJuvix/Syntax/Concrete/PublicAnn.hs | 3 +- src/MiniJuvix/Syntax/Concrete/Scoped/Name.hs | 11 +- .../Syntax/Concrete/Scoped/Name/NameKind.hs | 2 +- .../Syntax/Concrete/Scoped/Scoper.hs | 199 ++++++++---------- 10 files changed, 260 insertions(+), 143 deletions(-) diff --git a/package.yaml b/package.yaml index 8150c7e6f..b84964d1e 100644 --- a/package.yaml +++ b/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 diff --git a/src/MiniJuvix/Syntax/Concrete/Fixity.hs b/src/MiniJuvix/Syntax/Concrete/Fixity.hs index 96b9f5d89..3b996c25b 100644 --- a/src/MiniJuvix/Syntax/Concrete/Fixity.hs +++ b/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) diff --git a/src/MiniJuvix/Syntax/Concrete/Language.hs b/src/MiniJuvix/Syntax/Concrete/Language.hs index 8ab0f7c62..9a682c919 100644 --- a/src/MiniJuvix/Syntax/Concrete/Language.hs +++ b/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 -------------------------------------------------------------------------------- diff --git a/src/MiniJuvix/Syntax/Concrete/Language/Stage.hs b/src/MiniJuvix/Syntax/Concrete/Language/Stage.hs index 4fc1f576e..752af87f2 100644 --- a/src/MiniJuvix/Syntax/Concrete/Language/Stage.hs +++ b/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]) diff --git a/src/MiniJuvix/Syntax/Concrete/Loc.hs b/src/MiniJuvix/Syntax/Concrete/Loc.hs index 20076837e..ac401a970 100644 --- a/src/MiniJuvix/Syntax/Concrete/Loc.hs +++ b/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 diff --git a/src/MiniJuvix/Syntax/Concrete/Name.hs b/src/MiniJuvix/Syntax/Concrete/Name.hs index 56d8aeee2..589e8d503 100644 --- a/src/MiniJuvix/Syntax/Concrete/Name.hs +++ b/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 {..} = diff --git a/src/MiniJuvix/Syntax/Concrete/PublicAnn.hs b/src/MiniJuvix/Syntax/Concrete/PublicAnn.hs index 7f945891f..ce601cab3 100644 --- a/src/MiniJuvix/Syntax/Concrete/PublicAnn.hs +++ b/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) diff --git a/src/MiniJuvix/Syntax/Concrete/Scoped/Name.hs b/src/MiniJuvix/Syntax/Concrete/Scoped/Name.hs index fb173214c..aa4627856 100644 --- a/src/MiniJuvix/Syntax/Concrete/Scoped/Name.hs +++ b/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 diff --git a/src/MiniJuvix/Syntax/Concrete/Scoped/Name/NameKind.hs b/src/MiniJuvix/Syntax/Concrete/Scoped/Name/NameKind.hs index 5bf1b12a0..cb2c89881 100644 --- a/src/MiniJuvix/Syntax/Concrete/Scoped/Name/NameKind.hs +++ b/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]) diff --git a/src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs b/src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs index 69ba09cf6..2aaa7ac8a 100644 --- a/src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs +++ b/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"