1
1
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:
Jan Mas Rovira 2022-02-18 01:53:10 +01:00
parent 85601c6332
commit 4651906e32
10 changed files with 260 additions and 143 deletions

View File

@ -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

View File

@ -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)

View File

@ -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
--------------------------------------------------------------------------------

View File

@ -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])

View File

@ -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

View File

@ -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 {..} =

View File

@ -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)

View File

@ -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

View File

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

View File

@ -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"