Skip to content

Commit c989c09

Browse files
bladyjokerbladyjoker
committed
Filtering classes feature tested and moved to the compiler lib
1 parent 83ab891 commit c989c09

File tree

4 files changed

+140
-36
lines changed

4 files changed

+140
-36
lines changed

‎lambda-buffers-codegen/app/LambdaBuffers/Codegen/Cli/Gen.hs‎

Lines changed: 2 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -101,7 +101,7 @@ filterToRequestedClasses reqCls ci =
101101
let
102102
ciClassRels = PC.indexClassRelations ci
103103
ciQClassNames = Map.keysSet ciClassRels
104-
requestedClasses' = classClosure ciClassRels reqCls
104+
requestedClasses' = PC.classClosure ciClassRels reqCls
105105
in
106106
do
107107
logInfo $ "Computed class closure: " <> unwords (Text.unpack . Config.qClassNameToText <$> toList reqCls)
@@ -115,28 +115,7 @@ filterToRequestedClasses reqCls ci =
115115
<> "\nClasses missing: "
116116
<> unwords (Text.unpack . Config.qClassNameToText <$> toList (reqCls `Set.difference` ciQClassNames))
117117
exitFailure
118-
return $ ci & #modules .~ (filterClassInModule requestedClasses' <$> ci ^. #modules)
119-
where
120-
classClosure :: PC.ClassRels -> Set PC.QClassName -> Set PC.QClassName
121-
classClosure classRels cls =
122-
let classRels' = Map.filterWithKey (\k _x -> k `Set.member` cls) classRels
123-
cls' = cls <> (Set.fromList . mconcat . Map.elems $ classRels')
124-
in if cls == cls'
125-
then cls
126-
else classClosure classRels cls'
127-
filterClassInModule :: Set PC.QClassName -> PC.Module -> PC.Module
128-
filterClassInModule cls m =
129-
m
130-
{ PC.classDefs = Map.filterWithKey (\_clName clDef -> PC.qualifyClassName (m ^. #moduleName) (clDef ^. #className) `Set.member` cls) (m ^. #classDefs)
131-
, PC.instances = [i | i <- m ^. #instances, filterInstance cls m i]
132-
, PC.derives = [d | d <- m ^. #derives, filterDerive cls m d]
133-
}
134-
filterInstance :: Set PC.QClassName -> PC.Module -> PC.InstanceClause -> Bool
135-
filterInstance cls m inst = filterConstraint cls m (inst ^. #head)
136-
filterDerive :: Set PC.QClassName -> PC.Module -> PC.Derive -> Bool
137-
filterDerive cls m drv = filterConstraint cls m (drv ^. #constraint)
138-
filterConstraint :: Set PC.QClassName -> PC.Module -> PC.Constraint -> Bool
139-
filterConstraint cls m cnstr = PC.qualifyClassRef (m ^. #moduleName) (cnstr ^. #classRef) `Set.member` cls
118+
return $ ci & #modules .~ (PC.filterClassInModule requestedClasses' <$> ci ^. #modules)
140119

141120
filterToRequestedModules :: GenOpts -> Map (PC.InfoLess PC.ModuleName) (Either P.Error Generated) -> IO (Map (PC.InfoLess PC.ModuleName) (Either P.Error Generated))
142121
filterToRequestedModules opts res = do

‎lambda-buffers-compiler/src/LambdaBuffers/ProtoCompat/Utils.hs‎

Lines changed: 10 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
{-# OPTIONS_GHC -Wno-orphans #-}
22
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
33

4-
module LambdaBuffers.ProtoCompat.Utils (prettyModuleName, prettyModuleName', localRef2ForeignRef, filterClassInModule, classClosure) where
4+
module LambdaBuffers.ProtoCompat.Utils (prettyModuleName, prettyModuleName', localRef2ForeignRef, classClosure, filterClassInModule) where
55

66
import Control.Lens (Getter, to, view, (&), (.~), (^.))
77
import Data.Map qualified as Map
@@ -59,6 +59,8 @@ instance Semigroup Codegen.Error where
5959
& Codegen.unsupportedOpaqueErrors .~ l ^. Codegen.unsupportedOpaqueErrors <> r ^. Codegen.unsupportedOpaqueErrors
6060
& Codegen.unsupportedClassErrors .~ l ^. Codegen.unsupportedClassErrors <> r ^. Codegen.unsupportedClassErrors
6161

62+
-- | Class closure is used by lbg when restricting implementation printing to some user specified classes. The users are able to specify which classes should be printed, for example: print Eq but don't print Json. This is particularly useful when some backends don't support a certain type class.
63+
6264
-- | `classClosure classRels initialClasses` computes the full class closure reachable from `initialClasses`.
6365
classClosure :: PC.ClassRels -> Set PC.QClassName -> Set PC.QClassName
6466
classClosure classRels cls =
@@ -71,13 +73,19 @@ classClosure classRels cls =
7173
filterClassInModule :: Set PC.QClassName -> PC.Module -> PC.Module
7274
filterClassInModule cls m =
7375
m
74-
{ PC.classDefs = Map.filterWithKey (\_clName clDef -> PC.qualifyClassName (m ^. #moduleName) (clDef ^. #className) `Set.member` cls) (m ^. #classDefs)
76+
{ PC.classDefs = Map.filter (filterClassDef cls m) (m ^. #classDefs)
7577
, PC.instances = [i | i <- m ^. #instances, filterInstance cls m i]
7678
, PC.derives = [d | d <- m ^. #derives, filterDerive cls m d]
7779
}
80+
81+
filterClassDef :: Set PC.QClassName -> PC.Module -> PC.ClassDef -> Bool
82+
filterClassDef cls m clDef = PC.qualifyClassName (m ^. #moduleName) (clDef ^. #className) `Set.member` cls
83+
7884
filterInstance :: Set PC.QClassName -> PC.Module -> PC.InstanceClause -> Bool
7985
filterInstance cls m inst = filterConstraint cls m (inst ^. #head)
86+
8087
filterDerive :: Set PC.QClassName -> PC.Module -> PC.Derive -> Bool
8188
filterDerive cls m drv = filterConstraint cls m (drv ^. #constraint)
89+
8290
filterConstraint :: Set PC.QClassName -> PC.Module -> PC.Constraint -> Bool
8391
filterConstraint cls m cnstr = PC.qualifyClassRef (m ^. #moduleName) (cnstr ^. #classRef) `Set.member` cls

‎lambda-buffers-compiler/test/Test/LambdaBuffers/Compiler/ClassClosure.hs‎

Lines changed: 100 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -4,22 +4,23 @@ module Test.LambdaBuffers.Compiler.ClassClosure (
44

55
import Control.Lens ((^.))
66
import Data.Foldable (Foldable (toList))
7-
import Data.Map qualified as Map
87
import Data.Set qualified as Set
98
import Data.Text (Text)
109
import LambdaBuffers.ProtoCompat qualified as PC
1110
import Test.LambdaBuffers.ProtoCompat.Utils qualified as U
1211
import Test.Tasty (TestName, TestTree, testGroup)
1312
import Test.Tasty.HUnit (testCase, (@?=))
14-
import Prelude (Monoid (mconcat), Show (show), zip, ($), (.), (<$>), (<>))
13+
import Prelude (Show (show), zip, ($), (.), (<$>))
1514

1615
tests :: TestTree
1716
tests =
1817
testGroup
1918
"LambdaBuffers.Compiler.ClassClosure checks"
2019
[ testGroup
2120
"All classes in closure and related rules should be removed"
22-
[ classClosureTest "test1" [(["Prelude"], "Ord")] [(["Prelude"], "Eq"), (["Prelude"], "Ord")] test1
21+
[ classClosureTest "Restrict to only Eq" [(["Prelude"], "Eq")] [(["Prelude"], "Eq")] testEq
22+
, classClosureTest "Restrict to only Ord" [(["Prelude"], "Ord")] [(["Prelude"], "Eq"), (["Prelude"], "Ord")] testOrd
23+
, classClosureTest "No class only ty defs" [] [] testNoClass
2324
]
2425
]
2526

@@ -37,17 +38,17 @@ classClosureTest title cls clsWant (ciIn, ciWant) =
3738
title
3839
$ testCase "Class closure should be" (cls'' @?= clsWant'')
3940
: ( [ testGroup
40-
(PC.prettyModuleName (mGot' ^. #moduleName))
41-
[ testCase "Class definitions should match" $ (mGot' ^. #classDefs) @?= (mWant ^. #classDefs)
42-
, testCase "Instances should match" $ (mGot' ^. #instances) @?= (mWant ^. #instances)
43-
, testCase "Derives should match" $ (mGot' ^. #derives) @?= (mWant ^. #derives)
41+
(show $ PC.prettyModuleName (mGot ^. #moduleName))
42+
[ testCase "Class definitions should match" $ (mGot ^. #classDefs) @?= (mWant ^. #classDefs)
43+
, testCase "Instances should match" $ (mGot ^. #instances) @?= (mWant ^. #instances)
44+
, testCase "Derives should match" $ (mGot ^. #derives) @?= (mWant ^. #derives)
4445
]
45-
| (mWant, mGot') <- zip (toList $ ciWant ^. #modules) (toList $ ciGot ^. #modules)
46+
| (mWant, mGot) <- zip (toList $ ciWant ^. #modules) (toList $ ciGot ^. #modules)
4647
]
4748
)
4849

49-
test1 :: (PC.CompilerInput, PC.CompilerInput)
50-
test1 =
50+
testNoClass :: (PC.CompilerInput, PC.CompilerInput)
51+
testNoClass =
5152
( U.ci
5253
[ U.mod'preludeO
5354
, U.mod'
@@ -70,7 +71,51 @@ test1 =
7071
[["Prelude"]]
7172
]
7273
, U.ci
73-
[ U.mod'preludeO {PC.classDefs = Map.empty, PC.instances = []}
74+
[ U.mod'prelude'noclass
75+
, U.mod'
76+
["Foo"]
77+
[ U.td
78+
"Foo"
79+
( U.abs ["a", "b", "c"] $
80+
U.sum
81+
[ ("MkFoo", [U.fr ["Prelude"] "Either" U.@ [U.fr ["Prelude"] "Int8", U.tv "a"]])
82+
, ("MkBar", [U.fr ["Prelude"] "Maybe" U.@ [U.tv "b"], U.fr ["Prelude"] "List" U.@ [U.tv "b"]])
83+
, ("MkBaz", [U.fr ["Prelude"] "Map" U.@ [U.tv "b", U.tv "c"]])
84+
]
85+
)
86+
]
87+
[]
88+
[]
89+
[]
90+
[["Prelude"]]
91+
]
92+
)
93+
94+
testEq :: (PC.CompilerInput, PC.CompilerInput)
95+
testEq =
96+
( U.ci
97+
[ U.mod'preludeO
98+
, U.mod'
99+
["Foo"]
100+
[ U.td
101+
"Foo"
102+
( U.abs ["a", "b", "c"] $
103+
U.sum
104+
[ ("MkFoo", [U.fr ["Prelude"] "Either" U.@ [U.fr ["Prelude"] "Int8", U.tv "a"]])
105+
, ("MkBar", [U.fr ["Prelude"] "Maybe" U.@ [U.tv "b"], U.fr ["Prelude"] "List" U.@ [U.tv "b"]])
106+
, ("MkBaz", [U.fr ["Prelude"] "Map" U.@ [U.tv "b", U.tv "c"]])
107+
]
108+
)
109+
]
110+
[]
111+
[]
112+
[ deriveEq (U.lr "Foo" U.@ [U.tv "a", U.tv "b", U.tv "c"])
113+
, deriveOrd (U.lr "Foo" U.@ [U.tv "a", U.tv "b", U.tv "c"])
114+
]
115+
[["Prelude"]]
116+
]
117+
, U.ci
118+
[ U.mod'prelude'only'eq
74119
, U.mod'
75120
["Foo"]
76121
[ U.td
@@ -90,6 +135,50 @@ test1 =
90135
]
91136
)
92137

138+
testOrd :: (PC.CompilerInput, PC.CompilerInput)
139+
testOrd =
140+
( U.ci
141+
[ U.mod'preludeO
142+
, U.mod'
143+
["Foo"]
144+
[ U.td
145+
"Foo"
146+
( U.abs ["a", "b", "c"] $
147+
U.sum
148+
[ ("MkFoo", [U.fr ["Prelude"] "Either" U.@ [U.fr ["Prelude"] "Int8", U.tv "a"]])
149+
, ("MkBar", [U.fr ["Prelude"] "Maybe" U.@ [U.tv "b"], U.fr ["Prelude"] "List" U.@ [U.tv "b"]])
150+
, ("MkBaz", [U.fr ["Prelude"] "Map" U.@ [U.tv "b", U.tv "c"]])
151+
]
152+
)
153+
]
154+
[]
155+
[]
156+
[ deriveEq (U.lr "Foo" U.@ [U.tv "a", U.tv "b", U.tv "c"])
157+
, deriveOrd (U.lr "Foo" U.@ [U.tv "a", U.tv "b", U.tv "c"])
158+
]
159+
[["Prelude"]]
160+
]
161+
, U.ci
162+
[ U.mod'preludeO
163+
, U.mod'
164+
["Foo"]
165+
[ U.td
166+
"Foo"
167+
( U.abs ["a", "b", "c"] $
168+
U.sum
169+
[ ("MkFoo", [U.fr ["Prelude"] "Either" U.@ [U.fr ["Prelude"] "Int8", U.tv "a"]])
170+
, ("MkBar", [U.fr ["Prelude"] "Maybe" U.@ [U.tv "b"], U.fr ["Prelude"] "List" U.@ [U.tv "b"]])
171+
, ("MkBaz", [U.fr ["Prelude"] "Map" U.@ [U.tv "b", U.tv "c"]])
172+
]
173+
)
174+
]
175+
[]
176+
[]
177+
[deriveEq (U.lr "Foo" U.@ [U.tv "a", U.tv "b", U.tv "c"]), deriveOrd (U.lr "Foo" U.@ [U.tv "a", U.tv "b", U.tv "c"])]
178+
[["Prelude"]]
179+
]
180+
)
181+
93182
deriveEq :: PC.Ty -> PC.Derive
94183
deriveEq = U.drv . eqCstr
95184

‎lambda-buffers-compiler/test/Test/LambdaBuffers/ProtoCompat/Utils.hs‎

Lines changed: 28 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,8 @@ module Test.LambdaBuffers.ProtoCompat.Utils (
2727
recrd,
2828
prod',
2929
qcln',
30+
mod'prelude'only'eq,
31+
mod'prelude'noclass,
3032
) where
3133

3234
import Control.Lens ((^.))
@@ -287,3 +289,29 @@ mod'prelude =
287289
, derive'ord'list
288290
]
289291
[]
292+
293+
mod'prelude'only'eq :: PC.Module
294+
mod'prelude'only'eq =
295+
mod'
296+
["Prelude"]
297+
[td'eitherO, td'maybeO, td'int8, td'bytes, td'mapO, td'listO]
298+
[cd'eq]
299+
[ inst'eq'int8
300+
, inst'eq'bytes
301+
, inst'eq'maybeO
302+
, inst'eq'eitherO
303+
, inst'eq'mapO
304+
, inst'eq'listO
305+
]
306+
[]
307+
[]
308+
309+
mod'prelude'noclass :: PC.Module
310+
mod'prelude'noclass =
311+
mod'
312+
["Prelude"]
313+
[td'eitherO, td'maybeO, td'int8, td'bytes, td'mapO, td'listO]
314+
[]
315+
[]
316+
[]
317+
[]

0 commit comments

Comments
 (0)