From 0cf993134ed26ebeab702fb573e8f219ddde7c70 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=81ukasz=20Czajka?= <62751+lukaszcz@users.noreply.github.com> Date: Tue, 26 Sep 2023 11:28:50 +0200 Subject: [PATCH] Add fixity `none` and make aliases inherit fixity (#2391) * Closes #2310 * Makes aliases inherit fixity * Adds `none` fixity definition to the standard library --- juvix-stdlib | 2 +- .../Compiler/Backend/C/Translation/FromReg.hs | 1 + .../Compiler/Concrete/Data/ScopedName.hs | 4 +++- src/Juvix/Compiler/Concrete/Print/Base.hs | 1 + .../FromParsed/Analysis/Scoping.hs | 20 ++++++++++++------- .../Concrete/Translation/FromSource.hs | 2 ++ src/Juvix/Data/Fixity.hs | 2 ++ src/Juvix/Data/FixityInfo.hs | 1 + tests/positive/Alias.juvix | 5 +++++ 9 files changed, 29 insertions(+), 9 deletions(-) diff --git a/juvix-stdlib b/juvix-stdlib index 2680b1984..23f6b1991 160000 --- a/juvix-stdlib +++ b/juvix-stdlib @@ -1 +1 @@ -Subproject commit 2680b19844616821d4ce77a40e9f02fb2e6c1995 +Subproject commit 23f6b1991e8f31e1360a7e23a21c6a9732a292b1 diff --git a/src/Juvix/Compiler/Backend/C/Translation/FromReg.hs b/src/Juvix/Compiler/Backend/C/Translation/FromReg.hs index 770cf09e8..4e9035c22 100644 --- a/src/Juvix/Compiler/Backend/C/Translation/FromReg.hs +++ b/src/Juvix/Compiler/Backend/C/Translation/FromReg.hs @@ -77,6 +77,7 @@ fromReg lims tab = Fixity.OpBinary AssocNone -> "assoc_none" Fixity.OpBinary AssocLeft -> "assoc_left" Fixity.OpBinary AssocRight -> "assoc_right" + Fixity.OpNone -> "assoc_none" functionInfo :: CCode functionInfo = diff --git a/src/Juvix/Compiler/Concrete/Data/ScopedName.hs b/src/Juvix/Compiler/Concrete/Data/ScopedName.hs index 9e69aa62a..abb9e6bc8 100644 --- a/src/Juvix/Compiler/Concrete/Data/ScopedName.hs +++ b/src/Juvix/Compiler/Concrete/Data/ScopedName.hs @@ -117,7 +117,9 @@ instance HasNameKind AName where getNameKind = (^. anameKind) hasFixity :: Name' s -> Bool -hasFixity n = isJust (n ^. nameFixity) +hasFixity n = case n ^. nameFixity of + Just Fixity {..} -> _fixityArity /= OpNone + Nothing -> False isConstructor :: Name' s -> Bool isConstructor n = case n ^. nameKind of diff --git a/src/Juvix/Compiler/Concrete/Print/Base.hs b/src/Juvix/Compiler/Concrete/Print/Base.hs index 688d6cc8f..6c8055860 100644 --- a/src/Juvix/Compiler/Concrete/Print/Base.hs +++ b/src/Juvix/Compiler/Concrete/Print/Base.hs @@ -663,6 +663,7 @@ instance PrettyPrint Arity where ppCode = \case Unary -> noLoc Str.unary Binary -> noLoc Str.binary + None -> noLoc Str.none instance PrettyPrint BinaryAssoc where ppCode a = noLoc $ case a of diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs index 31b678df0..9eb6d4963 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs @@ -556,9 +556,12 @@ entryToScopedIden name e = do } PreSymbolAlias {} -> do e' <- normalizePreSymbolEntry e + let scopedName' = + over S.nameFixity (maybe (e' ^. symbolEntry . S.nameFixity) Just) $ + set S.nameKind (getNameKind e') scopedName return ScopedIden - { _scopedIdenAlias = Just (set S.nameKind (getNameKind e') scopedName), + { _scopedIdenAlias = Just scopedName', _scopedIdenFinal = helper (e' ^. symbolEntry) } registerScopedIden si @@ -706,6 +709,7 @@ resolveFixitySyntaxDef fdef@FixitySyntaxDef {..} = topBindings $ do Just FI.AssocLeft -> OpBinary AssocLeft Just FI.AssocRight -> OpBinary AssocRight Just FI.AssocNone -> OpBinary AssocNone + FI.None -> OpNone } registerFixity @$> FixityDef @@ -2433,14 +2437,14 @@ makeExpressionTable (ExpressionAtoms atoms _) = [recordUpdate] : [appOpExplicit] where mkOperator :: ScopedIden -> Maybe (Precedence, P.Operator Parse Expression) mkOperator iden - | Just Fixity {..} <- _nameFixity = Just $ + | Just Fixity {..} <- _nameFixity = case _fixityArity of - OpUnary u -> (_fixityPrecedence, P.Postfix (unaryApp <$> parseSymbolId _nameId)) + OpUnary u -> Just (_fixityPrecedence, P.Postfix (unaryApp <$> parseSymbolId _nameId)) where unaryApp :: ScopedIden -> Expression -> Expression unaryApp funName arg = case u of AssocPostfix -> ExpressionPostfixApplication (PostfixApplication arg funName) - OpBinary b -> (_fixityPrecedence, infixLRN (binaryApp <$> parseSymbolId _nameId)) + OpBinary b -> Just (_fixityPrecedence, infixLRN (binaryApp <$> parseSymbolId _nameId)) where binaryApp :: ScopedIden -> Expression -> Expression -> Expression binaryApp _infixAppOperator _infixAppLeft _infixAppRight = @@ -2450,6 +2454,7 @@ makeExpressionTable (ExpressionAtoms atoms _) = [recordUpdate] : [appOpExplicit] AssocLeft -> P.InfixL AssocRight -> P.InfixR AssocNone -> P.InfixN + OpNone -> Nothing | otherwise = Nothing where S.Name' {..} = iden ^. scopedIdenName @@ -2725,13 +2730,13 @@ makePatternTable (PatternAtoms latoms _) = [appOp] : operators unqualifiedSymbolOp constr = run . runFail $ do Fixity {..} <- failMaybe (constr ^. scopedIdenName . S.nameFixity) let _nameId = constr ^. scopedIdenName . S.nameId - return $ case _fixityArity of - OpUnary u -> (_fixityPrecedence, P.Postfix (unaryApp <$> parseSymbolId _nameId)) + case _fixityArity of + OpUnary u -> return (_fixityPrecedence, P.Postfix (unaryApp <$> parseSymbolId _nameId)) where unaryApp :: ScopedIden -> PatternArg -> PatternArg unaryApp constrName = case u of AssocPostfix -> explicitP . PatternPostfixApplication . (`PatternPostfixApp` constrName) - OpBinary b -> (_fixityPrecedence, infixLRN (binaryInfixApp <$> parseSymbolId _nameId)) + OpBinary b -> return (_fixityPrecedence, infixLRN (binaryInfixApp <$> parseSymbolId _nameId)) where binaryInfixApp :: ScopedIden -> PatternArg -> PatternArg -> PatternArg binaryInfixApp name argLeft = explicitP . PatternInfixApplication . PatternInfixApp argLeft name @@ -2740,6 +2745,7 @@ makePatternTable (PatternAtoms latoms _) = [appOp] : operators AssocLeft -> P.InfixL AssocRight -> P.InfixR AssocNone -> P.InfixN + OpNone -> fail parseSymbolId :: S.NameId -> ParsePat ScopedIden parseSymbolId uid = P.token getConstructorRefWithId mempty where diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs index bd873c7f7..7915a9822 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs @@ -568,6 +568,8 @@ parsedFixityInfo = do $> Unary <|> kw kwBinary $> Binary + <|> kw kwNone + $> None fixitySyntaxDef :: forall r. (Members '[InfoTableBuilder, PragmasStash, JudocStash, NameIdGen] r) => KeywordRef -> ParsecS r (FixitySyntaxDef 'Parsed) fixitySyntaxDef _fixitySyntaxKw = P.label "" $ do diff --git a/src/Juvix/Data/Fixity.hs b/src/Juvix/Data/Fixity.hs index ec990654e..fcafc7474 100644 --- a/src/Juvix/Data/Fixity.hs +++ b/src/Juvix/Data/Fixity.hs @@ -24,6 +24,7 @@ data BinaryAssoc data OperatorArity = OpUnary UnaryAssoc | OpBinary BinaryAssoc + | OpNone deriving stock (Show, Eq, Ord, Data) data Fixity = Fixity @@ -65,6 +66,7 @@ isBinary :: Fixity -> Bool isBinary f = case f ^. fixityArity of OpBinary {} -> True OpUnary {} -> False + OpNone -> False isUnary :: Fixity -> Bool isUnary = not . isBinary diff --git a/src/Juvix/Data/FixityInfo.hs b/src/Juvix/Data/FixityInfo.hs index 85fe2fc41..8aede44bd 100644 --- a/src/Juvix/Data/FixityInfo.hs +++ b/src/Juvix/Data/FixityInfo.hs @@ -11,6 +11,7 @@ import Juvix.Prelude.Base data Arity = Unary | Binary + | None deriving stock (Show, Eq, Ord, Generic) -- TODO consider using sum type for Same | Below && Above diff --git a/tests/positive/Alias.juvix b/tests/positive/Alias.juvix index 59bb5af87..2389e349a 100644 --- a/tests/positive/Alias.juvix +++ b/tests/positive/Alias.juvix @@ -37,10 +37,15 @@ syntax operator || logical; | zero b := b | one _ := one; +syntax operator or none; syntax alias or := ||; +syntax alias ||| := ||; + or3 (a b c : Binary) : Binary := or (or a b) c; +or3' (a b c : Binary) : Binary := (a ||| b) ||| c; + type Pair := | mkPair Binary Binary;