Skip to content

Commit 83ab891

Browse files
bladyjokerbladyjoker
committed
WIP save
1 parent 05f6b44 commit 83ab891

File tree

5 files changed

+138
-1
lines changed

5 files changed

+138
-1
lines changed

‎lambda-buffers-compiler/lambda-buffers-compiler.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -193,6 +193,7 @@ test-suite tests
193193
Test.KindCheck
194194
Test.KindCheck.Errors
195195
Test.LambdaBuffers.Compiler
196+
Test.LambdaBuffers.Compiler.ClassClosure
196197
Test.LambdaBuffers.Compiler.Coverage
197198
Test.LambdaBuffers.Compiler.LamTy
198199
Test.LambdaBuffers.Compiler.MiniLog

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

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

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

66
import Control.Lens (Getter, to, view, (&), (.~), (^.))
7+
import Data.Map qualified as Map
78
import Data.ProtoLens (Message (defMessage))
9+
import Data.Set (Set)
10+
import Data.Set qualified as Set
11+
import LambdaBuffers.ProtoCompat.Indexing qualified as PC
812
import LambdaBuffers.ProtoCompat.IsCompat.FromProto qualified as PC
913
import LambdaBuffers.ProtoCompat.IsCompat.Lang ()
1014
import LambdaBuffers.ProtoCompat.Types qualified as PC
@@ -54,3 +58,26 @@ instance Semigroup Codegen.Error where
5458
& Codegen.internalErrors .~ l ^. Codegen.internalErrors <> r ^. Codegen.internalErrors
5559
& Codegen.unsupportedOpaqueErrors .~ l ^. Codegen.unsupportedOpaqueErrors <> r ^. Codegen.unsupportedOpaqueErrors
5660
& Codegen.unsupportedClassErrors .~ l ^. Codegen.unsupportedClassErrors <> r ^. Codegen.unsupportedClassErrors
61+
62+
-- | `classClosure classRels initialClasses` computes the full class closure reachable from `initialClasses`.
63+
classClosure :: PC.ClassRels -> Set PC.QClassName -> Set PC.QClassName
64+
classClosure classRels cls =
65+
let classRels' = Map.filterWithKey (\k _x -> k `Set.member` cls) classRels
66+
cls' = cls <> (Set.fromList . mconcat . Map.elems $ classRels')
67+
in if cls == cls'
68+
then cls
69+
else classClosure classRels cls'
70+
71+
filterClassInModule :: Set PC.QClassName -> PC.Module -> PC.Module
72+
filterClassInModule cls m =
73+
m
74+
{ PC.classDefs = Map.filterWithKey (\_clName clDef -> PC.qualifyClassName (m ^. #moduleName) (clDef ^. #className) `Set.member` cls) (m ^. #classDefs)
75+
, PC.instances = [i | i <- m ^. #instances, filterInstance cls m i]
76+
, PC.derives = [d | d <- m ^. #derives, filterDerive cls m d]
77+
}
78+
filterInstance :: Set PC.QClassName -> PC.Module -> PC.InstanceClause -> Bool
79+
filterInstance cls m inst = filterConstraint cls m (inst ^. #head)
80+
filterDerive :: Set PC.QClassName -> PC.Module -> PC.Derive -> Bool
81+
filterDerive cls m drv = filterConstraint cls m (drv ^. #constraint)
82+
filterConstraint :: Set PC.QClassName -> PC.Module -> PC.Constraint -> Bool
83+
filterConstraint cls m cnstr = PC.qualifyClassRef (m ^. #moduleName) (cnstr ^. #classRef) `Set.member` cls

‎lambda-buffers-compiler/test/Test.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@ module Main (main) where
33
import Test.DeriveCheck qualified as DC
44
import Test.KindCheck qualified as KC
55
import Test.LambdaBuffers.Compiler qualified as LBC
6+
import Test.LambdaBuffers.Compiler.ClassClosure qualified as ClassClosure
67
import Test.LambdaBuffers.Compiler.LamTy qualified as LT
78
import Test.LambdaBuffers.Compiler.MiniLog qualified as ML
89
import Test.LambdaBuffers.Compiler.TypeClassCheck qualified as TC
@@ -19,4 +20,5 @@ main =
1920
, LT.test
2021
, ML.test
2122
, TC.test
23+
, ClassClosure.tests
2224
]

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

Lines changed: 103 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,103 @@
1+
module Test.LambdaBuffers.Compiler.ClassClosure (
2+
tests,
3+
) where
4+
5+
import Control.Lens ((^.))
6+
import Data.Foldable (Foldable (toList))
7+
import Data.Map qualified as Map
8+
import Data.Set qualified as Set
9+
import Data.Text (Text)
10+
import LambdaBuffers.ProtoCompat qualified as PC
11+
import Test.LambdaBuffers.ProtoCompat.Utils qualified as U
12+
import Test.Tasty (TestName, TestTree, testGroup)
13+
import Test.Tasty.HUnit (testCase, (@?=))
14+
import Prelude (Monoid (mconcat), Show (show), zip, ($), (.), (<$>), (<>))
15+
16+
tests :: TestTree
17+
tests =
18+
testGroup
19+
"LambdaBuffers.Compiler.ClassClosure checks"
20+
[ testGroup
21+
"All classes in closure and related rules should be removed"
22+
[ classClosureTest "test1" [(["Prelude"], "Ord")] [(["Prelude"], "Eq"), (["Prelude"], "Ord")] test1
23+
]
24+
]
25+
26+
classClosureTest :: TestName -> [([Text], Text)] -> [([Text], Text)] -> (PC.CompilerInput, PC.CompilerInput) -> TestTree
27+
classClosureTest title cls clsWant (ciIn, ciWant) =
28+
let
29+
classRels = PC.indexClassRelations ciIn
30+
cls' = Set.fromList [U.qcln' (U.mn mn) clN | (mn, clN) <- cls]
31+
clsWant' = Set.fromList [U.qcln' (U.mn mn) clN | (mn, clN) <- clsWant]
32+
cls'' = PC.classClosure classRels cls'
33+
clsWant'' = PC.classClosure classRels clsWant'
34+
ciGot = PC.CompilerInput $ PC.filterClassInModule cls'' <$> ciIn ^. #modules
35+
in
36+
testGroup
37+
title
38+
$ testCase "Class closure should be" (cls'' @?= clsWant'')
39+
: ( [ 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)
44+
]
45+
| (mWant, mGot') <- zip (toList $ ciWant ^. #modules) (toList $ ciGot ^. #modules)
46+
]
47+
)
48+
49+
test1 :: (PC.CompilerInput, PC.CompilerInput)
50+
test1 =
51+
( U.ci
52+
[ U.mod'preludeO
53+
, U.mod'
54+
["Foo"]
55+
[ U.td
56+
"Foo"
57+
( U.abs ["a", "b", "c"] $
58+
U.sum
59+
[ ("MkFoo", [U.fr ["Prelude"] "Either" U.@ [U.fr ["Prelude"] "Int8", U.tv "a"]])
60+
, ("MkBar", [U.fr ["Prelude"] "Maybe" U.@ [U.tv "b"], U.fr ["Prelude"] "List" U.@ [U.tv "b"]])
61+
, ("MkBaz", [U.fr ["Prelude"] "Map" U.@ [U.tv "b", U.tv "c"]])
62+
]
63+
)
64+
]
65+
[]
66+
[]
67+
[ deriveEq (U.lr "Foo" U.@ [U.tv "a", U.tv "b", U.tv "c"])
68+
, deriveOrd (U.lr "Foo" U.@ [U.tv "a", U.tv "b", U.tv "c"])
69+
]
70+
[["Prelude"]]
71+
]
72+
, U.ci
73+
[ U.mod'preludeO {PC.classDefs = Map.empty, PC.instances = []}
74+
, U.mod'
75+
["Foo"]
76+
[ U.td
77+
"Foo"
78+
( U.abs ["a", "b", "c"] $
79+
U.sum
80+
[ ("MkFoo", [U.fr ["Prelude"] "Either" U.@ [U.fr ["Prelude"] "Int8", U.tv "a"]])
81+
, ("MkBar", [U.fr ["Prelude"] "Maybe" U.@ [U.tv "b"], U.fr ["Prelude"] "List" U.@ [U.tv "b"]])
82+
, ("MkBaz", [U.fr ["Prelude"] "Map" U.@ [U.tv "b", U.tv "c"]])
83+
]
84+
)
85+
]
86+
[]
87+
[]
88+
[deriveEq (U.lr "Foo" U.@ [U.tv "a", U.tv "b", U.tv "c"])]
89+
[["Prelude"]]
90+
]
91+
)
92+
93+
deriveEq :: PC.Ty -> PC.Derive
94+
deriveEq = U.drv . eqCstr
95+
96+
eqCstr :: PC.Ty -> PC.Constraint
97+
eqCstr = U.cstr (U.fcr ["Prelude"] "Eq")
98+
99+
deriveOrd :: PC.Ty -> PC.Derive
100+
deriveOrd = U.drv . ordCstr
101+
102+
ordCstr :: PC.Ty -> PC.Constraint
103+
ordCstr = U.cstr (U.fcr ["Prelude"] "Ord")

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

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ module Test.LambdaBuffers.ProtoCompat.Utils (
2626
inst',
2727
recrd,
2828
prod',
29+
qcln',
2930
) where
3031

3132
import Control.Lens ((^.))
@@ -84,6 +85,9 @@ vn n = PC.VarName n def
8485
cln :: Text -> PC.ClassName
8586
cln n = PC.ClassName n def
8687

88+
qcln' :: PC.ModuleName -> Text -> PC.QClassName
89+
qcln' mn' n = (PC.mkInfoLess mn', PC.mkInfoLess $ PC.ClassName n def)
90+
8791
abs :: [Text] -> PC.TyBody -> PC.TyAbs
8892
abs args body = PC.TyAbs (OMap.fromList . fmap arg $ args) body def
8993
where

0 commit comments

Comments
 (0)