Skip to content

Commit a99eba8

Browse files
bladyjokerbladyjoker
committed
ProtoCompat.Types are using ordered-containers OMap
1 parent 3cf2e3a commit a99eba8

File tree

10 files changed

+75
-143
lines changed

10 files changed

+75
-143
lines changed

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

Lines changed: 2 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -96,17 +96,14 @@ library
9696
, containers >=0.6.5.1
9797
, data-default >=0.7
9898
, freer-simple >=1.2
99-
, generic-arbitrary
10099
, generic-lens >=2.2
101100
, generics-sop >=0.5
102101
, lambda-buffers-compiler-pb >=0.1.0.0
103102
, mtl >=2.2
104-
, ordered-containers
103+
, ordered-containers >=0.2
105104
, parsec >=3.1
106105
, prettyprinter >=1.7
107106
, proto-lens >=0.7
108-
, QuickCheck >=2.14
109-
, quickcheck-instances >=0.3
110107
, text >=1.2
111108

112109
exposed-modules:
@@ -161,12 +158,11 @@ test-suite tests
161158
, lambda-buffers-compiler
162159
, lambda-buffers-compiler-pb >=0.1
163160
, nonempty-containers >=0.3
161+
, ordered-containers >=0.2
164162
, proto-lens >=0.7
165-
, QuickCheck >=2.14
166163
, tasty >=1.4
167164
, tasty-hedgehog >=1.4
168165
, tasty-hunit >=0.10
169-
, tasty-quickcheck >=0.10
170166
, text >=1.2
171167

172168
other-modules:

