mirror of
https://github.com/anoma/juvix.git
synced 2024-12-13 19:49:20 +03:00
[scoper] use atoms information instead of scope to parse infix operators
This commit is contained in:
parent
85601c6332
commit
4651906e32
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -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])
|
||||
|
||||
|
@ -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
|
||||
|
@ -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 {..} =
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -19,7 +19,7 @@ data NameKind
|
||||
KNameLocalModule
|
||||
| -- | An top module name.
|
||||
KNameTopModule
|
||||
deriving stock (Show, Eq)
|
||||
deriving stock (Show, Eq, Data)
|
||||
|
||||
$(genSingletons [''NameKind])
|
||||
|
||||
|
@ -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,26 +978,17 @@ 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)
|
||||
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
|
||||
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 -> Maybe (Precedence, P.Operator Parse Expression)
|
||||
unqualifiedSymbolOp S.Name' {..}
|
||||
| S.SomeFixity Fixity {..} <- _nameFixity = Just $
|
||||
case fixityArity of
|
||||
@ -1069,17 +1061,15 @@ parseExpressionAtoms ::
|
||||
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"
|
||||
|
Loading…
Reference in New Issue
Block a user