Skip to content

Commit d7381a3

Browse files
cstmlcstml
committed
Merge remote-tracking branch 'origin/main' into compiler/multiple-declaration-error
2 parents cf654b9 + 419f3a9 commit d7381a3

File tree

17 files changed

+444
-89
lines changed

17 files changed

+444
-89
lines changed

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

Lines changed: 9 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -103,6 +103,7 @@ library
103103
, prettyprinter >=1.7
104104
, proto-lens >=0.7
105105
, QuickCheck >=2.14
106+
, quickcheck-instances >=0.3
106107
, text >=1.2
107108

108109
exposed-modules:
@@ -117,8 +118,10 @@ library
117118
LambdaBuffers.Compiler.NamingCheck
118119
LambdaBuffers.Compiler.ProtoCompat
119120
LambdaBuffers.Compiler.ProtoCompat.Types
121+
LambdaBuffers.Compiler.TypeClass.Pat
122+
LambdaBuffers.Compiler.TypeClass.Pretty
123+
LambdaBuffers.Compiler.TypeClass.Rules
120124
LambdaBuffers.Compiler.TypeClassCheck
121-
Orphan.Text
122125

123126
hs-source-dirs: src
124127

@@ -156,9 +159,9 @@ test-suite tests
156159

157160
other-modules:
158161
Test.KindCheck
159-
Test.Samples.Proto.CompilerInput
160-
Test.Samples.Proto.Module
161-
Test.Samples.Proto.SourceInfo
162-
Test.Samples.Proto.TyDef
163-
Test.Samples.Proto.Utils
164162
Test.TypeClassCheck
163+
Test.Utils.CompilerInput
164+
Test.Utils.Constructors
165+
Test.Utils.Module
166+
Test.Utils.SourceInfo
167+
Test.Utils.TyDef

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,10 +2,10 @@ module LambdaBuffers.Compiler.KindCheck.Variable (Variable (LocalRef, ForeignRef
22

33
import Data.Text (Text)
44
import GHC.Generics (Generic)
5-
import Orphan.Text ()
65
import Prettyprinter (Pretty (pretty), concatWith)
76
import Test.QuickCheck (Arbitrary)
87
import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary (GenericArbitrary))
8+
import Test.QuickCheck.Instances.Text ()
99

1010
type Atom = Text
1111

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

Lines changed: 50 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -54,10 +54,10 @@ throwNamingError = either (Left . NamingError) return
5454

5555
-- TODO(bladyjoker): Revisit and make part of compiler.proto
5656
data ProtoError
57-
= MultipleInstanceHeads ClassName [Ty] SourceInfo
58-
| NoInstanceHead ClassName SourceInfo
59-
| NoConstraintArgs ClassName SourceInfo
60-
| MultipleConstraintArgs ClassName [Ty] SourceInfo
57+
= MultipleInstanceHeads TyClassRef [Ty] SourceInfo
58+
| NoInstanceHead TyClassRef SourceInfo
59+
| NoConstraintArgs TyClassRef SourceInfo
60+
| MultipleConstraintArgs TyClassRef [Ty] SourceInfo
6161
| NoClassArgs ClassName SourceInfo
6262
| MultipleClassArgs ClassName SourceInfo
6363
| NoTyAppArgs SourceInfo
@@ -387,6 +387,41 @@ instance IsMessage P.Product'Record'Field Field where
387387
Classes, instances, constraints
388388
-}
389389

390+
instance IsMessage P.TyClassRef'Local LocalClassRef where
391+
fromProto lr = do
392+
si <- fromProto $ lr ^. P.sourceInfo
393+
nm <- fromProto $ lr ^. P.className
394+
pure $ LocalClassRef nm si
395+
396+
toProto (LocalClassRef nm si) =
397+
defMessage
398+
& P.className .~ toProto nm
399+
& P.sourceInfo .~ toProto si
400+
401+
instance IsMessage P.TyClassRef'Foreign ForeignClassRef where
402+
fromProto fr = do
403+
si <- fromProto $ fr ^. P.sourceInfo
404+
mn <- fromProto $ fr ^. P.moduleName
405+
tn <- fromProto $ fr ^. P.className
406+
pure $ ForeignClassRef tn mn si
407+
408+
toProto (ForeignClassRef tn mn si) =
409+
defMessage
410+
& P.className .~ toProto tn
411+
& P.moduleName .~ toProto mn
412+
& P.sourceInfo .~ toProto si
413+
414+
instance IsMessage P.TyClassRef TyClassRef where
415+
fromProto tr = case tr ^. P.maybe'classRef of
416+
Nothing -> throwProtoError $ OneOfNotSet "class_ref"
417+
Just x -> case x of
418+
P.TyClassRef'LocalClassRef lr -> LocalCI <$> fromProto lr
419+
P.TyClassRef'ForeignClassRef f -> ForeignCI <$> fromProto f
420+
421+
toProto = \case
422+
LocalCI lr -> defMessage & P.localClassRef .~ toProto lr
423+
ForeignCI fr -> defMessage & P.foreignClassRef .~ toProto fr
424+
390425
instance IsMessage P.ClassDef ClassDef where
391426
fromProto cd = do
392427
si <- fromProto $ cd ^. P.sourceInfo
@@ -411,7 +446,7 @@ instance IsMessage P.ClassDef ClassDef where
411446
instance IsMessage P.InstanceClause InstanceClause where
412447
fromProto ic = do
413448
si <- fromProto $ ic ^. P.sourceInfo
414-
cnm <- fromProto $ ic ^. P.className
449+
cnm <- fromProto $ ic ^. P.classRef
415450
csts <- traverse fromProto $ ic ^. P.constraints
416451
hds <- ic ^. (P.heads . traversing fromProto)
417452
hd <- case hds of
@@ -422,15 +457,15 @@ instance IsMessage P.InstanceClause InstanceClause where
422457