‎lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Inference.hs‎

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ import Control.Monad.Freer.Writer (Writer, runWriter, tell)
2525
import Data.Bifunctor (Bifunctor (second))
2626
import Data.Foldable (foldrM)
2727
import Data.Map qualified as M
28+
import Data.Map.Ordered qualified as OMap
2829
import Data.Text qualified as T
2930
import LambdaBuffers.Compiler.KindCheck.Derivation (
3031
Context (Context),
@@ -139,16 +140,15 @@ derive x = deriveTyAbs x
139140

140141
deriveTyAbs :: PC.TyAbs -> Derive Derivation
141142
deriveTyAbs tyabs = do
142-
case M.toList (tyabs ^. #tyArgs) of
143+
case OMap.assocs (tyabs ^. #tyArgs) of
143144
[] -> deriveTyBody (x ^. #tyBody)
144145
a@(_, ar) : as -> do
145146
let argK = protoKind2Kind (ar ^. #argKind)
146147
bodyK <- KVar <$> fresh
147148
ctx <- ask
148-
149149
let newContext = ctx & addContext %~ (<> M.singleton (mkInfoLess (TyVar (ar ^. #argName))) argK)
150-
let newAbs = tyabs & #tyArgs .~ uncurry M.singleton a
151-
let restAbs = tyabs & #tyArgs .~ M.fromList as
150+
newAbs = tyabs & #tyArgs .~ OMap.singleton a
151+
restAbs = tyabs & #tyArgs .~ OMap.fromList as
152152

153153
restF <- local (const newContext) $ deriveTyAbs restAbs
154154

@@ -165,11 +165,11 @@ derive x = deriveTyAbs x
165165

166166
deriveSum :: PC.Sum -> Derive Derivation
167167
deriveSum s = do
168-
case M.toList (s ^. #constructors) of
168+
case OMap.assocs (s ^. #constructors) of
169169
[] -> voidDerivation
170170
c : cs -> do
171171
dc <- deriveConstructor $ snd c
172-
restDc <- deriveSum $ s & #constructors .~ M.fromList cs
172+
restDc <- deriveSum $ s & #constructors .~ OMap.fromList cs
173173
sumDerivation dc restDc
174174

175175
deriveConstructor :: PC.Constructor -> Derive Derivation
@@ -186,11 +186,11 @@ derive x = deriveTyAbs x
186186

187187
deriveRecord :: PC.Record -> Derive Derivation
188188
deriveRecord r = do
189-
case M.toList (r ^. #fields) of
189+
case OMap.assocs (r ^. #fields) of
190190
[] -> unitDerivation
191191
f : fs -> do
192192
d1 <- deriveField $ snd f
193-
d2 <- deriveRecord $ r & #fields .~ M.fromList fs
193+
d2 <- deriveRecord $ r & #fields .~ OMap.fromList fs
194194
productDerivation d1 d2
195195

196196
deriveField :: PC.Field -> Derive Derivation

‎lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Kind.hs‎

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,6 @@ module LambdaBuffers.Compiler.KindCheck.Kind (Kind (KType, (:->:), KVar), kind2P
33
import GHC.Generics (Generic)
44
import LambdaBuffers.Compiler.ProtoCompat.Types qualified as PC
55
import Prettyprinter (Pretty (pretty), parens, (<+>))
6-
import Test.QuickCheck.Arbitrary.Generic (Arbitrary, GenericArbitrary (GenericArbitrary))
76

87
infixr 8 :->:
98

@@ -14,7 +13,6 @@ data Kind
1413
| Kind :->: Kind
1514
| KVar Atom
1615
deriving stock (Eq, Show, Generic)
17-
deriving (Arbitrary) via GenericArbitrary Kind
1816

1917
instance Pretty Kind where
2018
pretty = \case

‎lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Type.hs‎

Lines changed: 0 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -12,8 +12,6 @@ import Generics.SOP qualified as SOP
1212
import LambdaBuffers.Compiler.ProtoCompat.InfoLess (InfoLess, InfoLessC, withInfoLess)
1313
import LambdaBuffers.Compiler.ProtoCompat.Types qualified as PC
1414
import Prettyprinter (Pretty (pretty), viaShow)
15-
import Test.QuickCheck (Arbitrary)
16-
import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary (GenericArbitrary))
1715

1816
-- NOTE(cstml): Let's remove the Arbitrary instances and replaces them with
1917
-- Gens.
@@ -24,7 +22,6 @@ data Variable
2422
QualifiedTyRef PC.ForeignRef
2523
| TyVar PC.VarName
2624
deriving stock (Eq, Ord, Show, Generic)
27-
deriving (Arbitrary) via GenericArbitrary Variable
2825
deriving anyclass (SOP.Generic)
2926

3027
instance Pretty Variable where

‎lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/FromProto.hs‎

Lines changed: 17 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,8 @@ import Data.Foldable (foldlM, toList)
1010
import Data.Kind (Type)
1111
import Data.Map (Map)
1212
import Data.Map qualified as Map
13+
import Data.Map.Ordered (OMap)
14+
import Data.Map.Ordered qualified as OMap
1315
import Data.ProtoLens (Message (messageName), MessageEnum (showEnum), defMessage)
1416
import Data.Proxy (Proxy (Proxy))
1517
import Data.Text (Text)
@@ -86,6 +88,18 @@ parseAndIndex key =
8688
)
8789
(mempty, mempty)
8890

91+
parseAndIndex' :: forall {t :: Type -> Type} {proto} {a} {k}. (Foldable t, IsMessage proto a, Ord k) => (a -> k) -> t proto -> FromProto (OMap k a, Map k [proto])
92+
parseAndIndex' key =
93+
foldlM
94+
( \(indexed, multiples) px -> do
95+
x <- fromProto px
96+
let k = key x
97+
if OMap.member k indexed
98+
then return (indexed, Map.insertWith (++) k [px] multiples)
99+
else return (OMap.alter (const (Just x)) k indexed, multiples)
100+
)
101+
(OMap.empty, mempty)
102+
89103
{-
90104
SourceInfo
91105
-}
@@ -292,7 +306,7 @@ instance IsMessage P.TyDef PC.TyDef where
292306

293307
instance IsMessage P.TyAbs PC.TyAbs where
294308
fromProto ta = do
295-
(tyargs, mulTyArgs) <- parseAndIndex (\a -> mkInfoLess $ a ^. #argName) (ta ^. P.tyArgs)
309+
(tyargs, mulTyArgs) <- parseAndIndex' (\a -> mkInfoLess $ a ^. #argName) (ta ^. P.tyArgs)
296310
tybody <- fromProto $ ta ^. P.tyBody
297311
si <- fromProto $ ta ^. P.sourceInfo
298312
ctx <- ask
@@ -381,7 +395,7 @@ instance IsMessage P.TyBody PC.TyBody where
381395

382396
instance IsMessage P.Sum PC.Sum where
383397
fromProto s = do
384-
(ctors, mulCtors) <- parseAndIndex (\c -> mkInfoLess $ c ^. #constrName) (s ^. P.constructors)
398+
(ctors, mulCtors) <- parseAndIndex' (\c -> mkInfoLess $ c ^. #constrName) (s ^. P.constructors)
385399
si <- fromProto $ s ^. P.sourceInfo
386400
ctx <- ask
387401
(ctxMn, ctxTyd) <- case ctx of
@@ -417,7 +431,7 @@ instance IsMessage P.Sum'Constructor PC.Constructor where
417431

418432
instance IsMessage P.Product'Record PC.Record where
419433
fromProto r = do
420-
(fields, mulFields) <- parseAndIndex (\f -> mkInfoLess $ f ^. #fieldName) (r ^. P.fields)
434+
(fields, mulFields) <- parseAndIndex' (\f -> mkInfoLess $ f ^. #fieldName) (r ^. P.fields)
421435
si <- fromProto $ r ^. P.sourceInfo
422436
ctx <- ask
423437
(ctxMn, ctxTyd) <- case ctx of

‎lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/InfoLess.hs‎

Lines changed: 9 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,5 @@
11
{-# LANGUAGE DefaultSignatures #-}
22
{-# LANGUAGE UndecidableInstances #-}
3-
{-# OPTIONS_GHC -Wno-orphans #-}
43

54
module LambdaBuffers.Compiler.ProtoCompat.InfoLess (
65
InfoLess,
@@ -10,18 +9,17 @@ module LambdaBuffers.Compiler.ProtoCompat.InfoLess (
109
InfoLessC (infoLessId),
1110
) where
1211

13-
import Data.Bifunctor (Bifunctor (bimap))
14-
import Data.Map qualified as M
12+
import Data.Map (Map)
13+
import Data.Map.Ordered (OMap)
14+
import Data.Set (Set)
1515
import Data.Set qualified as S
1616
import Data.Text (Text)
1717
import Generics.SOP (All2, Generic (Code, from, to), Proxy (Proxy), hcmap, mapII)
18-
import Test.QuickCheck (Arbitrary)
1918

2019
-- | InfoLess newtype. Constructor is not exported to not allow the construction of types with the Info. InfoLess a can only be constructed via its class instance and deconstructed using the exported function.
2120
newtype InfoLess a = InfoLess {unsafeInfoLess :: a}
2221
deriving stock (Show, Eq, Ord)
2322
deriving stock (Functor, Traversable, Foldable)
24-
deriving newtype (Arbitrary, InfoLessC)
2523

2624
{- | SourceInfo Less ID.
2725
A TypeClass that provides id for types with SourceInfo - where SI is defaulted - therefore ignored. Can only be derived.
@@ -55,8 +53,11 @@ instance InfoLessC Int where
5553
instance InfoLessC Text where
5654
infoLessId = id
5755

58-
instance (Ord k, InfoLessC k, InfoLessC v) => InfoLessC (M.Map k v) where
59-
infoLessId = M.fromList . fmap (bimap infoLessId infoLessId) . M.toList
56+
instance (Ord k, InfoLessC v) => InfoLessC (Map k v) where
57+
infoLessId m = infoLessId <$> m
6058

61-
instance (Ord a, InfoLessC a) => InfoLessC (S.Set a) where
59+
instance (Ord a, InfoLessC a) => InfoLessC (Set a) where
6260
infoLessId = S.fromList . fmap infoLessId . S.toList
61+
62+
instance (Ord k, InfoLessC v) => InfoLessC (OMap k v) where
63+
infoLessId om = infoLessId <$> om

0 commit comments

Comments
 (0)