From 96a1ad560fe22e58f91031a045fed9d591cda412 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Thu, 30 Nov 2023 11:43:18 +0000 Subject: [PATCH] feat: Output separate nodes for variable bindings Note that we currently create fake IDs for these on the fly, as we already did for various elements of patterns. As a result, bindings are in effect not selectable, and thus cannot have actions assigned to them. We will need to give bindings IDs in the core of the library in order to solve this, most likely by making more use of our `Bind` type. Signed-off-by: George Thomas --- primer-api/src/Primer/API.hs | 101 ++++++++-- primer-api/src/Primer/API/EdgeFlavor.hs | 1 + primer-api/src/Primer/API/NodeFlavor.hs | 17 +- primer-api/test/outputs/APITree/Expr | 182 ++++++++++++------ primer-api/test/outputs/APITree/Type | 30 ++- .../test/outputs/OpenAPI/openapi.json | 24 +-- 6 files changed, 250 insertions(+), 105 deletions(-) diff --git a/primer-api/src/Primer/API.hs b/primer-api/src/Primer/API.hs index b349106e6..a5bbb47bc 100644 --- a/primer-api/src/Primer/API.hs +++ b/primer-api/src/Primer/API.hs @@ -853,16 +853,34 @@ viewTreeExpr e0 = case e0 of Lam _ s e -> Tree { nodeId - , body = TextBody $ RecordPair Flavor.Lam $ localName s + , body = NoBody Flavor.Lam , childTrees = [RecordPair EdgeFlavor.Lam $ viewTreeExpr e] - , rightChild = Nothing + , rightChild = + Just + $ RecordPair + EdgeFlavor.Bind + Tree + { nodeId = bindingNodeId + , body = TextBody $ RecordPair Flavor.VarBind $ localName s + , childTrees = [] + , rightChild = Nothing + } } LAM _ s e -> Tree { nodeId - , body = TextBody $ RecordPair Flavor.LAM $ localName s + , body = NoBody Flavor.LAM , childTrees = [RecordPair EdgeFlavor.Lam $ viewTreeExpr e] - , rightChild = Nothing + , rightChild = + Just + $ RecordPair + EdgeFlavor.Bind + Tree + { nodeId = bindingNodeId + , body = TextBody $ RecordPair Flavor.TVarBind $ localName s + , childTrees = [] + , rightChild = Nothing + } } Var _ ref -> Tree @@ -876,23 +894,50 @@ viewTreeExpr e0 = case e0 of Let _ s e1 e2 -> Tree { nodeId - , body = TextBody $ RecordPair Flavor.Let $ localName s + , body = NoBody Flavor.Let , childTrees = [RecordPair EdgeFlavor.LetEqual $ viewTreeExpr e1, RecordPair EdgeFlavor.LetIn $ viewTreeExpr e2] - , rightChild = Nothing + , rightChild = + Just + $ RecordPair + EdgeFlavor.Bind + Tree + { nodeId = bindingNodeId + , body = TextBody $ RecordPair Flavor.VarBind $ localName s + , childTrees = [] + , rightChild = Nothing + } } LetType _ s t e -> Tree { nodeId - , body = TextBody $ RecordPair Flavor.LetType $ localName s + , body = NoBody Flavor.LetType , childTrees = [RecordPair EdgeFlavor.LetEqual $ viewTreeExpr e, RecordPair EdgeFlavor.LetIn $ viewTreeType t] - , rightChild = Nothing + , rightChild = + Just + $ RecordPair + EdgeFlavor.Bind + Tree + { nodeId = bindingNodeId + , body = TextBody $ RecordPair Flavor.TVarBind $ localName s + , childTrees = [] + , rightChild = Nothing + } } Letrec _ s e1 t e2 -> Tree { nodeId - , body = TextBody $ RecordPair Flavor.Letrec $ localName s + , body = NoBody Flavor.Letrec , childTrees = [RecordPair EdgeFlavor.LetEqual $ viewTreeExpr e1, RecordPair EdgeFlavor.Ann $ viewTreeType t, RecordPair EdgeFlavor.LetIn $ viewTreeExpr e2] - , rightChild = Nothing + , rightChild = + Just + $ RecordPair + EdgeFlavor.Bind + Tree + { nodeId = bindingNodeId + , body = TextBody $ RecordPair Flavor.VarBind $ localName s + , childTrees = [] + , rightChild = Nothing + } } Case _ e bs fb -> Tree @@ -935,7 +980,7 @@ viewTreeExpr e0 = case e0 of EdgeFlavor.ConField Tree { nodeId = show $ getID m - , body = TextBody $ RecordPair Flavor.PatternBind $ localName v + , body = TextBody $ RecordPair Flavor.VarBind $ localName v , childTrees = [] , rightChild = Nothing } @@ -985,6 +1030,10 @@ viewTreeExpr e0 = case e0 of , rightChild = Nothing } where + bindingNodeId = nodeId <> "V" + -- this ID will not clash with any others in the tree, + -- since node IDs in the input expression are unique, + -- and don't contain non-numerical characters nodeId = show $ e0 ^. _id -- | Similar to 'viewTreeExpr', but for 'Type's @@ -1040,19 +1089,41 @@ viewTreeType' t0 = case t0 of TForall _ n k t -> Tree { nodeId - , body = TextBody $ RecordPair Flavor.TForall $ localName n + , body = NoBody Flavor.TForall , childTrees = [RecordPair EdgeFlavor.ForallKind $ viewTreeKind' k, RecordPair EdgeFlavor.Forall $ viewTreeType' t] - , rightChild = Nothing + , rightChild = + Just + $ RecordPair + EdgeFlavor.Bind + Tree + { nodeId = bindingNodeId + , body = TextBody $ RecordPair Flavor.TVarBind $ localName n + , childTrees = [] + , rightChild = Nothing + } } TLet _ n t b -> Tree { nodeId - , body = TextBody $ RecordPair Flavor.TLet $ localName n + , body = NoBody Flavor.TLet , childTrees = [RecordPair EdgeFlavor.LetEqual $ viewTreeType' t, RecordPair EdgeFlavor.LetIn $ viewTreeType' b] - , rightChild = Nothing + , rightChild = + Just + $ RecordPair + EdgeFlavor.Bind + Tree + { nodeId = bindingNodeId + , body = TextBody $ RecordPair Flavor.TVarBind $ localName n + , childTrees = [] + , rightChild = Nothing + } } where nodeId = t0 ^. _typeMetaLens + -- this ID will not clash with any others in the tree, + -- since node IDs in the input expression are unique, + -- and don't contain non-numerical characters + bindingNodeId = nodeId <> "V" -- | Like 'viewTreeType', but for kinds. viewTreeKind :: Kind -> Tree diff --git a/primer-api/src/Primer/API/EdgeFlavor.hs b/primer-api/src/Primer/API/EdgeFlavor.hs index c4aa94530..d8ca3ad8c 100644 --- a/primer-api/src/Primer/API/EdgeFlavor.hs +++ b/primer-api/src/Primer/API/EdgeFlavor.hs @@ -29,6 +29,7 @@ data EdgeFlavor | FunOut | ForallKind | Forall + | Bind deriving stock (Show, Read, Eq, Generic) deriving (ToJSON, FromJSON) via PrimerJSON EdgeFlavor deriving anyclass (NFData) diff --git a/primer-api/src/Primer/API/NodeFlavor.hs b/primer-api/src/Primer/API/NodeFlavor.hs index 9ce688238..b94bee856 100644 --- a/primer-api/src/Primer/API/NodeFlavor.hs +++ b/primer-api/src/Primer/API/NodeFlavor.hs @@ -19,19 +19,13 @@ import Primer.JSON (CustomJSON (..), FromJSON, PrimerJSON, ToJSON) data NodeFlavorTextBody = Con - | Lam - | LAM - | Let - | LetType - | Letrec - | PatternBind | PatternCon | TCon | TVar - | TForall - | TLet | GlobalVar | LocalVar + | VarBind + | TVarBind deriving stock (Show, Read, Eq, Generic, Enum, Bounded) deriving (ToJSON, FromJSON) via PrimerJSON NodeFlavorTextBody deriving anyclass (NFData) @@ -65,6 +59,13 @@ data NodeFlavorNoBody | KType | KHole | KFun + | Lam + | LAM + | Let + | LetType + | Letrec + | TLet + | TForall deriving stock (Show, Read, Eq, Generic, Enum, Bounded) deriving (ToJSON, FromJSON) via PrimerJSON NodeFlavorNoBody deriving anyclass (NFData) diff --git a/primer-api/test/outputs/APITree/Expr b/primer-api/test/outputs/APITree/Expr index bc71a4b50..fc94c8137 100644 --- a/primer-api/test/outputs/APITree/Expr +++ b/primer-api/test/outputs/APITree/Expr @@ -1,14 +1,6 @@ Tree { nodeId = "10" - , body = TextBody - ( RecordPair - { fst = Let - , snd = Name - { qualifiedModule = Nothing - , baseName = "x" - } - } - ) + , body = NoBody Let , childTrees = [ RecordPair { fst = LetEqual @@ -64,15 +56,7 @@ Tree { fst = LetIn , snd = Tree { nodeId = "14" - , body = TextBody - ( RecordPair - { fst = Letrec - , snd = Name - { qualifiedModule = Nothing - , baseName = "y" - } - } - ) + , body = NoBody Letrec , childTrees = [ RecordPair { fst = LetEqual @@ -243,29 +227,13 @@ Tree { fst = AnnTerm , snd = Tree { nodeId = "28" - , body = TextBody - ( RecordPair - { fst = Lam - , snd = Name - { qualifiedModule = Nothing - , baseName = "i" - } - } - ) + , body = NoBody Lam , childTrees = [ RecordPair { fst = Lam , snd = Tree { nodeId = "29" - , body = TextBody - ( RecordPair - { fst = LAM - , snd = Name - { qualifiedModule = Nothing - , baseName = "β" - } - } - ) + , body = NoBody LAM , childTrees = [ RecordPair { fst = Lam @@ -283,15 +251,7 @@ Tree { fst = AppArg , snd = Tree { nodeId = "32" - , body = TextBody - ( RecordPair - { fst = LetType - , snd = Name - { qualifiedModule = Nothing - , baseName = "b" - } - } - ) + , body = NoBody LetType , childTrees = [ RecordPair { fst = LetEqual @@ -334,7 +294,25 @@ Tree } } ] - , rightChild = Nothing + , rightChild = Just + ( RecordPair + { fst = Bind + , snd = Tree + { nodeId = "32V" + , body = TextBody + ( RecordPair + { fst = TVarBind + , snd = Name + { qualifiedModule = Nothing + , baseName = "b" + } + } + ) + , childTrees = [] + , rightChild = Nothing + } + } + ) } } , RecordPair @@ -460,7 +438,7 @@ Tree { nodeId = "39" , body = TextBody ( RecordPair - { fst = PatternBind + { fst = VarBind , snd = Name { qualifiedModule = Nothing , baseName = "n" @@ -644,11 +622,47 @@ Tree } } ] - , rightChild = Nothing + , rightChild = Just + ( RecordPair + { fst = Bind + , snd = Tree + { nodeId = "29V" + , body = TextBody + ( RecordPair + { fst = TVarBind + , snd = Name + { qualifiedModule = Nothing + , baseName = "β" + } + } + ) + , childTrees = [] + , rightChild = Nothing + } + } + ) } } ] - , rightChild = Nothing + , rightChild = Just + ( RecordPair + { fst = Bind + , snd = Tree + { nodeId = "28V" + , body = TextBody + ( RecordPair + { fst = VarBind + , snd = Name + { qualifiedModule = Nothing + , baseName = "i" + } + } + ) + , childTrees = [] + , rightChild = Nothing + } + } + ) } } , RecordPair @@ -681,15 +695,7 @@ Tree { fst = FunOut , snd = Tree { nodeId = "50" - , body = TextBody - ( RecordPair - { fst = TForall - , snd = Name - { qualifiedModule = Nothing - , baseName = "α" - } - } - ) + , body = NoBody TForall , childTrees = [ RecordPair { fst = ForallKind @@ -778,7 +784,25 @@ Tree } } ] - , rightChild = Nothing + , rightChild = Just + ( RecordPair + { fst = Bind + , snd = Tree + { nodeId = "50V" + , body = TextBody + ( RecordPair + { fst = TVarBind + , snd = Name + { qualifiedModule = Nothing + , baseName = "α" + } + } + ) + , childTrees = [] + , rightChild = Nothing + } + } + ) } } ] @@ -790,9 +814,45 @@ Tree } } ] - , rightChild = Nothing + , rightChild = Just + ( RecordPair + { fst = Bind + , snd = Tree + { nodeId = "14V" + , body = TextBody + ( RecordPair + { fst = VarBind + , snd = Name + { qualifiedModule = Nothing + , baseName = "y" + } + } + ) + , childTrees = [] + , rightChild = Nothing + } + } + ) } } ] - , rightChild = Nothing + , rightChild = Just + ( RecordPair + { fst = Bind + , snd = Tree + { nodeId = "10V" + , body = TextBody + ( RecordPair + { fst = VarBind + , snd = Name + { qualifiedModule = Nothing + , baseName = "x" + } + } + ) + , childTrees = [] + , rightChild = Nothing + } + } + ) } \ No newline at end of file diff --git a/primer-api/test/outputs/APITree/Type b/primer-api/test/outputs/APITree/Type index bf131c110..4f3e341a1 100644 --- a/primer-api/test/outputs/APITree/Type +++ b/primer-api/test/outputs/APITree/Type @@ -26,15 +26,7 @@ Tree { fst = FunOut , snd = Tree { nodeId = "2" - , body = TextBody - ( RecordPair - { fst = TForall - , snd = Name - { qualifiedModule = Nothing - , baseName = "a" - } - } - ) + , body = NoBody TForall , childTrees = [ RecordPair { fst = ForallKind @@ -122,7 +114,25 @@ Tree } } ] - , rightChild = Nothing + , rightChild = Just + ( RecordPair + { fst = Bind + , snd = Tree + { nodeId = "2V" + , body = TextBody + ( RecordPair + { fst = TVarBind + , snd = Name + { qualifiedModule = Nothing + , baseName = "a" + } + } + ) + , childTrees = [] + , rightChild = Nothing + } + } + ) } } ] diff --git a/primer-service/test/outputs/OpenAPI/openapi.json b/primer-service/test/outputs/OpenAPI/openapi.json index b91675ada..70364e4d9 100644 --- a/primer-service/test/outputs/OpenAPI/openapi.json +++ b/primer-service/test/outputs/OpenAPI/openapi.json @@ -131,7 +131,8 @@ "FunIn", "FunOut", "ForallKind", - "Forall" + "Forall", + "Bind" ], "type": "string" }, @@ -444,7 +445,14 @@ "PatternWildcard", "KType", "KHole", - "KFun" + "KFun", + "Lam", + "LAM", + "Let", + "LetType", + "Letrec", + "TLet", + "TForall" ], "type": "string" }, @@ -458,19 +466,13 @@ "NodeFlavorTextBody": { "enum": [ "Con", - "Lam", - "LAM", - "Let", - "LetType", - "Letrec", - "PatternBind", "PatternCon", "TCon", "TVar", - "TForall", - "TLet", "GlobalVar", - "LocalVar" + "LocalVar", + "VarBind", + "TVarBind" ], "type": "string" },