423458
toProto (InstanceClause cnm hd csts si) =
424459
defMessage
425-
& P.className .~ toProto cnm
460+
& P.classRef .~ toProto cnm
426461
& P.heads .~ pure (toProto hd)
427462
& P.constraints .~ (toProto <$> csts)
428463
& P.sourceInfo .~ toProto si
429464

430465
instance IsMessage P.Constraint Constraint where
431466
fromProto c = do
432467
si <- fromProto $ c ^. P.sourceInfo
433-
cnm <- fromProto $ c ^. P.className
468+
cnm <- fromProto $ c ^. P.classRef
434469
args <- c ^. (P.arguments . traversing fromProto)
435470
arg <- case args of
436471
[] -> throwProtoError $ NoConstraintArgs cnm si
@@ -440,7 +475,7 @@ instance IsMessage P.Constraint Constraint where
440475

441476
toProto (Constraint cnm arg si) =
442477
defMessage
443-
& P.className .~ toProto cnm
478+
& P.classRef .~ toProto cnm
444479
& P.arguments .~ pure (toProto arg)
445480
& P.sourceInfo .~ toProto si
446481

@@ -454,15 +489,17 @@ instance IsMessage P.Module Module where
454489
tdefs <- traverse fromProto $ m ^. P.typeDefs
455490
cdefs <- traverse fromProto $ m ^. P.classDefs
456491
insts <- traverse fromProto $ m ^. P.instances
492+
impts <- traverse fromProto $ m ^. P.imports
457493
si <- fromProto $ m ^. P.sourceInfo
458-
pure $ Module mnm tdefs cdefs insts si
494+
pure $ Module mnm tdefs cdefs insts impts si
459495

460-
toProto (Module mnm tdefs cdefs insts si) =
496+
toProto (Module mnm tdefs cdefs insts impts si) =
461497
defMessage
462498
& P.moduleName .~ toProto mnm
463499
& P.typeDefs .~ (toProto <$> tdefs)
464500
& P.classDefs .~ (toProto <$> cdefs)
465501
& P.instances .~ (toProto <$> insts)
502+
& P.imports .~ (toProto <$> impts)
466503
& P.sourceInfo .~ toProto si
467504

468505
instance IsMessage P.CompilerInput CompilerInput where
@@ -529,7 +566,7 @@ instance IsMessage P.KindCheckError KindCheckError where
529566
<$> fromProto (err ^. P.tyName)
530567
<*> fromProto (err ^. P.inferredKind)
531568
<*> fromProto (err ^. P.definedKind)
532-
P.KindCheckError'MultipleTyDefError' err ->
569+
P.KindCheckError'MultipleTydefError err ->
533570
MultipleTyDefError
534571
<$> fromProto (err ^. P.declaration1)
535572
<*> fromProto (err ^. P.declaration2)
@@ -555,8 +592,8 @@ instance IsMessage P.KindCheckError KindCheckError where
555592
& (P.inconsistentTypeError . P.definedKind) .~ toProto kd
556593
MultipleTyDefError d1 d2 ->
557594
defMessage
558-
& (P.multipleTyDefError . P.declaration1) .~ toProto d1
559-
& (P.multipleTyDefError . P.declaration2) .~ toProto d2
595+
& (P.multipleTydefError . P.declaration1) .~ toProto d1
596+
& (P.multipleTydefError . P.declaration2) .~ toProto d2
560597

561598
instance IsMessage P.CompilerError CompilerError where
562599
fromProto cErr = case cErr ^. P.maybe'compilerError of

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

