anoma/juvix
1
1
Fork 0
mirror of https://github.com/anoma/juvix.git synced 2024-11-30 05:42:26 +03:00
Code Issues Projects Releases Wiki Activity

User-friendly operator declaration syntax (#2270)

Browse Source 
* Closes #1964 

Adds the possibility to define operator fixities. They live in a
separate namespace. Standard library defines a few in
`Stdlib.Data.Fixity`:
```

syntax fixity rapp {arity: binary, assoc: right};
syntax fixity lapp {arity: binary, assoc: left, same: rapp};
syntax fixity seq {arity: binary, assoc: left, above: [lapp]};

syntax fixity functor {arity: binary, assoc: right};

syntax fixity logical {arity: binary, assoc: right, above: [seq]};
syntax fixity comparison {arity: binary, assoc: none, above: [logical]};

syntax fixity pair {arity: binary, assoc: right};
syntax fixity cons {arity: binary, assoc: right, above: [pair]};

syntax fixity step {arity: binary, assoc: right};
syntax fixity range {arity: binary, assoc: right, above: [step]};

syntax fixity additive {arity: binary, assoc: left, above: [comparison, range, cons]};
syntax fixity multiplicative {arity: binary, assoc: left, above: [additive]};

syntax fixity composition {arity: binary, assoc: right, above: [multiplicative]};
```

The fixities are identifiers in a separate namespace (different from
symbol and module namespaces). They can be exported/imported and then
used in operator declarations:
```
import Stdlib.Data.Fixity open;

syntax operator && logical;
syntax operator || logical;
syntax operator + additive;
syntax operator * multiplicative;
```
This commit is contained in:
Łukasz Czajka 2023-08-09 18:15:51 +02:00 committed by GitHub
parent 7b000eba0c
commit eebe961321
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
60 changed files with 677 additions and 271 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
app/Commands/Repl.hs
View File

@ -286,6 +286,7 @@ printDocumentation = replParseIdentifiers >=> printIdentifiers
KNameConstructor -> getDocConstructor n
KNameLocalModule -> impossible
KNameTopModule -> impossible
KNameFixity -> impossible
printDoc mdoc
where
printDoc :: Maybe (Concrete.Judoc 'Concrete.Scoped) -> Repl ()
@ -342,6 +343,7 @@ printDefinition = replParseIdentifiers >=> printIdentifiers
KNameConstructor -> printConstructor n
KNameLocalModule -> impossible
KNameTopModule -> impossible
KNameFixity -> impossible
where
printLocation :: HasLoc s => s -> Repl ()
printLocation def = do

14
assets/css/source-ayu-light.css
View File

@ -35,6 +35,10 @@ body {
color: #5c6166;
}
.ju-fixity {
color: #3d4247;
}
.ju-number {
color: #000000;
}
@ -43,11 +47,13 @@ body {
font-weight: bold;
}
a:hover, a.hover-highlight {
background-color: #dadbdc ;
a:hover,
a.hover-highlight {
background-color: #dadbdc;
}
a:link, a:visited {
a:link,
a:visited {
text-decoration: none;
}
@ -59,4 +65,4 @@ footer a {
color: gray;
font-size: small;
font-weight: bold;
}
}

16
assets/css/source-nord.css
View File

@ -35,6 +35,10 @@ body {
color: #d8dee9
}
.ju-fixity {
color: #a4b4d2
}
.ju-number {
color: #d8dee9
}
@ -43,12 +47,14 @@ body {
font-weight: bold;
}
a:link, a:visited {
text-decoration: none;
a:link,
a:visited {
text-decoration: none;
}
a:hover, a.hover-highlight {
background-color: #4c566a;
a:hover,
a.hover-highlight {
background-color: #4c566a;
}
footer {
@ -59,4 +65,4 @@ footer a {
color: gray;
font-size: small;
font-weight: bold;
}
}

2
juvix-stdlib

@ -1 +1 @@
Subproject commit 70136587762ec31f6f6d88fc1b13b610d327417e
Subproject commit 94346ef8e34fd215b277a31d365fd32a5f3a0db5

11
runtime/src/juvix/info.h
View File

@ -2,20 +2,21 @@
#define JUVIX_INFO_H
#include <juvix/defs.h>
#include <juvix/limits.h>
typedef enum { assoc_left, assoc_right, assoc_none } assoc_t;
typedef struct {
int precedence;
int64_t precedence;
assoc_t assoc;
} fixity_t;
#define PREC_MINUS_OMEGA1 (-2)
#define PREC_MINUS_OMEGA (-1)
#define PREC_OMEGA 100000
#define PREC_UPDATE (-(1LL << 63))
#define PREC_ARROW (PREC_UPDATE + 1)
#define PREC_APP (9223372036854775807LL)
#define APP_FIXITY \
{ PREC_OMEGA, assoc_left }
{ PREC_APP, assoc_left }
typedef struct {
const char *name;

6
src/Juvix/Compiler/Backend/C/Translation/FromReg.hs
View File

@ -66,9 +66,9 @@ fromReg lims tab =
getPrec :: Precedence -> Expression
getPrec = \case
PrecMinusOmega1 -> macroVar "PREC_MINUS_OMEGA1"
PrecMinusOmega -> macroVar "PREC_MINUS_OMEGA"
PrecOmega -> macroVar "PREC_OMEGA"
PrecUpdate -> macroVar "PREC_UPDATE"
PrecApp -> macroVar "PREC_APP"
PrecArrow -> macroVar "PREC_ARROW"
PrecNat n -> integer n
getAssoc :: OperatorArity -> Text

1
src/Juvix/Compiler/Backend/Html/Translation/FromTyped/Source.hs
View File

@ -294,6 +294,7 @@ putTag ann x = case ann of
S.KNameAxiom -> "ju-axiom"
S.KNameLocalModule -> "ju-var"
S.KNameTopModule -> "ju-var"
S.KNameFixity -> "ju-fixity"
)
nameIdAttr :: S.NameId -> AttributeValue

1
src/Juvix/Compiler/Concrete/Data/Highlight/RenderEmacs.hs
View File

@ -16,6 +16,7 @@ nameKindFace = \case
KNameLocalModule -> Just FaceModule
KNameAxiom -> Just FaceAxiom
KNameLocal -> Nothing
KNameFixity -> Nothing
fromCodeAnn :: CodeAnn -> Maybe EmacsProperty
fromCodeAnn = \case

8
src/Juvix/Compiler/Concrete/Data/InfoTable.hs
View File

@ -38,7 +38,9 @@ data InfoTable = InfoTable
_infoModules :: HashMap S.TopModulePath (Module 'Scoped 'ModuleTop),
_infoAxioms :: HashMap S.NameId AxiomInfo,
_infoInductives :: HashMap S.NameId InductiveInfo,
_infoFunctions :: HashMap S.NameId FunctionInfo
_infoFunctions :: HashMap S.NameId FunctionInfo,
_infoFixities :: HashMap S.NameId FixityDef,
_infoPriorities :: IntSet
}
emptyInfoTable :: InfoTable
@ -48,7 +50,9 @@ emptyInfoTable =
_infoAxioms = mempty,
_infoModules = mempty,
_infoInductives = mempty,
_infoFunctions = mempty
_infoFunctions = mempty,
_infoFixities = mempty,
_infoPriorities = mempty
}
makeLenses ''InfoTable

12
src/Juvix/Compiler/Concrete/Data/InfoTableBuilder.hs
View File

@ -1,6 +1,7 @@
module Juvix.Compiler.Concrete.Data.InfoTableBuilder where
import Data.HashMap.Strict qualified as HashMap
import Data.IntSet qualified as IntSet
import Juvix.Compiler.Concrete.Data.Highlight.Input
import Juvix.Compiler.Concrete.Data.Scope
import Juvix.Compiler.Concrete.Data.ScopedName
@ -17,6 +18,9 @@ data InfoTableBuilder m a where
RegisterFunctionClause :: FunctionClause 'Scoped -> InfoTableBuilder m ()
RegisterName :: HasLoc c => S.Name' c -> InfoTableBuilder m ()
RegisterModule :: Module 'Scoped 'ModuleTop -> InfoTableBuilder m ()
RegisterFixity :: FixityDef -> InfoTableBuilder m ()
RegisterHighlightDoc :: S.NameId -> Maybe (Judoc 'Scoped) -> InfoTableBuilder m ()
GetInfoTable :: InfoTableBuilder m InfoTable
makeSem ''InfoTableBuilder
@ -74,6 +78,14 @@ toState = reinterpret $ \case
let j = m ^. moduleDoc
modify (over infoModules (HashMap.insert (m ^. modulePath) m))
registerDoc (m ^. modulePath . nameId) j
RegisterFixity f -> do
let fid = f ^. fixityDefSymbol . S.nameId
modify (over infoFixities (HashMap.insert fid f))
modify (over infoPriorities (IntSet.insert (f ^. fixityDefPrec)))
RegisterHighlightDoc fid doc ->
registerDoc fid doc
GetInfoTable ->
get
runInfoTableBuilderRepl :: InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r (InfoTable, a)
runInfoTableBuilderRepl tab = ignoreHighlightBuilder . runInfoTableBuilder tab . raiseUnder

2
src/Juvix/Compiler/Concrete/Data/NameSpace.hs
View File

@ -7,6 +7,7 @@ import Juvix.Prelude
data NameSpace
= NameSpaceSymbols
| NameSpaceModules
| NameSpaceFixities
deriving stock (Eq, Generic, Enum, Bounded, Show, Ord)
instance Hashable NameSpace
@ -25,3 +26,4 @@ type family NameKindNameSpace s = res where
NameKindNameSpace 'KNameAxiom = 'NameSpaceSymbols
NameKindNameSpace 'KNameLocalModule = 'NameSpaceModules
NameKindNameSpace 'KNameTopModule = 'NameSpaceModules
NameKindNameSpace 'KNameFixity = 'NameSpaceFixities

7
src/Juvix/Compiler/Concrete/Data/Scope.hs
View File

@ -17,6 +17,7 @@ nsEntry :: forall ns. SingI ns => Lens' (NameSpaceEntryType ns) (S.Name' ())
nsEntry = case sing :: SNameSpace ns of
SNameSpaceModules -> moduleEntry
SNameSpaceSymbols -> symbolEntry
SNameSpaceFixities -> fixityEntry
mkModuleRef' :: SingI t => ModuleRef'' 'S.NotConcrete t -> ModuleRef' 'S.NotConcrete
mkModuleRef' m = ModuleRef' (sing :&: m)
@ -25,11 +26,13 @@ scopeNameSpace :: forall (ns :: NameSpace). SingI ns => Lens' Scope (HashMap Sym
scopeNameSpace = case sing :: SNameSpace ns of
SNameSpaceSymbols -> scopeSymbols
SNameSpaceModules -> scopeModuleSymbols
SNameSpaceFixities -> scopeFixitySymbols
scopeNameSpaceLocal :: forall (ns :: NameSpace). Sing ns -> Lens' Scope (HashMap Symbol S.Symbol)
scopeNameSpaceLocal s = case s of
SNameSpaceSymbols -> scopeLocalSymbols
SNameSpaceModules -> scopeLocalModuleSymbols
SNameSpaceFixities -> scopeLocalFixitySymbols
emptyScope :: S.AbsModulePath -> Scope
emptyScope absPath =
@ -37,7 +40,9 @@ emptyScope absPath =
{ _scopePath = absPath,
_scopeSymbols = mempty,
_scopeModuleSymbols = mempty,
_scopeFixitySymbols = mempty,
_scopeTopModules = mempty,
_scopeLocalSymbols = mempty,
_scopeLocalModuleSymbols = mempty
_scopeLocalModuleSymbols = mempty,
_scopeLocalFixitySymbols = mempty
}

29
src/Juvix/Compiler/Concrete/Data/Scope/Base.hs
View File

@ -24,6 +24,7 @@ data Scope = Scope
{ _scopePath :: S.AbsModulePath,
_scopeSymbols :: HashMap Symbol (SymbolInfo 'NameSpaceSymbols),
_scopeModuleSymbols :: HashMap Symbol (SymbolInfo 'NameSpaceModules),
_scopeFixitySymbols :: HashMap Symbol (SymbolInfo 'NameSpaceFixities),
-- | The map from S.NameId to Modules is needed because we support merging
-- several imports under the same name. E.g.
-- import A as X;
@ -34,7 +35,8 @@ data Scope = Scope
-- symbol with a different location but we may want the location of the
-- original symbol
_scopeLocalSymbols :: HashMap Symbol S.Symbol,
_scopeLocalModuleSymbols :: HashMap Symbol S.Symbol
_scopeLocalModuleSymbols :: HashMap Symbol S.Symbol,
_scopeLocalFixitySymbols :: HashMap Symbol S.Symbol
}
newtype ModulesCache = ModulesCache
@ -64,13 +66,15 @@ data ScoperState = ScoperState
_scoperConstructorFields :: HashMap S.NameId RecordNameSignature
}
data SymbolFixity = SymbolFixity
{ _symbolFixityUsed :: Bool,
_symbolFixityDef :: OperatorSyntaxDef
data SymbolOperator = SymbolOperator
{ _symbolOperatorUsed :: Bool,
_symbolOperatorFixity :: Fixity,
_symbolOperatorDef :: OperatorSyntaxDef
}
deriving stock (Show)
newtype ScoperFixities = ScoperFixites
{ _scoperFixities :: HashMap Symbol SymbolFixity
newtype ScoperOperators = ScoperOperators
{ _scoperOperators :: HashMap Symbol SymbolOperator
}
deriving newtype (Semigroup, Monoid)
@ -84,12 +88,21 @@ newtype ScoperIterators = ScoperIterators
}
deriving newtype (Semigroup, Monoid)
data ScoperSyntax = ScoperSyntax
{ _scoperSyntaxOperators :: ScoperOperators,
_scoperSyntaxIterators :: ScoperIterators
}
emptyScoperSyntax :: ScoperSyntax
emptyScoperSyntax = ScoperSyntax mempty mempty
makeLenses ''ScoperIterators
makeLenses ''SymbolOperator
makeLenses ''SymbolIterator
makeLenses ''SymbolInfo
makeLenses ''Scope
makeLenses ''ScoperFixities
makeLenses ''SymbolFixity
makeLenses ''ScoperOperators
makeLenses ''ScoperSyntax
makeLenses ''ScoperState
makeLenses ''ScopeParameters
makeLenses ''ModulesCache

1
src/Juvix/Compiler/Concrete/Extra.hs
View File

@ -84,6 +84,7 @@ groupStatements = \case
g :: Statement s -> Statement s -> Bool
g a b = case (a, b) of
(StatementSyntax _, StatementSyntax _) -> True
(StatementSyntax (SyntaxFixity _), _) -> False
(StatementSyntax (SyntaxOperator o), s) -> definesSymbol (o ^. opSymbol) s
(StatementSyntax (SyntaxIterator i), s) -> definesSymbol (i ^. iterSymbol) s
(StatementImport _, StatementImport _) -> True

12
src/Juvix/Compiler/Concrete/Keywords.hs
View File

@ -29,23 +29,21 @@ import Juvix.Data.Keyword.All
kwColon,
kwEnd,
kwEq,
kwFixity,
kwHiding,
kwHole,
kwImport,
kwIn,
kwInductive,
kwInfix,
kwInfixl,
kwInfixr,
kwIterator,
kwLambda,
kwLet,
kwMapsTo,
kwModule,
kwOpen,
kwOperator,
kwPipe,
kwPositive,
kwPostfix,
kwPublic,
kwRightArrow,
kwSyntax,
@ -94,9 +92,7 @@ nonKeywords :: [Keyword]
nonKeywords =
[ kwAs,
kwEq,
kwInfix,
kwInfixl,
kwInfixr,
kwPostfix,
kwFixity,
kwOperator,
kwIterator
]

74
src/Juvix/Compiler/Concrete/Language.hs
View File

@ -31,6 +31,7 @@ import Juvix.Compiler.Concrete.Data.VisibilityAnn
import Juvix.Data
import Juvix.Data.Ape.Base as Ape
import Juvix.Data.Fixity
import Juvix.Data.FixityInfo (FixityInfo)
import Juvix.Data.IteratorAttribs
import Juvix.Data.Keyword
import Juvix.Data.NameKind
@ -45,6 +46,7 @@ type NameSpaceEntryType :: NameSpace -> GHC.Type
type family NameSpaceEntryType s = res | res -> s where
NameSpaceEntryType 'NameSpaceSymbols = SymbolEntry
NameSpaceEntryType 'NameSpaceModules = ModuleSymbolEntry
NameSpaceEntryType 'NameSpaceFixities = FixitySymbolEntry
type RecordUpdateExtraType :: Stage -> GHC.Type
type family RecordUpdateExtraType s = res | res -> s where
@ -142,6 +144,8 @@ type ParsedPragmas = WithLoc (WithSource Pragmas)
type ParsedIteratorAttribs = WithLoc (WithSource IteratorAttribs)
type ParsedFixityInfo = WithLoc (WithSource FixityInfo)
-- | We group consecutive definitions and reserve symbols in advance, so that we
-- don't need extra syntax for mutually recursive definitions. Also, it allows
-- us to be more flexible with the ordering of the definitions.
@ -161,7 +165,7 @@ data NonDefinitionsSection (s :: Stage) = NonDefinitionsSection
}
data Definition (s :: Stage)
= DefinitionSyntax SyntaxDef
= DefinitionSyntax (SyntaxDef s)
| DefinitionFunctionDef (FunctionDef s)
| DefinitionInductive (InductiveDef s)
| DefinitionAxiom (AxiomDef s)
@ -175,7 +179,7 @@ data NonDefinition (s :: Stage)
| NonDefinitionOpenModule (OpenModule s)
data Statement (s :: Stage)
= StatementSyntax SyntaxDef
= StatementSyntax (SyntaxDef s)
| StatementTypeSignature (TypeSignature s)
| StatementFunctionDef (FunctionDef s)
| StatementImport (Import s)
@ -234,19 +238,62 @@ deriving stock instance Ord (Import 'Parsed)
deriving stock instance Ord (Import 'Scoped)
data SyntaxDef
= SyntaxOperator OperatorSyntaxDef
data SyntaxDef (s :: Stage)
= SyntaxFixity (FixitySyntaxDef s)
| SyntaxOperator OperatorSyntaxDef
| SyntaxIterator IteratorSyntaxDef
deriving stock (Show, Eq, Ord)
instance HasLoc SyntaxDef where
deriving stock instance (Show (SyntaxDef 'Parsed))
deriving stock instance (Show (SyntaxDef 'Scoped))
deriving stock instance (Eq (SyntaxDef 'Parsed))
deriving stock instance (Eq (SyntaxDef 'Scoped))
deriving stock instance (Ord (SyntaxDef 'Parsed))
deriving stock instance (Ord (SyntaxDef 'Scoped))
instance HasLoc (SyntaxDef s) where
getLoc = \case
SyntaxFixity t -> getLoc t
SyntaxOperator t -> getLoc t
SyntaxIterator t -> getLoc t
data FixitySyntaxDef (s :: Stage) = FixitySyntaxDef
{ _fixitySymbol :: SymbolType s,
_fixityDoc :: Maybe (Judoc s),
_fixityInfo :: ParsedFixityInfo,
_fixityKw :: KeywordRef,
_fixitySyntaxKw :: KeywordRef
}
deriving stock instance (Show (FixitySyntaxDef 'Parsed))
deriving stock instance (Show (FixitySyntaxDef 'Scoped))
deriving stock instance (Eq (FixitySyntaxDef 'Parsed))
deriving stock instance (Eq (FixitySyntaxDef 'Scoped))
deriving stock instance (Ord (FixitySyntaxDef 'Parsed))
deriving stock instance (Ord (FixitySyntaxDef 'Scoped))
data FixityDef = FixityDef
{ _fixityDefSymbol :: S.Symbol,
_fixityDefFixity :: Fixity,
_fixityDefPrec :: Int
}
deriving stock (Show, Eq, Ord)
instance HasLoc (FixitySyntaxDef s) where
getLoc FixitySyntaxDef {..} = getLoc _fixitySyntaxKw <> getLoc _fixityInfo
data OperatorSyntaxDef = OperatorSyntaxDef
{ _opSymbol :: Symbol,
_opFixity :: Fixity,
_opFixity :: Symbol,
_opKw :: KeywordRef,
_opSyntaxKw :: KeywordRef
}
@ -965,13 +1012,19 @@ newtype ModuleSymbolEntry = ModuleSymbolEntry
}
deriving stock (Show)
newtype FixitySymbolEntry = FixitySymbolEntry
{ _fixityEntry :: S.Name' ()
}
deriving stock (Show)
instance SingI t => CanonicalProjection (ModuleRef'' c t) (ModuleRef' c) where
project r = ModuleRef' (sing :&: r)
-- | Symbols that a module exports
data ExportInfo = ExportInfo
{ _exportSymbols :: HashMap Symbol SymbolEntry,
_exportModuleSymbols :: HashMap Symbol ModuleSymbolEntry
_exportModuleSymbols :: HashMap Symbol ModuleSymbolEntry,
_exportFixitySymbols :: HashMap Symbol FixitySymbolEntry
}
deriving stock (Show)
@ -1586,6 +1639,8 @@ makeLenses ''ProjectionDef
makeLenses ''ScopedIden'
makeLenses ''SymbolEntry
makeLenses ''ModuleSymbolEntry
makeLenses ''FixitySymbolEntry
makeLenses ''FixityDef
makeLenses ''RecordField
makeLenses ''RhsRecord
makeLenses ''RhsAdt
@ -1610,6 +1665,7 @@ makeLenses ''Application
makeLenses ''Let
makeLenses ''FunctionParameters
makeLenses ''Import
makeLenses ''FixitySyntaxDef
makeLenses ''OperatorSyntaxDef
makeLenses ''IteratorSyntaxDef
makeLenses ''ConstructorDef
@ -2251,11 +2307,13 @@ exportAllNames :: SimpleFold ExportInfo (S.Name' ())
exportAllNames =
exportSymbols . each . symbolEntry
<> exportModuleSymbols . each . moduleEntry
<> exportFixitySymbols . each . fixityEntry
exportNameSpace :: forall ns. SingI ns => Lens' ExportInfo (HashMap Symbol (NameSpaceEntryType ns))
exportNameSpace = case sing :: SNameSpace ns of
SNameSpaceSymbols -> exportSymbols
SNameSpaceModules -> exportModuleSymbols
SNameSpaceFixities -> exportFixitySymbols
_ConstructorRhsRecord :: Traversal' (ConstructorRhs s) (RhsRecord s)
_ConstructorRhsRecord f rhs = case rhs of

24
src/Juvix/Compiler/Concrete/Print/Base.hs
View File

@ -425,8 +425,9 @@ instance SingI s => PrettyPrint (Import s) where
Nothing -> Nothing
Just as -> Just (ppCode Kw.kwAs <+> ppModulePathType as)
instance PrettyPrint SyntaxDef where
instance SingI s => PrettyPrint (SyntaxDef s) where
ppCode = \case
SyntaxFixity f -> ppCode f
SyntaxOperator op -> ppCode op
SyntaxIterator it -> ppCode it
@ -573,19 +574,22 @@ instance SingI s => PrettyPrint (Lambda s) where
instance PrettyPrint Precedence where
ppCode = \case
PrecMinusOmega1 -> noLoc (pretty ("-ω₁" :: Text))
PrecMinusOmega -> noLoc (pretty ("-ω" :: Text))
PrecUpdate -> noLoc (pretty ("-ω₁" :: Text))
PrecArrow -> noLoc (pretty ("-ω" :: Text))
PrecNat n -> noLoc (pretty n)
PrecOmega -> noLoc (pretty ("ω" :: Text))
PrecApp -> noLoc (pretty ("ω" :: Text))
instance SingI s => PrettyPrint (FixitySyntaxDef s) where
ppCode FixitySyntaxDef {..} = do
let sym' = ppSymbolType _fixitySymbol
let txt = pretty (_fixityInfo ^. withLocParam . withSourceText)
ppCode _fixitySyntaxKw <+> ppCode _fixityKw <+> sym' <+> braces (noLoc txt)
instance PrettyPrint OperatorSyntaxDef where
ppCode OperatorSyntaxDef {..} = do
let opSymbol' = ppUnkindedSymbol _opSymbol
fi <+> opSymbol'
where
fi = do
let p = ppCode (_opFixity ^. fixityPrecedence)
ppCode _opSyntaxKw <+> ppCode _opKw <+> p
let p = ppUnkindedSymbol _opFixity
ppCode _opSyntaxKw <+> ppCode _opKw <+> opSymbol' <+> p
instance PrettyPrint PatternApp where
ppCode = apeHelper
@ -642,7 +646,7 @@ instance PrettyPrint (WithSource Pragmas) where
in annotated AnnComment (noLoc txt) <> line
instance PrettyPrint (WithSource IteratorAttribs) where
ppCode = annotated AnnComment . braces . noLoc . pretty . (^. withSourceText)
ppCode = braces . noLoc . pretty . (^. withSourceText)
ppJudocStart :: Members '[ExactPrint, Reader Options] r => Sem r (Maybe ())
ppJudocStart = do

305
src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs
View File

@ -9,6 +9,7 @@ import Control.Monad.Combinators.Expr qualified as P
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Data.List.NonEmpty qualified as NonEmpty
import GHC.Base (maxInt, minInt)
import Juvix.Compiler.Concrete.Data.Highlight.Input
import Juvix.Compiler.Concrete.Data.InfoTableBuilder
import Juvix.Compiler.Concrete.Data.Name qualified as N
@ -25,6 +26,7 @@ import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error
import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context (ParserResult)
import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context qualified as Parsed
import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Data.FixityInfo qualified as FI
import Juvix.Data.IteratorAttribs
import Juvix.Data.NameKind
import Juvix.Prelude
@ -127,12 +129,12 @@ scopeCheckOpenModule ::
Sem r (OpenModule 'Scoped)
scopeCheckOpenModule = mapError (JuvixError @ScoperError) . checkOpenModule
freshVariable :: Members '[NameIdGen, State ScoperFixities, State ScoperIterators, State Scope, State ScoperState] r => Symbol -> Sem r S.Symbol
freshVariable :: Members '[NameIdGen, State ScoperSyntax, State Scope, State ScoperState] r => Symbol -> Sem r S.Symbol
freshVariable = freshSymbol KNameLocal
checkProjectionDef ::
forall r.
Members '[Error ScoperError, InfoTableBuilder, Reader BindingStrategy, State Scope, State ScoperState, NameIdGen, State ScoperFixities, State ScoperIterators] r =>
Members '[Error ScoperError, InfoTableBuilder, Reader BindingStrategy, State Scope, State ScoperState, NameIdGen, State ScoperSyntax] r =>
ProjectionDef 'Parsed ->
Sem r (ProjectionDef 'Scoped)
checkProjectionDef p = do
@ -146,7 +148,7 @@ checkProjectionDef p = do
freshSymbol ::
forall r.
Members '[State Scope, State ScoperState, NameIdGen, State ScoperFixities, State ScoperIterators] r =>
Members '[State Scope, State ScoperState, NameIdGen, State ScoperSyntax] r =>
NameKind ->
Symbol ->
Sem r S.Symbol
@ -161,25 +163,31 @@ freshSymbol _nameKind _nameConcrete = do
_nameIterator <- iter
return S.Name' {..}
where
fixity :: Sem r (Maybe Fixity)
fixity ::
Sem r (Maybe Fixity)
fixity
| S.canHaveFixity _nameKind = do
mf <- gets (^? scoperFixities . at _nameConcrete . _Just . symbolFixityDef . opFixity)
when (isJust mf) (modify (set (scoperFixities . at _nameConcrete . _Just . symbolFixityUsed) True))
mf <- gets (^? scoperSyntaxOperators . scoperOperators . at _nameConcrete . _Just . symbolOperatorFixity)
when (isJust mf) (modify (set (scoperSyntaxOperators . scoperOperators . at _nameConcrete . _Just . symbolOperatorUsed) True))
return mf
| otherwise = return Nothing
iter :: Sem r (Maybe IteratorAttribs)
iter = runFail $ do
failUnless (S.canBeIterator _nameKind)
ma <- gets (^? scoperIterators . at _nameConcrete . _Just . symbolIteratorDef . iterAttribs) >>= failMaybe
let attrs = maybe emptyIteratorAttribs (^. withLocParam . withSourceValue) ma
modify (set (scoperIterators . at _nameConcrete . _Just . symbolIteratorUsed) True)
return attrs
iter
| S.canBeIterator _nameKind = do
mma <- gets (^? scoperSyntaxIterators . scoperIterators . at _nameConcrete . _Just . symbolIteratorDef . iterAttribs)
case mma of
Just ma -> do
let attrs = maybe emptyIteratorAttribs (^. withLocParam . withSourceValue) ma
modify (set (scoperSyntaxIterators . scoperIterators . at _nameConcrete . _Just . symbolIteratorUsed) True)
return $ Just attrs
Nothing ->
return Nothing
| otherwise = return Nothing
reserveSymbolSignatureOf ::
forall (k :: NameKind) r d.
( Members '[Error ScoperError, NameIdGen, State ScoperFixities, State ScoperIterators, State ScoperIterators, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r,
( Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r,
HasNameSignature d,
SingI (NameKindNameSpace k)
) =>
@ -193,7 +201,7 @@ reserveSymbolSignatureOf k d s = do
reserveSymbolOf ::
forall (nameKind :: NameKind) (ns :: NameSpace) r.
( Members '[Error ScoperError, NameIdGen, State ScoperFixities, State ScoperIterators, State ScoperIterators, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r,
( Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r,
ns ~ NameKindNameSpace nameKind,
SingI ns
) =>
@ -213,6 +221,7 @@ reserveSymbolOf k nameSig s = do
entry =
let symE = SymbolEntry (S.unConcrete s')
modE = ModuleSymbolEntry (S.unConcrete s')
fixE = FixitySymbolEntry (S.unConcrete s')
in case k of
SKNameConstructor -> symE
SKNameInductive -> symE
@ -221,6 +230,7 @@ reserveSymbolOf k nameSig s = do
SKNameLocal -> symE
SKNameLocalModule -> modE
SKNameTopModule -> modE
SKNameFixity -> fixE
addS :: NameSpaceEntryType ns -> Maybe (SymbolInfo ns) -> SymbolInfo ns
addS mentry m = case m of
Nothing -> symbolInfoSingle mentry
@ -244,7 +254,8 @@ reserveSymbolOf k nameSig s = do
)
getReservedDefinitionSymbol ::
Members '[Error ScoperError, NameIdGen, State ScoperFixities, State ScoperIterators, State ScoperIterators, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
forall r.
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
Symbol ->
Sem r S.Symbol
getReservedDefinitionSymbol s = do
@ -253,75 +264,82 @@ getReservedDefinitionSymbol s = do
err = error ("impossible. Contents of scope:\n" <> ppTrace (toList m))
return s'
ignoreFixities :: Sem (State ScoperFixities ': r) a -> Sem r a
ignoreFixities = evalState mempty
ignoreIterators :: Sem (State ScoperIterators ': r) a -> Sem r a
ignoreIterators = evalState mempty
ignoreSyntax :: Sem (State ScoperSyntax ': r) a -> Sem r a
ignoreSyntax = evalState emptyScoperSyntax
-- | Variables are assumed to never be infix operators
bindVariableSymbol ::
Members '[Error ScoperError, NameIdGen, State Scope, InfoTableBuilder, State ScoperState] r =>
Symbol ->
Sem r S.Symbol
bindVariableSymbol = localBindings . ignoreFixities . ignoreIterators . reserveSymbolOf SKNameLocal Nothing
bindVariableSymbol = localBindings . ignoreSyntax . reserveSymbolOf SKNameLocal Nothing
reserveInductiveSymbol ::
Members '[Error ScoperError, NameIdGen, State ScoperFixities, State ScoperIterators, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r =>
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r =>
InductiveDef 'Parsed ->
Sem r S.Symbol
reserveInductiveSymbol d = reserveSymbolSignatureOf SKNameInductive d (d ^. inductiveName)
reserveProjectionSymbol ::
Members '[Error ScoperError, NameIdGen, State ScoperFixities, State ScoperIterators, State Scope, Reader BindingStrategy, InfoTableBuilder, State ScoperState] r =>
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, Reader BindingStrategy, InfoTableBuilder, State ScoperState] r =>
ProjectionDef 'Parsed ->
Sem r S.Symbol
reserveProjectionSymbol d = reserveSymbolOf SKNameFunction Nothing (d ^. projectionField)
reserveConstructorSymbol ::
Members '[Error ScoperError, NameIdGen, State ScoperFixities, State ScoperIterators, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r =>
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r =>
InductiveDef 'Parsed ->
ConstructorDef 'Parsed ->
Sem r S.Symbol
reserveConstructorSymbol d c = reserveSymbolSignatureOf SKNameConstructor (d, c) (c ^. constructorName)
reserveFunctionSymbol ::
Members '[Error ScoperError, NameIdGen, State ScoperFixities, State ScoperIterators, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r =>
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r =>
FunctionDef 'Parsed ->
Sem r S.Symbol
reserveFunctionSymbol f =
reserveSymbolSignatureOf SKNameFunction f (f ^. signName)
reserveAxiomSymbol ::
Members '[Error ScoperError, NameIdGen, State ScoperFixities, State ScoperIterators, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r =>
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, State ScoperState, Reader BindingStrategy, InfoTableBuilder] r =>
AxiomDef 'Parsed ->
Sem r S.Symbol
reserveAxiomSymbol a = reserveSymbolSignatureOf SKNameAxiom a (a ^. axiomName)
bindFunctionSymbol ::
Members '[Error ScoperError, NameIdGen, State ScoperFixities, State ScoperIterators, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
Symbol ->
Sem r S.Symbol
bindFunctionSymbol = getReservedDefinitionSymbol
bindInductiveSymbol ::
Members '[Error ScoperError, NameIdGen, State ScoperFixities, State ScoperIterators, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
Symbol ->
Sem r S.Symbol
bindInductiveSymbol = getReservedDefinitionSymbol
bindAxiomSymbol ::
Members '[Error ScoperError, NameIdGen, State ScoperFixities, State ScoperIterators, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
Symbol ->
Sem r S.Symbol
bindAxiomSymbol = getReservedDefinitionSymbol
bindConstructorSymbol ::
Members '[Error ScoperError, NameIdGen, State ScoperFixities, State ScoperIterators, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
Symbol ->
Sem r S.Symbol
bindConstructorSymbol = getReservedDefinitionSymbol
bindFixitySymbol ::
Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, State ScoperState, Reader BindingStrategy] r =>
Symbol ->
Sem r S.Symbol
bindFixitySymbol s = do
m <- gets (^. scopeLocalFixitySymbols)
let s' = fromMaybe err (m ^. at s)
err = error ("impossible. Contents of scope:\n" <> ppTrace (toList m))
return s'
checkImport ::
forall r.
(Members '[Error ScoperError, State Scope, Reader ScopeParameters, State ScoperState, InfoTableBuilder, NameIdGen] r) =>
@ -389,7 +407,7 @@ getModuleExportInfo m = fromMaybeM err (gets (^? scoperModules . at (m ^. module
-- | Do not call directly. Looks for a symbol in (possibly) nested local modules
lookupSymbolAux ::
forall r.
Members '[State ScoperState, State Scope, Output ModuleSymbolEntry, Output SymbolEntry] r =>
Members '[State ScoperState, State Scope, Output ModuleSymbolEntry, Output SymbolEntry, Output FixitySymbolEntry] r =>
[Symbol] ->
Symbol ->
Sem r ()
@ -409,6 +427,7 @@ lookupSymbolAux modules final = do
gets (^.. scopeNameSpace @ns . at final . _Just . symbolInfo . each) >>= mapM_ output
helper (Proxy @'NameSpaceSymbols)
helper (Proxy @'NameSpaceModules)
helper (Proxy @'NameSpaceFixities)
p : ps ->
gets (^.. scopeModuleSymbols . at p . _Just . symbolInfo . each)
>>= mapM_ (getModuleExportInfo >=> lookInExport final ps)
@ -426,7 +445,7 @@ mkModuleEntry (ModuleRef' (t :&: m)) = ModuleSymbolEntry $ case t of
lookInExport ::
forall r.
Members '[State ScoperState, Output SymbolEntry, Output ModuleSymbolEntry] r =>
Members '[State ScoperState, Output SymbolEntry, Output ModuleSymbolEntry, Output FixitySymbolEntry] r =>
Symbol ->
[Symbol] ->
ExportInfo ->
@ -435,6 +454,7 @@ lookInExport sym remaining e = case remaining of
[] -> do
whenJust (e ^. exportSymbols . at sym) output
whenJust (e ^. exportModuleSymbols . at sym) output
whenJust (e ^. exportFixitySymbols . at sym) output
s : ss -> whenJustM (mayModule e s) (lookInExport sym ss)
where
mayModule :: ExportInfo -> Symbol -> Sem r (Maybe ExportInfo)
@ -447,12 +467,14 @@ lookupQualifiedSymbol ::
forall r.
Members '[State Scope, State ScoperState] r =>
([Symbol], Symbol) ->
Sem r ([SymbolEntry], [ModuleSymbolEntry])
lookupQualifiedSymbol = runOutputList . execOutputList . go
Sem r ([SymbolEntry], [ModuleSymbolEntry], [FixitySymbolEntry])
lookupQualifiedSymbol sms = do
(es, (ms, fs)) <- runOutputList $ runOutputList $ execOutputList $ go sms
return (es, ms, fs)
where
go ::
forall r'.
Members [State ScoperState, State Scope, Output SymbolEntry, Output ModuleSymbolEntry] r' =>
Members [State ScoperState, State Scope, Output SymbolEntry, Output ModuleSymbolEntry, Output FixitySymbolEntry] r' =>
([Symbol], Symbol) ->
Sem r' ()
go (path, sym) = do
@ -490,7 +512,7 @@ checkQualifiedExpr ::
QualifiedName ->
Sem r ScopedIden
checkQualifiedExpr q@(QualifiedName (SymbolPath p) sym) = do
es <- fst <$> lookupQualifiedSymbol (toList p, sym)
es <- fst3 <$> lookupQualifiedSymbol (toList p, sym)
case es of
[] -> notInScope
[e] -> entryToScopedIden q' e
@ -515,6 +537,7 @@ exportScope ::
exportScope Scope {..} = do
_exportSymbols <- HashMap.fromList <$> mapMaybeM mkentry (HashMap.toList _scopeSymbols)
_exportModuleSymbols <- HashMap.fromList <$> mapMaybeM mkentry (HashMap.toList _scopeModuleSymbols)
_exportFixitySymbols <- HashMap.fromList <$> mapMaybeM mkentry (HashMap.toList _scopeFixitySymbols)
return ExportInfo {..}
where
mkentry ::
@ -539,8 +562,9 @@ exportScope Scope {..} = do
_scopePath
s
( case sing :: SNameSpace ns of
SNameSpaceSymbols -> Left es
SNameSpaceModules -> Right es
SNameSpaceSymbols -> ExportEntriesSymbols es
SNameSpaceModules -> ExportEntriesModules es
SNameSpaceFixities -> ExportEntriesFixities es
)
)
)
@ -559,44 +583,121 @@ readScopeModule import_ = do
addImport :: ScopeParameters -> ScopeParameters
addImport = over scopeTopParents (cons import_)
checkOperatorSyntaxDef ::
checkFixitySyntaxDef ::
forall r.
Members '[Error ScoperError, State Scope, State ScoperState, State ScoperFixities, State ScoperIterators] r =>
Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, State ScoperSyntax, NameIdGen, InfoTableBuilder] r =>
FixitySyntaxDef 'Parsed ->
Sem r (FixitySyntaxDef 'Scoped)
checkFixitySyntaxDef FixitySyntaxDef {..} = topBindings $ do
sym <- bindFixitySymbol _fixitySymbol
doc <- mapM checkJudoc _fixityDoc
registerHighlightDoc (sym ^. S.nameId) doc
return
FixitySyntaxDef
{ _fixitySymbol = sym,
_fixityDoc = doc,
..
}
resolveFixitySyntaxDef ::
forall r.
Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, State ScoperSyntax, NameIdGen, InfoTableBuilder] r =>
FixitySyntaxDef 'Parsed ->
Sem r ()
resolveFixitySyntaxDef fdef@FixitySyntaxDef {..} = topBindings $ do
sym <- reserveSymbolOf SKNameFixity Nothing _fixitySymbol
let loc = getLoc _fixityInfo
fi = _fixityInfo ^. withLocParam . withSourceValue
same <- checkMaybeFixity loc $ fi ^. FI.fixityPrecSame
below <- mapM (checkFixitySymbol . WithLoc loc) $ fi ^. FI.fixityPrecBelow
above <- mapM (checkFixitySymbol . WithLoc loc) $ fi ^. FI.fixityPrecAbove
tab <- getInfoTable
let samePrec = getPrec tab <$> same
belowPrec :: Integer
belowPrec = fromIntegral $ maximum (minInt + 1 : map (getPrec tab) above)
abovePrec :: Integer
abovePrec = fromIntegral $ minimum (maxInt - 1 : map (getPrec tab) below)
when (belowPrec >= abovePrec + 1) $
throw (ErrPrecedenceInconsistency (PrecedenceInconsistencyError fdef))
when (isJust same && not (null below && null above)) $
throw (ErrPrecedenceInconsistency (PrecedenceInconsistencyError fdef))
-- we need Integer to avoid overflow when computing prec
let prec = fromMaybe (fromInteger $ (abovePrec + belowPrec) `div` 2) samePrec
fx =
Fixity
{ _fixityPrecedence = PrecNat prec,
_fixityArity =
case fi ^. FI.fixityArity of
FI.Unary -> Unary AssocPostfix
FI.Binary -> case fi ^. FI.fixityAssoc of
Nothing -> Binary AssocNone
Just FI.AssocLeft -> Binary AssocLeft
Just FI.AssocRight -> Binary AssocRight
Just FI.AssocNone -> Binary AssocNone
}
registerFixity
@$> FixityDef
{ _fixityDefSymbol = sym,
_fixityDefFixity = fx,
_fixityDefPrec = prec
}
return ()
where
checkMaybeFixity ::
forall r'.
Members '[Error ScoperError, State Scope, State ScoperState] r' =>
Interval ->
Maybe Text ->
Sem r' (Maybe S.Symbol)
checkMaybeFixity loc = \case
Just same -> Just <$> checkFixitySymbol (WithLoc loc same)
Nothing -> return Nothing
getPrec :: InfoTable -> S.Symbol -> Int
getPrec tab = (^. fixityDefPrec) . fromJust . flip HashMap.lookup (tab ^. infoFixities) . (^. S.nameId)
resolveOperatorSyntaxDef ::
forall r.
Members '[Error ScoperError, State Scope, State ScoperState, State ScoperSyntax, InfoTableBuilder] r =>
OperatorSyntaxDef ->
Sem r ()
checkOperatorSyntaxDef s@OperatorSyntaxDef {..} = do
resolveOperatorSyntaxDef s@OperatorSyntaxDef {..} = do
checkNotDefined
let sf =
SymbolFixity
{ _symbolFixityUsed = False,
_symbolFixityDef = s
sym <- checkFixitySymbol _opFixity
tab <- getInfoTable
let fx = fromJust (HashMap.lookup (sym ^. S.nameId) (tab ^. infoFixities)) ^. fixityDefFixity
sf =
SymbolOperator
{ _symbolOperatorUsed = False,
_symbolOperatorDef = s,
_symbolOperatorFixity = fx
}
modify (over scoperFixities (HashMap.insert _opSymbol sf))
modify (over scoperSyntaxOperators (over scoperOperators (HashMap.insert _opSymbol sf)))
where
checkNotDefined :: Sem r ()
checkNotDefined =
whenJustM
(HashMap.lookup _opSymbol <$> gets (^. scoperFixities))
$ \s' -> throw (ErrDuplicateFixity (DuplicateFixity (s' ^. symbolFixityDef) s))
(HashMap.lookup _opSymbol <$> gets (^. scoperSyntaxOperators . scoperOperators))
$ \s' -> throw (ErrDuplicateOperator (DuplicateOperator (s' ^. symbolOperatorDef) s))
checkIteratorSyntaxDef ::
resolveIteratorSyntaxDef ::
forall r.
Members '[Error ScoperError, State Scope, State ScoperState, State ScoperFixities, State ScoperIterators] r =>
Members '[Error ScoperError, State Scope, State ScoperState, State ScoperSyntax] r =>
IteratorSyntaxDef ->
Sem r ()
checkIteratorSyntaxDef s@IteratorSyntaxDef {..} = do
resolveIteratorSyntaxDef s@IteratorSyntaxDef {..} = do
checkNotDefined
let sf =
SymbolIterator
{ _symbolIteratorUsed = False,
_symbolIteratorDef = s
}
modify (set (scoperIterators . at _iterSymbol) (Just sf))
modify (set (scoperSyntaxIterators . scoperIterators . at _iterSymbol) (Just sf))
where
checkNotDefined :: Sem r ()
checkNotDefined =
whenJustM
(HashMap.lookup _iterSymbol <$> gets (^. scoperIterators))
(HashMap.lookup _iterSymbol <$> gets (^. scoperSyntaxIterators . scoperIterators))
$ \s' -> throw (ErrDuplicateIterator (DuplicateIterator (s' ^. symbolIteratorDef) s))
-- | Only used as syntactical convenience for registerX functions
@ -605,7 +706,7 @@ checkIteratorSyntaxDef s@IteratorSyntaxDef {..} = do
checkFunctionDef ::
forall r.
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperFixities, State ScoperIterators, Reader BindingStrategy] r =>
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperSyntax, Reader BindingStrategy] r =>
FunctionDef 'Parsed ->
Sem r (FunctionDef 'Scoped)
checkFunctionDef FunctionDef {..} = do
@ -655,7 +756,7 @@ checkFunctionDef FunctionDef {..} = do
}
checkTypeSignature ::
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperFixities, State ScoperIterators, Reader BindingStrategy] r =>
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperSyntax, Reader BindingStrategy] r =>
TypeSignature 'Parsed ->
Sem r (TypeSignature 'Scoped)
checkTypeSignature TypeSignature {..} = do
@ -684,7 +785,7 @@ checkInductiveParameters params = do
checkInductiveDef ::
forall r.
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperFixities, State ScoperIterators, State ScoperIterators, Reader BindingStrategy] r =>
Members '[Reader ScopeParameters, Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperSyntax, Reader BindingStrategy] r =>
InductiveDef 'Parsed ->
Sem r (InductiveDef 'Scoped)
checkInductiveDef InductiveDef {..} = do
@ -885,17 +986,11 @@ withLocalScope ma = do
put before
return x
fixitiesBlock :: Members '[Error ScoperError] r => Sem (State ScoperFixities ': r) a -> Sem r a
fixitiesBlock m =
evalState (mempty :: ScoperFixities) $ do
a <- m
checkOrphanFixities
return a
iteratorsBlock :: Members '[Error ScoperError] r => Sem (State ScoperIterators ': r) a -> Sem r a
iteratorsBlock m =
evalState (mempty :: ScoperIterators) $ do
syntaxBlock :: Members '[Error ScoperError] r => Sem (State ScoperSyntax ': r) a -> Sem r a
syntaxBlock m =
evalState emptyScoperSyntax $ do
a <- m
checkOrphanOperators
checkOrphanIterators
return a
@ -907,8 +1002,7 @@ checkModuleBody ::
checkModuleBody body = do
body' <-
fmap flattenSections
. fixitiesBlock
. iteratorsBlock
. syntaxBlock
$ checkSections (mkSections body)
exported <- get >>= exportScope
return (exported, body')
@ -947,7 +1041,7 @@ checkModuleBody body = do
checkSections ::
forall r.
Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperFixities, State ScoperIterators, State ScoperIterators] r =>
Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperSyntax] r =>
StatementSections 'Parsed ->
Sem r (StatementSections 'Scoped)
checkSections sec = do
@ -1008,7 +1102,7 @@ checkSections sec = do
where
reserveDefinition :: Definition 'Parsed -> Sem r' ()
reserveDefinition = \case
DefinitionSyntax s -> void (checkSyntaxDef s)
DefinitionSyntax s -> resolveSyntaxDef s
DefinitionFunctionDef d -> void (reserveFunctionSymbol d)
DefinitionTypeSignature d -> void (reserveSymbolOf SKNameFunction Nothing (d ^. sigName))
DefinitionAxiom d -> void (reserveAxiomSymbol d)
@ -1051,7 +1145,7 @@ checkSections sec = do
goDefinition :: Definition 'Parsed -> Sem r' (Definition 'Scoped)
goDefinition = \case
DefinitionSyntax s -> return (DefinitionSyntax s)
DefinitionSyntax s -> DefinitionSyntax <$> checkSyntaxDef s
DefinitionFunctionDef d -> DefinitionFunctionDef <$> checkFunctionDef d
DefinitionTypeSignature d -> DefinitionTypeSignature <$> checkTypeSignature d
DefinitionAxiom d -> DefinitionAxiom <$> checkAxiomDef d
@ -1163,7 +1257,7 @@ reserveLocalModuleSymbol ::
Symbol ->
Sem r S.Symbol
reserveLocalModuleSymbol =
ignoreFixities . ignoreIterators . reserveSymbolOf SKNameLocalModule Nothing
ignoreSyntax . reserveSymbolOf SKNameLocalModule Nothing
checkLocalModule ::
forall r.
@ -1211,17 +1305,17 @@ checkLocalModule Module {..} = do
over (nsEntry . S.nameWhyInScope) S.BecauseInherited
. set (nsEntry . S.nameVisibilityAnn) VisPrivate
checkOrphanFixities :: forall r. Members '[Error ScoperError, State ScoperFixities] r => Sem r ()
checkOrphanFixities = do
declared <- gets (^. scoperFixities)
let unused = fmap (^. symbolFixityDef) . find (^. symbolFixityUsed . to not) . toList $ declared
checkOrphanOperators :: forall r. Members '[Error ScoperError, State ScoperSyntax] r => Sem r ()
checkOrphanOperators = do
declared <- gets (^. scoperSyntaxOperators . scoperOperators)
let unused = fmap (^. symbolOperatorDef) . find (^. symbolOperatorUsed . to not) . toList $ declared
case unused of
Nothing -> return ()
Just x -> throw (ErrUnusedOperatorDef (UnusedOperatorDef x))
checkOrphanIterators :: forall r. Members '[Error ScoperError, State ScoperIterators] r => Sem r ()
checkOrphanIterators :: forall r. Members '[Error ScoperError, State ScoperSyntax] r => Sem r ()
checkOrphanIterators = do
declared <- gets (^. scoperIterators)
declared <- gets (^. scoperSyntaxIterators . scoperIterators)
let unused = fmap (^. symbolIteratorDef) . find (^. symbolIteratorUsed . to not) . toList $ declared
case unused of
Nothing -> return ()
@ -1244,7 +1338,7 @@ lookupModuleSymbol ::
Name ->
Sem r ModuleRef
lookupModuleSymbol n = do
es <- snd <$> lookupQualifiedSymbol (path, sym)
es <- snd3 <$> lookupQualifiedSymbol (path, sym)
case nonEmpty (resolveShadowing es) of
Nothing -> notInScope
Just (x :| []) -> getModuleRef x n
@ -1390,6 +1484,7 @@ checkOpenModuleNoImport importModuleHint OpenModule {..}
mergeScope ei = do
mapM_ mergeSymbol (HashMap.toList (ei ^. exportSymbols))
mapM_ mergeSymbol (HashMap.toList (ei ^. exportModuleSymbols))
mapM_ mergeSymbol (HashMap.toList (ei ^. exportFixitySymbols))
where
mergeSymbol :: forall ns. SingI ns => (Symbol, NameSpaceEntryType ns) -> Sem r ()
mergeSymbol (s, entry) =
@ -1403,7 +1498,8 @@ checkOpenModuleNoImport importModuleHint OpenModule {..}
alterEntries nfo =
ExportInfo
{ _exportSymbols = alterEntry <$> nfo ^. exportSymbols,
_exportModuleSymbols = alterEntry <$> nfo ^. exportModuleSymbols
_exportModuleSymbols = alterEntry <$> nfo ^. exportModuleSymbols,
_exportFixitySymbols = alterEntry <$> nfo ^. exportFixitySymbols
}
alterEntry :: SingI ns => NameSpaceEntryType ns -> NameSpaceEntryType ns
@ -1424,6 +1520,7 @@ checkOpenModuleNoImport importModuleHint OpenModule {..}
Just (Using l) ->
over exportSymbols (HashMap.fromList . mapMaybe inUsing . HashMap.toList)
. over exportModuleSymbols (HashMap.fromList . mapMaybe inUsing . HashMap.toList)
. over exportFixitySymbols (HashMap.fromList . mapMaybe inUsing . HashMap.toList)
where
inUsing ::
forall (ns :: NameSpace).
@ -1442,6 +1539,7 @@ checkOpenModuleNoImport importModuleHint OpenModule {..}
Just (Hiding l) ->
over exportSymbols (HashMap.filter (not . inHiding))
. over exportModuleSymbols (HashMap.filter (not . inHiding))
. over exportFixitySymbols (HashMap.filter (not . inHiding))
where
inHiding :: forall ns. SingI ns => NameSpaceEntryType ns -> Bool
inHiding e = HashSet.member (e ^. nsEntry . S.nameId) u
@ -1490,7 +1588,7 @@ checkFunctionClause clause@FunctionClause {..} = do
err = throw (ErrLacksTypeSig (LacksTypeSig clause))
checkAxiomDef ::
Members '[Reader ScopeParameters, InfoTableBuilder, Error ScoperError, State Scope, State ScoperState, NameIdGen, State ScoperFixities, State ScoperIterators, Reader BindingStrategy] r =>
Members '[Reader ScopeParameters, InfoTableBuilder, Error ScoperError, State Scope, State ScoperState, NameIdGen, State ScoperSyntax, Reader BindingStrategy] r =>
AxiomDef 'Parsed ->
Sem r (AxiomDef 'Scoped)
checkAxiomDef AxiomDef {..} = do
@ -1528,8 +1626,7 @@ checkLetClauses ::
Sem r (NonEmpty (LetClause 'Scoped))
checkLetClauses =
localBindings
. ignoreFixities
. ignoreIterators
. ignoreSyntax
. fmap fromSections
. checkSections
. mkLetSections
@ -1755,15 +1852,29 @@ checkUnqualified ::
checkUnqualified s = do
scope <- get
-- Lookup at the global scope
let err = throw (ErrSymNotInScope (NotInScope s scope))
entries <- fst <$> lookupQualifiedSymbol ([], s)
entries <- fst3 <$> lookupQualifiedSymbol ([], s)
case resolveShadowing entries of
[] -> err
[] -> throw (ErrSymNotInScope (NotInScope s scope))
[x] -> entryToScopedIden n x
es -> throw (ErrAmbiguousSym (AmbiguousSym n es))
where
n = NameUnqualified s
checkFixitySymbol ::
(Members '[Error ScoperError, State Scope, State ScoperState] r) =>
Symbol ->
Sem r S.Symbol
checkFixitySymbol s = do
scope <- get
-- Lookup at the global scope
entries <- thd3 <$> lookupQualifiedSymbol ([], s)
case resolveShadowing entries of
[] -> throw (ErrSymNotInScope (NotInScope s scope))
[x] -> return $ entryToSymbol x s
es -> throw (ErrAmbiguousSym (AmbiguousSym n (map (SymbolEntry . (^. fixityEntry)) es)))
where
n = NameUnqualified s
-- | Remove the symbol entries associated with a single symbol according to the
-- shadowing rules for modules. For example, a symbol defined in the outer
-- module with the same name as a symbol defined in the inner module will be
@ -1830,7 +1941,7 @@ lookupNameOfKind ::
Name ->
Sem r (Maybe S.Name)
lookupNameOfKind nameKind n = do
entries <- mapMaybe filterEntry . fst <$> lookupQualifiedSymbol (path, sym)
entries <- mapMaybe filterEntry . fst3 <$> lookupQualifiedSymbol (path, sym)
case entries of
[] -> return Nothing
[e] -> return (Just (set S.nameConcrete n e)) -- There is one constructor with such a name
@ -2154,12 +2265,22 @@ checkParsePatternAtom ::
checkParsePatternAtom = checkPatternAtom >=> parsePatternAtom
checkSyntaxDef ::
(Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperFixities, State ScoperIterators, State ScoperIterators] r) =>
SyntaxDef ->
Sem r SyntaxDef
(Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperSyntax] r) =>
SyntaxDef 'Parsed ->
Sem r (SyntaxDef 'Scoped)
checkSyntaxDef = \case
SyntaxOperator opDef -> SyntaxOperator opDef <$ checkOperatorSyntaxDef opDef
SyntaxIterator iterDef -> SyntaxIterator iterDef <$ checkIteratorSyntaxDef iterDef
SyntaxFixity fixDef -> SyntaxFixity <$> checkFixitySyntaxDef fixDef
SyntaxOperator opDef -> return $ SyntaxOperator opDef
SyntaxIterator iterDef -> return $ SyntaxIterator iterDef
resolveSyntaxDef ::
(Members '[Error ScoperError, Reader ScopeParameters, State Scope, State ScoperState, InfoTableBuilder, NameIdGen, State ScoperSyntax] r) =>
SyntaxDef 'Parsed ->
Sem r ()
resolveSyntaxDef = \case
SyntaxFixity fixDef -> resolveFixitySyntaxDef fixDef
SyntaxOperator opDef -> resolveOperatorSyntaxDef opDef
SyntaxIterator iterDef -> resolveIteratorSyntaxDef iterDef
-------------------------------------------------------------------------------
-- Infix Expression

6
src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error.hs
View File

@ -22,7 +22,7 @@ data ScoperError
| ErrSymNotInScope NotInScope
| ErrQualSymNotInScope QualSymNotInScope
| ErrModuleNotInScope ModuleNotInScope
| ErrDuplicateFixity DuplicateFixity
| ErrDuplicateOperator DuplicateOperator
| ErrDuplicateIterator DuplicateIterator
| ErrMultipleExport MultipleExportConflict
| ErrAmbiguousSym AmbiguousSym
@ -46,6 +46,7 @@ data ScoperError
| ErrUnexpectedField UnexpectedField
| ErrRepeatedField RepeatedField
| ErrConstructorNotARecord ConstructorNotARecord
| ErrPrecedenceInconsistency PrecedenceInconsistencyError
instance ToGenericError ScoperError where
genericError = \case
@ -59,7 +60,7 @@ instance ToGenericError ScoperError where
ErrSymNotInScope e -> genericError e
ErrQualSymNotInScope e -> genericError e
ErrModuleNotInScope e -> genericError e
ErrDuplicateFixity e -> genericError e
ErrDuplicateOperator e -> genericError e
ErrDuplicateIterator e -> genericError e
ErrMultipleExport e -> genericError e
ErrAmbiguousSym e -> genericError e
@ -83,3 +84,4 @@ instance ToGenericError ScoperError where
ErrUnexpectedField e -> genericError e
ErrRepeatedField e -> genericError e
ErrConstructorNotARecord e -> genericError e
ErrPrecedenceInconsistency e -> genericError e

49
src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping/Error/Types.hs
View File

@ -221,14 +221,14 @@ instance ToGenericError QualSymNotInScope where
i = getLoc _qualSymNotInScope
msg = "Qualified symbol not in scope:" <+> ppCode opts' _qualSymNotInScope
data DuplicateFixity = DuplicateFixity
{ _dupFixityFirst :: OperatorSyntaxDef,
_dupFixitySecond :: OperatorSyntaxDef
data DuplicateOperator = DuplicateOperator
{ _dupOperatorFirst :: OperatorSyntaxDef,
_dupOperatorSecond :: OperatorSyntaxDef
}
deriving stock (Show)
instance ToGenericError DuplicateFixity where
genericError DuplicateFixity {..} = ask >>= generr
instance ToGenericError DuplicateOperator where
genericError DuplicateOperator {..} = ask >>= generr
where
generr opts =
return
@ -239,18 +239,18 @@ instance ToGenericError DuplicateFixity where
}
where
opts' = fromGenericOptions opts
i1 = getLoc _dupFixityFirst
i2 = getLoc _dupFixitySecond
i1 = getLoc _dupOperatorFirst
i2 = getLoc _dupOperatorSecond
msg =
"Multiple fixity declarations for symbol"
"Multiple operator declarations for symbol"
<+> ppCode opts' sym
<> ":"
<> line
<> indent' (align locs)
where
sym = _dupFixityFirst ^. opSymbol
locs = vsep $ map (pretty . getLoc) [_dupFixityFirst, _dupFixityFirst]
sym = _dupOperatorFirst ^. opSymbol
locs = vsep $ map (pretty . getLoc) [_dupOperatorFirst, _dupOperatorSecond]
data DuplicateIterator = DuplicateIterator
{ _dupIteratorFirst :: IteratorSyntaxDef,
@ -283,10 +283,16 @@ instance ToGenericError DuplicateIterator where
sym = _dupIteratorFirst ^. iterSymbol
locs = vsep $ map (pretty . getLoc) [_dupIteratorFirst, _dupIteratorFirst]
data ExportEntries
= ExportEntriesSymbols (NonEmpty SymbolEntry)
| ExportEntriesModules (NonEmpty ModuleSymbolEntry)
| ExportEntriesFixities (NonEmpty FixitySymbolEntry)
deriving stock (Show)
data MultipleExportConflict = MultipleExportConflict
{ _multipleExportModule :: S.AbsModulePath,
_multipleExportSymbol :: Symbol,
_multipleExportEntries :: Either (NonEmpty SymbolEntry) (NonEmpty ModuleSymbolEntry)
_multipleExportEntries :: ExportEntries
}
deriving stock (Show)
@ -852,3 +858,24 @@ instance ToGenericError RepeatedField where
where
i :: Interval
i = getLoc _repeatedField
newtype PrecedenceInconsistencyError = PrecedenceInconsistencyError
{ _precedenceInconsistencyErrorFixityDef :: FixitySyntaxDef 'Parsed
}
deriving stock (Show)
instance ToGenericError PrecedenceInconsistencyError where
genericError PrecedenceInconsistencyError {..} = do
opts <- fromGenericOptions <$> ask
let msg =
"Cannot resolve precedence ordering for "
<+> ppCode opts (_precedenceInconsistencyErrorFixityDef ^. fixitySymbol)
return
GenericError
{ _genericErrorLoc = i,
_genericErrorMessage = mkAnsiText msg,
_genericErrorIntervals = [i]
}
where
i :: Interval
i = getLoc _precedenceInconsistencyErrorFixityDef

45
src/Juvix/Compiler/Concrete/Translation/FromSource.hs
View File

@ -279,7 +279,7 @@ topModulePath = mkTopModulePath <$> dottedSymbol
infixl 3 <?|>
-- | Tries the left alternative. If it fails, backtracks and restores the contents of the pragmas and judoc stashes. Then parses the right atlernative
-- | Tries the left alternative. If it fails, backtracks and restores the contents of the pragmas and judoc stashes. Then parses the right alternative
(<?|>) :: Members '[PragmasStash, JudocStash] r => ParsecS r a -> ParsecS r a -> ParsecS r a
l <?|> r = do
p <- P.lift (get @(Maybe ParsedPragmas))
@ -296,15 +296,15 @@ statement = P.label "<top level statement>" $ do
optional_ stashPragmas
ms <-
optional
( StatementSyntax <$> syntaxDef
<|> StatementOpenModule
<$> newOpenSyntax
-- TODO remove <?|> after removing old syntax
<?|> StatementFunctionDef
<$> newTypeSignature Nothing
-- TODO remove <?|> after removing old syntax
<?|> StatementOpenModule
<$> openModule
( StatementOpenModule
<$> newOpenSyntax
-- TODO remove <?|> after removing old syntax
<?|> StatementFunctionDef
<$> newTypeSignature Nothing
-- TODO remove <?|> after removing old syntax
<?|> StatementOpenModule
<$> openModule
<|> StatementSyntax <$> syntaxDef
<|> StatementImport <$> import_
<|> StatementInductive <$> inductiveDef Nothing
<|> StatementModule <$> moduleDef
@ -517,10 +517,11 @@ builtinStatement = do
-- Syntax declaration
--------------------------------------------------------------------------------
syntaxDef :: forall r. (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r SyntaxDef
syntaxDef :: forall r. (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r (SyntaxDef 'Parsed)
syntaxDef = do
syn <- kw kwSyntax
(SyntaxOperator <$> operatorSyntaxDef syn)
(SyntaxFixity <$> fixitySyntaxDef syn)
<|> (SyntaxOperator <$> operatorSyntaxDef syn)
<|> (SyntaxIterator <$> iteratorSyntaxDef syn)
--------------------------------------------------------------------------------
@ -530,20 +531,20 @@ syntaxDef = do
precedence :: (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => ParsecS r Precedence
precedence = PrecNat <$> (fst <$> decimal)
fixitySyntaxDef :: forall r. (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => KeywordRef -> ParsecS r (FixitySyntaxDef 'Parsed)
fixitySyntaxDef _fixitySyntaxKw = P.label "<fixity declaration>" $ do
_fixityKw <- kw kwFixity
_fixitySymbol <- symbol
_fixityInfo <- withLoc (parseYaml "{" "}")
_fixityDoc <- getJudoc
return FixitySyntaxDef {..}
operatorSyntaxDef :: forall r. (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => KeywordRef -> ParsecS r OperatorSyntaxDef
operatorSyntaxDef _opSyntaxKw = do
(_fixityArity, _opKw) <- arity
_fixityPrecedence <- precedence
_opKw <- kw kwOperator
_opSymbol <- symbol
let _opFixity = Fixity {..}
_opFixity <- symbol
return OperatorSyntaxDef {..}
where
arity :: ParsecS r (OperatorArity, KeywordRef)
arity =
(Binary AssocRight,) <$> kw kwInfixr
<|> (Binary AssocLeft,) <$> kw kwInfixl
<|> (Binary AssocNone,) <$> kw kwInfix
<|> (Unary AssocPostfix,) <$> kw kwPostfix
--------------------------------------------------------------------------------
-- Iterator syntax declaration

1
src/Juvix/Compiler/Internal/Extra.hs
View File

@ -456,6 +456,7 @@ instance IsExpression Name where
KNameLocal -> IdenVar
KNameLocalModule -> impossible
KNameTopModule -> impossible
KNameFixity -> impossible
instance IsExpression SmallUniverse where
toExpression = ExpressionUniverse

1
src/Juvix/Compiler/Internal/Translation/FromConcrete.hs
View File

@ -895,6 +895,7 @@ goExpression = \case
KNameConstructor -> Internal.IdenConstructor n'
KNameLocalModule -> impossible
KNameTopModule -> impossible
KNameFixity -> impossible
where
n' = goName (x ^. scopedIden)

15
src/Juvix/Data/Fixity.hs
View File

@ -4,12 +4,11 @@ import Juvix.Prelude.Base
-- | Note that the order of the constructors is important due to the `Ord`
-- instance.
-- TODO should we rename PrecMinusOmega to PrecApp, PrecMinusOmega1 to PrecUpdate, and PrecOmega to PrecFunction/Arrow?
data Precedence
= PrecMinusOmega1
| PrecMinusOmega
| PrecNat Natural
| PrecOmega
= PrecUpdate
| PrecArrow
| PrecNat Int
| PrecApp
deriving stock (Show, Eq, Data, Ord)
data UnaryAssoc = AssocPostfix
@ -69,13 +68,13 @@ isUnary :: Fixity -> Bool
isUnary = not . isBinary
appFixity :: Fixity
appFixity = Fixity PrecOmega (Binary AssocLeft)
appFixity = Fixity PrecApp (Binary AssocLeft)
funFixity :: Fixity
funFixity = Fixity PrecMinusOmega (Binary AssocRight)
funFixity = Fixity PrecArrow (Binary AssocRight)
updateFixity :: Fixity
updateFixity = Fixity PrecMinusOmega1 (Unary AssocPostfix)
updateFixity = Fixity PrecUpdate (Unary AssocPostfix)
atomParens :: (Fixity -> Bool) -> Atomicity -> Fixity -> Bool
atomParens associates argAtom opInf = case argAtom of

53
src/Juvix/Data/FixityInfo.hs Normal file
View File

@ -0,0 +1,53 @@
module Juvix.Data.FixityInfo where
import Juvix.Data.Yaml
import Juvix.Prelude.Base
data Arity = Unary | Binary
deriving stock (Show, Eq, Ord, Generic)
data Assoc = AssocLeft | AssocRight | AssocNone
deriving stock (Show, Eq, Ord, Generic)
data FixityInfo = FixityInfo
{ _fixityArity :: Arity,
_fixityAssoc :: Maybe Assoc,
_fixityPrecSame :: Maybe Text,
_fixityPrecBelow :: [Text],
_fixityPrecAbove :: [Text]
}
deriving stock (Show, Eq, Ord, Generic)
makeLenses ''FixityInfo
instance FromJSON FixityInfo where
parseJSON = toAesonParser id parseFixityInfo
where
parseFixityInfo :: Parse YamlError FixityInfo
parseFixityInfo = do
checkYamlKeys ["arity", "assoc", "same", "below", "above"]
_fixityArity <- key "arity" parseArity
_fixityAssoc <- keyMay "assoc" parseAssoc
_fixityPrecSame <- keyMay "same" asText
_fixityPrecBelow <- fromMaybe [] <$> keyMay "below" (eachInArray asText)
_fixityPrecAbove <- fromMaybe [] <$> keyMay "above" (eachInArray asText)
when (isJust _fixityPrecSame && not (null _fixityPrecBelow && null _fixityPrecAbove)) $
throwCustomError "'same' cannot be provided together with 'above' or 'below'"
return FixityInfo {..}
parseArity :: Parse YamlError Arity
parseArity = do
txt <- asText
case txt of
"unary" -> return Unary
"binary" -> return Binary
_ -> throwCustomError "unknown arity"
parseAssoc :: Parse YamlError Assoc
parseAssoc = do
txt <- asText
case txt of
"left" -> return AssocLeft
"right" -> return AssocRight
"none" -> return AssocNone
_ -> throwCustomError "unknown associativity"

9
src/Juvix/Data/Keyword/All.hs
View File

@ -58,6 +58,9 @@ kwInfixl = asciiKw Str.infixl_
kwInfixr :: Keyword
kwInfixr = asciiKw Str.infixr_
kwOperator :: Keyword
kwOperator = asciiKw Str.operator
kwLambda :: Keyword
kwLambda = unicodeKw Str.lambdaAscii Str.lambdaUnicode
@ -76,9 +79,6 @@ kwModule = asciiKw Str.module_
kwOpen :: Keyword
kwOpen = asciiKw Str.open
kwPostfix :: Keyword
kwPostfix = asciiKw Str.postfix
kwPublic :: Keyword
kwPublic = asciiKw Str.public
@ -88,6 +88,9 @@ kwRightArrow = unicodeKw Str.toAscii Str.toUnicode
kwSyntax :: Keyword
kwSyntax = asciiKw Str.syntax
kwFixity :: Keyword
kwFixity = asciiKw Str.fixity
kwIterator :: Keyword
kwIterator = asciiKw Str.iterator

7
src/Juvix/Data/NameKind.hs
View File

@ -19,6 +19,8 @@ data NameKind
KNameLocalModule
| -- | A top module name.
KNameTopModule
| -- | A fixity name
KNameFixity
deriving stock (Show, Eq, Data)
$(genSingletons [''NameKind])
@ -47,6 +49,7 @@ nameKindText = \case
KNameAxiom -> "axiom"
KNameLocalModule -> "local module"
KNameTopModule -> "module"
KNameFixity -> "fixity"
isExprKind :: HasNameKind a => a -> Bool
isExprKind k = case getNameKind k of
@ -69,6 +72,7 @@ canBeCompiled k = case getNameKind k of
KNameLocal -> False
KNameLocalModule -> False
KNameTopModule -> False
KNameFixity -> False
canHaveFixity :: HasNameKind a => a -> Bool
canHaveFixity k = case getNameKind k of
@ -79,6 +83,7 @@ canHaveFixity k = case getNameKind k of
KNameLocal -> False
KNameLocalModule -> False
KNameTopModule -> False
KNameFixity -> False
canBeIterator :: HasNameKind a => a -> Bool
canBeIterator k = case getNameKind k of
@ -89,6 +94,7 @@ canBeIterator k = case getNameKind k of
KNameLocal -> False
KNameLocalModule -> False
KNameTopModule -> False
KNameFixity -> False
nameKindAnsi :: NameKind -> AnsiStyle
nameKindAnsi k = case k of
@ -99,6 +105,7 @@ nameKindAnsi k = case k of
KNameFunction -> colorDull Yellow
KNameLocal -> mempty
KNameTopModule -> color Cyan
KNameFixity -> mempty
isFunctionKind :: HasNameKind a => a -> Bool
isFunctionKind k = case getNameKind k of

1
src/Juvix/Data/Yaml.hs
View File

@ -11,6 +11,7 @@ import Juvix.Prelude.Base
type YamlError = Text
-- | Check that all keys are in the given list.
checkYamlKeys :: [Text] -> Parse Text ()
checkYamlKeys keys = do
forEachInObject

6
src/Juvix/Extra/Strings.hs
View File

@ -89,12 +89,18 @@ infixl_ = "infixl"
infixr_ :: (IsString s) => s
infixr_ = "infixr"
operator :: (IsString s) => s
operator = "operator"
open :: (IsString s) => s
open = "open"
syntax :: (IsString s) => s
syntax = "syntax"
fixity :: (IsString s) => s
fixity = "fixity"
iterator :: (IsString s) => s
iterator = "iterator"

6
test/Scope/Negative.hs
View File

@ -100,11 +100,11 @@ scoperErrorTests =
ErrInfixPattern {} -> Nothing
_ -> wrongError,
NegTest
"Duplicate fixity declaration"
"Duplicate operator declaration"
$(mkRelDir ".")
$(mkRelFile "DuplicateFixity.juvix")
$(mkRelFile "DuplicateOperator.juvix")
$ \case
ErrDuplicateFixity {} -> Nothing
ErrDuplicateOperator {} -> Nothing
_ -> wrongError,
NegTest
"Multiple export conflict"

4
tests/Compilation/positive/test045.juvix
View File

@ -6,7 +6,9 @@ module test045;
| zero : Nat
| suc : Nat → Nat;
syntax infixl 6 +;
syntax fixity additive {arity: binary, assoc: left};
syntax operator + additive;
+ : Nat → Nat → Nat;
+ zero b := b;
+ (suc a) b := suc (a + b);

9
tests/Compilation/positive/test052.juvix
View File

@ -11,7 +11,8 @@ LambdaTy : Type -> Type;
AppTy : Type -> Type;
syntax infixl 6 :+:;
syntax operator :+: additive;
--- An ;Expr'; is an expression in our language.
type Expr' (v : Type) :=
| ! : v -> Expr' v
@ -105,7 +106,7 @@ module ValTraits;
++str ExprTraits.toString n;
end;
syntax infixl 1 >>=;
syntax operator >>= seq;
--- Monadic binding for ;Either;.
>>= :
{e a b : Type}
@ -185,7 +186,9 @@ evalNat topExpr := eval topExpr >>= getNat;
Λ : Expr -> Expr;
Λ body := lam (mkLambda body);
syntax infixl 9 #;
syntax fixity app {arity: binary, assoc: left, above: [composition]};
syntax operator # app;
--- Syntactical helper for creating an ;app;.
# : Expr -> Expr -> Expr;
# f x := app (mkApp f x);

6
tests/negative/230/Foo/Data/Bool.juvix
View File

@ -2,6 +2,8 @@ module Foo.Data.Bool;
import Stdlib.Data.Bool;
syntax fixity logical {arity: binary, assoc: right};
type Bool :=
| true : Bool
| false : Bool;
@ -10,13 +12,13 @@ not : Bool → Bool
| true := false
| false := true;
syntax infixr 2 ||;
syntax operator || logical;
|| : Bool → Bool → Bool
| false a := a
| true _ := true;
syntax infixr 2 &&;
syntax operator && logical;
&& : Bool → Bool → Bool
| false _ := false

8
tests/negative/DuplicateFixity.juvix
View File

@ -1,8 +0,0 @@
module DuplicateFixity;
syntax infixl 3 +;
syntax infixl 3 +;
axiom + : Type → Type → Type;
end;

9
tests/negative/DuplicateOperator.juvix Normal file
View File

@ -0,0 +1,9 @@
module DuplicateOperator;
syntax fixity add {arity: binary};
syntax operator + add;
syntax operator + add;
axiom + : Type → Type → Type;
end;

4
tests/negative/InfixError.juvix
View File

@ -1,6 +1,8 @@
module InfixError;
syntax infix 5 + ;
syntax fixity add {arity: binary, assoc: none};
syntax operator + add;
axiom + : Type → Type → Type;
axiom T : Type + Type + ;

4
tests/negative/InfixErrorP.juvix
View File

@ -1,6 +1,8 @@
module InfixErrorP;
syntax infix 5 , ;
syntax fixity pair {arity: binary};
syntax operator , pair;
type Pair :=
, : Type → Type → Pair;

6
tests/negative/Termination/Data/Bool.juvix
View File

@ -1,16 +1,18 @@
module Data.Bool;
syntax fixity logical {arity: binary, assoc: right};
type Bool :=
| true : Bool
| false : Bool;
syntax infixr 2 ||;
syntax operator || logical;
|| : Bool → Bool → Bool
| false a := a
| true _ := true;
syntax infixr 2 &&;
syntax operator && logical;
&& : Bool → Bool → Bool
| false _ := false

11
tests/negative/Termination/Data/Nat.juvix
View File

@ -1,16 +1,19 @@
module Data.Nat;
syntax fixity add {arity: binary};
syntax fixity mul {arity: binary, above: [add]};
type ℕ :=
| zero : ℕ
| suc : ℕ → ℕ;
syntax infixl 6 +;
syntax operator + add;
+ : ℕ → ℕ → ℕ
| zero b := b
| (suc a) b := suc (a + b);
syntax infixl 7 *;
syntax operator * mul;
* : ℕ → ℕ → ℕ
| zero b := zero
@ -20,11 +23,11 @@ import Data.Bool;
open Data.Bool;
even : ℕ → Bool
| zero := true
| (suc n) := odd n;
odd : ℕ → Bool
| zero := false
| (suc n) := even n;

3
tests/negative/UnusedOperatorDef.juvix
View File

@ -1,3 +1,4 @@
module UnusedOperatorDef;
syntax infixl 12 + ;
syntax fixity add {arity: binary};
syntax operator + add;
end ;

16
tests/positive/Ape.juvix
View File

@ -3,19 +3,25 @@ module Ape;
builtin string
axiom String : Type;
syntax infixl 7 *;
syntax fixity seq {arity: binary, assoc: left};
syntax fixity sub {arity: binary, assoc: right, above: [seq]};
syntax fixity ladd {arity: binary, assoc: left, above: [sub]};
syntax fixity radd {arity: binary, assoc: right, same: ladd};
syntax fixity mul {arity: binary, assoc: left, above: [ladd]};
syntax operator * mul;
axiom * : String → String → String;
syntax infixr 3 -;
syntax operator - sub;
axiom - : String → String → String;
syntax infixl 1 >>;
syntax operator >> seq;
axiom >> : String → String → String;
syntax infixl 6 +;
syntax operator + ladd;
axiom + : String → String → String;
syntax infixr 6 ++;
syntax operator ++ radd;
axiom ++ : String → String → String;
axiom f : String → String;

22
tests/positive/Format.juvix
View File

@ -27,7 +27,7 @@ go : Nat → Nat → Nat
module {- local module -}
M;
syntax -- syntax in local modules
infixr 4 ,;
operator , pair;
axiom , : String → String → String;
end;
@ -60,19 +60,25 @@ t3 : String :=
-- escaping in String literals
e1 : String := "\"\n";
syntax infixl 7 +l7;
syntax fixity l1 {arity: binary, assoc: left, below: [pair]};
syntax fixity r3 {arity: binary, assoc: right, above: [pair]};
syntax fixity l6 {arity: binary, assoc: left, above: [r3]};
syntax fixity r6 {arity: binary, assoc: right, same: l6};
syntax fixity l7 {arity: binary, assoc: left, above: [l6]};
syntax operator +l7 l7;
axiom +l7 : String → String → String;
syntax infixr 3 +r3;
syntax operator +r3 r3;
axiom +r3 : String → String → String;
syntax infixl 1 +l1;
syntax operator +l1 l1;
axiom +l1 : String → String → String;
syntax infixl 6 +l6;
syntax operator +l6 l6;
axiom +l6 : String → String → String;
syntax infixr 6 +r6;
syntax operator +r6 r6;
axiom +r6 : String → String → String;
-- nesting of chains
@ -158,8 +164,8 @@ f : Nat -> Nat :=
};
module Patterns;
syntax infixr 2 ×;
syntax infixr 4 ,;
syntax operator × functor;
syntax operator , pair;
type × (A : Type) (B : Type) :=
| , : A → B → A × B;

8
tests/positive/Imports/A.juvix
View File

@ -1,13 +1,17 @@
module A;
syntax fixity i3 {arity: binary};
module M;
module N;
syntax infix 3 t;
syntax operator t i3;
type T :=
| t : T;
end;
syntax infixr 2 +;
syntax fixity add {arity: binary, assoc: right, below: [i3]};
syntax operator + add;
axiom + : Type → Type → Type;
end;

10
tests/positive/Internal/AsPattern.juvix
View File

@ -1,6 +1,8 @@
module AsPattern;
syntax infixr 9 ∘;
import Stdlib.Data.Fixity open;
syntax operator ∘ composition;
∘
: {A : Type}
@ -17,15 +19,15 @@ type Nat :=
| zero : Nat
| suc : Nat → Nat;
syntax infixl 6 +;
syntax operator + additive;
builtin nat-plus
+ : Nat → Nat → Nat
| zero b := b
| (suc a) b := suc (a + b);
syntax infixr 2 ×;
syntax infixr 4 ,;
syntax operator × functor;
syntax operator , pair;
type × (A : Type) (B : Type) :=
| , : A → B → A × B;

10
tests/positive/Internal/Implicit.juvix
View File

@ -1,6 +1,8 @@
module Implicit;
syntax infixr 9 ∘;
import Stdlib.Data.Fixity open;
syntax operator ∘ composition;
∘
: {A : Type}
@ -16,8 +18,8 @@ type Nat :=
| zero : Nat
| suc : Nat → Nat;
syntax infixr 2 ×;
syntax infixr 4 ,;
syntax operator × functor;
syntax operator , pair;
type × (A : Type) (B : Type) :=
| , : A → B → A × B;
@ -68,7 +70,7 @@ if : {A : Type} → Bool → A → A → A
| true a _ := a
| false _ b := b;
syntax infixr 5 ::;
syntax operator :: cons;
type List (A : Type) :=
| nil : List A
| :: : A → List A → List A;

10
tests/positive/Internal/Lambda.juvix
View File

@ -1,15 +1,17 @@
module Lambda;
import Stdlib.Data.Fixity open;
type Nat :=
| zero : Nat
| suc : Nat → Nat;
syntax infixr 2 ×;
syntax infixr 4 ,;
syntax operator × functor;
syntax operator , pair;
type × (A : Type) (B : Type) :=
| , : A → B → A × B;
syntax infixr 9 ∘;
syntax operator ∘ composition;
∘
: {A : Type}
@ -74,7 +76,7 @@ second
both : {A : Type} → {B : Type} → (A → B) → A × A → B × B
| {_} {B} := λ {f (a, b) := f a, f b};
syntax infixr 5 ::;
syntax operator :: cons;
type List (a : Type) :=
| nil : List a
| :: : a → List a → List a;

10
tests/positive/Internal/Simple.juvix
View File

@ -13,20 +13,24 @@ type Nat :=
| zero : Nat
| suc : Nat → Nat;
syntax infix 3 ==;
syntax fixity cmp {arity: binary};
syntax fixity add {arity: binary, assoc: left, above: [cmp]};
syntax fixity cons {arity: binary, assoc: right, above: [add]};
syntax operator == cmp;
== : Nat → Nat → Bool
| zero zero := true
| (suc a) (suc b) := a == b
| _ _ := false;
syntax infixl 4 +;
syntax operator + add;
+ : Nat → Nat → Nat
| zero b := b
| (suc a) b := suc (a + b);
syntax infixr 5 ::;
syntax operator :: cons;
type List :=
| nil : List
| :: : Nat → List → List;

6
tests/positive/MutualType.juvix
View File

@ -1,6 +1,8 @@
module MutualType;
syntax infixr 5 ::;
syntax fixity cons {arity: binary, assoc: right};
syntax operator :: cons;
--- Inductive list.
type List (a : Type) :=
| --- The empty list
@ -9,7 +11,7 @@ type List (a : Type) :=
:: : a → List a → List a;
Forest : Type -> Type
| A := List (Tree A);
--- N-Ary tree.

4
tests/positive/Operators.juvix
View File

@ -1,6 +1,8 @@
module Operators;
syntax infixl 5 +;
syntax fixity add {arity: binary, assoc: left};
syntax operator + add;
axiom + : Type → Type → Type;
plus : Type → Type → Type := (+);

7
tests/positive/Reachability/Data/Nat.juvix
View File

@ -1,16 +1,19 @@
module Data.Nat;
syntax fixity add {arity: binary, assoc: left};
syntax fixity mul {arity: binary, assoc: left, above: [add]};
type ℕ :=
| zero : ℕ
| suc : ℕ → ℕ;
syntax infixl 6 +;
syntax operator + add;
+ : ℕ → ℕ → ℕ
| zero b := b
| (suc a) b := suc (a + b);
syntax infixl 7 *;
syntax operator * mul;
* : ℕ → ℕ → ℕ
| zero b := zero

4
tests/positive/Reachability/Data/Product.juvix
View File

@ -1,5 +1,7 @@
module Data.Product;
syntax infixr 2 ×;
syntax fixity prod {arity: binary};
syntax operator × prod;
type × (a : Type) (b : Type) :=
| , : a → b → a × b;

7
tests/positive/StdlibList/Data/Nat.juvix
View File

@ -1,16 +1,19 @@
module Data.Nat;
syntax fixity add {arity: binary, assoc: left};
syntax fixity mul {arity: binary, assoc: left, above: [add]};
type ℕ :=
| zero : ℕ
| suc : ℕ → ℕ;
syntax infixl 6 +;
syntax operator + add;
+ : ℕ → ℕ → ℕ
| zero b := b
| (suc a) b := suc (a + b);
syntax infixl 7 *;
syntax operator * mul;
* : ℕ → ℕ → ℕ
| zero b := zero

4
tests/positive/StdlibList/Data/Product.juvix
View File

@ -1,5 +1,7 @@
module Data.Product;
syntax infixr 2 ×;
syntax fixity prod {arity: binary};
syntax operator × prod;
type × (a : Type) (b : Type) :=
| , : a → b → a × b;

5
tests/positive/Symbols.juvix
View File

@ -1,5 +1,6 @@
module Symbols;
import Stdlib.Data.Fixity open;
import Stdlib.Data.Nat open;
╘⑽╛ : Nat := suc 9;
@ -11,11 +12,11 @@ import Stdlib.Data.Nat open;
（*） : Nat -> Nat -> Nat := (*);
syntax infixl 6 －;
syntax operator － additive;
－ : Nat -> Nat -> Nat := （-）;
syntax infixl 7 ·;
syntax operator · multiplicative;
· : Nat -> Nat -> Nat := （*）;

6
tests/positive/Syntax.juvix
View File

@ -26,7 +26,9 @@ odd : Nat -> Bool
| zero := false
| (suc n) := even n;
syntax infixl 4 ==1;
syntax fixity cmp {arity: binary};
syntax operator ==1 cmp;
==1 : Nat -> Nat -> Bool
| zero zero := true
@ -34,7 +36,7 @@ syntax infixl 4 ==1;
| _ _ := false;
-- note that ==2 is used before its infix definition
syntax infixl 4 ==2;
syntax operator ==2 cmp;
==2 : Nat -> Nat -> Bool
| zero zero := true

6
tests/positive/Termination/Data/Bool.juvix
View File

@ -1,5 +1,7 @@
module Data.Bool;
syntax fixity logical {arity: binary, assoc: right};
type Bool :=
| true : Bool
| false : Bool;
@ -8,13 +10,13 @@ not : Bool → Bool
| true := false
| false := true;
syntax infixr 2 ||;
syntax operator || logical;
|| : Bool → Bool → Bool
| false a := a
| true _ := true;
syntax infixr 2 &&;
syntax operator && logical;
&& : Bool → Bool → Bool
| false _ := false

11
tests/positive/Termination/Data/Nat.juvix
View File

@ -1,16 +1,19 @@
module Data.Nat;
syntax fixity add {arity: binary, assoc: left};
syntax fixity mul {arity: binary, assoc: left, above: [add]};
type ℕ :=
| zero : ℕ
| suc : ℕ → ℕ;
syntax infixl 6 +;
syntax operator + add;
+ : ℕ → ℕ → ℕ
| zero b := b
| (suc a) b := suc (a + b);
syntax infixl 7 *;
syntax operator * mul;
* : ℕ → ℕ → ℕ
| zero b := zero
@ -20,11 +23,11 @@ import Data.Bool;
open Data.Bool;
even : ℕ → Bool
| zero := true
| (suc n) := odd n;
odd : ℕ → Bool
| zero := false
| (suc n) := even n;

4
tests/positive/Termination/Fib.juvix
View File

@ -1,10 +1,12 @@
module Fib;
syntax fixity add {arity: binary, assoc: left};
type Nat :=
| zero : Nat
| suc : Nat → Nat;
syntax infixl 6 +;
syntax operator + add;
+ : Nat → Nat → Nat
| zero b := b

4
tests/positive/TypeAlias.juvix
View File

@ -13,7 +13,9 @@ x : alias := t;
id : Type → Type
| x := x;
syntax infixr 9 ⊙;
syntax fixity composition {arity: binary, assoc: right};
syntax operator ⊙ composition;
⊙ : (Type → Type) → (Type → Type) → Type → Type
| f g x := f (g x);

4
tests/positive/issue1466/M.juvix
View File

@ -8,7 +8,9 @@ nat : Type := ℕ;
nat2 : Type := nat;
syntax infixl 1 +;
syntax fixity add {arity: binary};
syntax operator + add;
+ : nat2 → nat → nat
| z b := b