Lines changed: 30 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,10 @@
11
{-# LANGUAGE DuplicateRecordFields #-}
22
{-# OPTIONS_GHC -Wno-orphans #-}
33
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
4+
-- this is needed so the deriving via can generate Arbitrary instances for data
5+
-- definitions with more than 4 constructors
46
{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}
57

6-
{- | this is needed so the deriving via can generate Arbitrary instances for
7-
data definitions with more than 4 constructors
8-
-}
98
module LambdaBuffers.Compiler.ProtoCompat.Types (
109
ClassDef (..),
1110
ClassName (..),
@@ -19,13 +18,15 @@ module LambdaBuffers.Compiler.ProtoCompat.Types (
1918
Field (..),
2019
FieldName (..),
2120
ForeignRef (..),
21+
ForeignClassRef (..),
2222
InstanceClause (..),
2323
Kind (..),
2424
KindRefType (..),
2525
KindCheckError (..),
2626
KindType (..),
2727
LBName (..),
2828
LocalRef (..),
29+
LocalClassRef (..),
2930
Module (..),
3031
ModuleName (..),
3132
ModuleNamePart (..),
@@ -40,6 +41,7 @@ module LambdaBuffers.Compiler.ProtoCompat.Types (
4041
TyApp (..),
4142
TyArg (..),
4243
TyBody (..),
44+
TyClassRef (..),
4345
TyDef (..),
4446
TyName (..),
4547
TyRef (..),
@@ -48,13 +50,15 @@ module LambdaBuffers.Compiler.ProtoCompat.Types (
4850
module VARS,
4951
) where
5052

53+
-- for NonEmpty
5154
import Control.Exception (Exception)
52-
import Data.List.NonEmpty (NonEmpty ((:|)), (<|))
55+
import Data.List.NonEmpty (NonEmpty)
5356
import Data.Text (Text)
5457
import GHC.Generics (Generic)
5558
import LambdaBuffers.Compiler.KindCheck.Variable as VARS (Atom, Variable)
5659
import Test.QuickCheck (Gen, oneof, resize, sized)
5760
import Test.QuickCheck.Arbitrary.Generic (Arbitrary (arbitrary), GenericArbitrary (GenericArbitrary))
61+
import Test.QuickCheck.Instances.Semigroup ()
5862

5963
data SourceInfo = SourceInfo {file :: Text, posFrom :: SourcePosition, posTo :: SourcePosition}
6064
deriving stock (Show, Eq, Ord, Generic)
@@ -197,6 +201,24 @@ data Product = RecordI Record | TupleI Tuple
197201
deriving stock (Show, Eq, Ord, Generic)
198202
deriving (Arbitrary) via GenericArbitrary Product
199203

204+
data ForeignClassRef = ForeignClassRef
205+
{ className :: ClassName
206+
, moduleName :: ModuleName
207+
, sourceInfo :: SourceInfo
208+
}
209+
deriving stock (Show, Eq, Ord, Generic)
210+
deriving (Arbitrary) via GenericArbitrary ForeignClassRef
211+
212+
data LocalClassRef = LocalClassRef {className :: ClassName, sourceInfo :: SourceInfo}
213+
deriving stock (Show, Eq, Ord, Generic)
214+
deriving (Arbitrary) via GenericArbitrary LocalClassRef
215+
216+
data TyClassRef
217+
= LocalCI LocalClassRef
218+
| ForeignCI ForeignClassRef
219+
deriving stock (Show, Eq, Ord, Generic)
220+
deriving (Arbitrary) via GenericArbitrary TyClassRef
221+
200222
data ClassDef = ClassDef
201223
{ className :: ClassName
202224
, classArgs :: TyArg
@@ -208,7 +230,7 @@ data ClassDef = ClassDef
208230
deriving (Arbitrary) via GenericArbitrary ClassDef
209231

210232
data InstanceClause = InstanceClause
211-
{ className :: ClassName
233+
{ classRef :: TyClassRef
212234
, head :: Ty
213235
, constraints :: [Constraint]
214236
, sourceInfo :: SourceInfo
@@ -226,7 +248,7 @@ instance Arbitrary InstanceClause where
226248
<*> resize n arbitrary
227249

228250
data Constraint = Constraint
229-
{ className :: ClassName
251+
{ classRef :: TyClassRef
230252
, argument :: Ty
231253
, sourceInfo :: SourceInfo
232254
}
@@ -238,6 +260,7 @@ data Module = Module
238260
, typeDefs :: [TyDef]
239261
, classDefs :: [ClassDef]
240262
, instances :: [InstanceClause]
263+
, imports :: [ModuleName]
241264
, sourceInfo :: SourceInfo
242265
}
243266
deriving stock (Show, Eq, Ord, Generic)
@@ -252,6 +275,7 @@ instance Arbitrary Module where
252275
<*> resize n arbitrary
253276
<*> resize n arbitrary
254277
<*> resize n arbitrary
278+
<*> resize n arbitrary
255279

256280
data InferenceErr
257281
= UnboundTermErr Text
@@ -307,20 +331,3 @@ data CompilerResult = CompilerResult
307331
deriving (Arbitrary) via GenericArbitrary CompilerResult
308332

309333
type CompilerOutput = Either CompilerError CompilerResult
310-
311-
-- nonEmptyArbList :: forall a. Arbitrary a => Gen [a]
312-
-- nonEmptyArbList = getNonEmpty <$> arbitrary @(NonEmptyList a)
313-
314-
-- Orphan Instances
315-
instance Arbitrary a => Arbitrary (NonEmpty a) where
316-
arbitrary = sized f
317-
where
318-
f :: (Num t, Ord t) => t -> Gen (NonEmpty a)
319-
f n
320-
| n <= 0 = do
321-
x <- arbitrary @a
322-
pure $ x :| []
323-
| otherwise = do
324-
x <- arbitrary
325-
xs <- f (n - 1)
326-
pure $ x <| xs

0 commit comments

Comments
 (0)