Skip to content

Commit 51602fa

Browse files
gnumonikgnumonik
committed
Cleanup after merging main
1 parent c8bc599 commit 51602fa

File tree

4 files changed

+32
-27
lines changed

4 files changed

+32
-27
lines changed

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -120,6 +120,7 @@ library
120120
LambdaBuffers.Compiler.ProtoCompat
121121
LambdaBuffers.Compiler.ProtoCompat.FromProto
122122
LambdaBuffers.Compiler.ProtoCompat.Types
123+
LambdaBuffers.Compiler.TypeClass.Compat
123124
LambdaBuffers.Compiler.TypeClass.Pat
124125
LambdaBuffers.Compiler.TypeClass.Pretty
125126
LambdaBuffers.Compiler.TypeClass.Rules

‎lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClass/Compat.hs‎

Lines changed: 26 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -12,15 +12,16 @@ module LambdaBuffers.Compiler.TypeClass.Compat (
1212

1313
import Control.Lens ((^.))
1414
import Control.Lens.Combinators (view)
15-
import Data.List.NonEmpty (NonEmpty ((:|)))
15+
import Data.Bifunctor (second)
1616
import Data.List.NonEmpty qualified as NE
17+
import Data.Map qualified as M
1718
import Data.Text qualified as T
1819
import LambdaBuffers.Compiler.ProtoCompat qualified as P
1920
import LambdaBuffers.Compiler.TypeClass.Pat (
2021
Exp (AppE, DecE, LitE, NilE, RefE),
2122
ExpressionLike (nil, (*:), (*=)),
2223
Literal (ModuleName, Name, Opaque, TyVar),
23-
Pat (AppP, DecP, LitP, NilP, RefP, VarP),
24+
Pat (AppP, DecP, LitP, NilP, RefP),
2425
toProdE,
2526
toProdP,
2627
toRecE,
@@ -48,20 +49,20 @@ making the resulting Pat suitable for substitution into Rules.
4849
-}
4950
defToExp :: P.TyDef -> Exp
5051
defToExp (P.TyDef tName (P.TyAbs tArgs tBody _) _) = DecE (LitE . Name $ tName ^. #name) vars $ case tBody of
51-
P.SumI constrs -> toSumE . NE.toList . fmap goConstr $ (constrs ^. #constructors)
52+
P.SumI constrs -> toSumE . fmap (uncurry goConstr . second (view #product)) . M.toList $ (constrs ^. #constructors)
5253
P.OpaqueI _ -> LitE Opaque
5354
where
54-
collectFreeTyVars :: [P.TyArg] -> Exp
55-
collectFreeTyVars = foldr (\x acc -> LitE (TyVar (x ^. (#argName . #name))) *: acc) nil
55+
collectFreeTyVars :: [P.VarName] -> Exp
56+
collectFreeTyVars = foldr (\x acc -> LitE (TyVar (x ^. #name)) *: acc) nil
5657

57-
vars = collectFreeTyVars tArgs
58+
vars = collectFreeTyVars (M.keys tArgs)
5859

59-
goConstr :: P.Constructor -> Exp
60-
goConstr (P.Constructor n p) = LitE (Name (n ^. #name)) *= goProduct p
60+
goConstr :: P.ConstrName -> P.Product -> Exp
61+
goConstr (P.ConstrName n _) p = LitE (Name n) *= goProduct p
6162

6263
goProduct :: P.Product -> Exp
6364
goProduct = \case
64-
P.RecordI (P.Record rMap _) -> toRecE . NE.toList . fmap goField $ rMap
65+
P.RecordI (P.Record rMap _) -> toRecE . fmap goField . M.elems $ rMap
6566
P.TupleI (P.Tuple pList _) -> toProdE $ fmap tyToExp pList
6667

6768
goField :: P.Field -> Exp
@@ -80,35 +81,36 @@ tyToExp = \case
8081
let mnm = modulename mn
8182
in RefE (LitE $ ModuleName mnm) . LitE . Name $ (tn ^. #name)
8283

83-
appToExp :: Exp -> NonEmpty Exp -> Exp
84-
appToExp fun (p :| ps) = case NE.nonEmpty ps of
84+
appToExp :: Exp -> [Exp] -> Exp
85+
appToExp e [] = e
86+
appToExp fun (p : ps) = case NE.nonEmpty ps of
8587
Nothing -> AppE fun p
86-
Just rest -> AppE fun p `appToExp` rest
88+
Just rest -> AppE fun p `appToExp` NE.toList rest
8789

8890
defToPat :: P.TyDef -> Pat
8991
defToPat (P.TyDef tName (P.TyAbs tArgs tBody _) _) = DecP (LitP . Name $ tName ^. #name) vars $ case tBody of
90-
P.SumI constrs -> toSumP . NE.toList . fmap goConstr $ (constrs ^. #constructors)
92+
P.SumI constrs -> toSumP . fmap (uncurry goConstr . second (view #product)) . M.toList $ (constrs ^. #constructors)
9193
P.OpaqueI _ -> LitP Opaque
9294
where
93-
collectFreeTyVars :: [P.TyArg] -> Pat
94-
collectFreeTyVars = foldr (\x acc -> VarP (x ^. (#argName . #name)) *: acc) nil
95+
collectFreeTyVars :: [P.VarName] -> Pat
96+
collectFreeTyVars = foldr (\x acc -> LitP (TyVar (x ^. #name)) *: acc) nil
9597

96-
vars = collectFreeTyVars tArgs
98+
vars = collectFreeTyVars (M.keys tArgs)
9799

98-
goConstr :: P.Constructor -> Pat
99-
goConstr (P.Constructor n p) = LitP (Name (n ^. #name)) *= goProduct p
100+
goConstr :: P.ConstrName -> P.Product -> Pat
101+
goConstr (P.ConstrName n _) p = LitP (Name n) *= goProduct p
100102

101103
goProduct :: P.Product -> Pat
102104
goProduct = \case
103-
P.RecordI (P.Record rMap _) -> toRecP . NE.toList . fmap goField $ rMap
105+
P.RecordI (P.Record rMap _) -> toRecP . fmap goField . M.elems $ rMap
104106
P.TupleI (P.Tuple pList _) -> toProdP $ fmap tyToPat pList
105107

106108
goField :: P.Field -> Pat
107109
goField (P.Field n v) = LitP (Name (n ^. #name)) *= tyToPat v
108110

109111
tyToPat :: P.Ty -> Pat
110112
tyToPat = \case
111-
P.TyVarI t -> VarP (t ^. #varName . #name)
113+
P.TyVarI t -> LitP . TyVar $ t ^. #varName . #name
112114
P.TyAppI tapp ->
113115
let fun = tyToPat $ tapp ^. #tyFunc
114116
ps = tyToPat <$> tapp ^. #tyArgs
@@ -119,7 +121,8 @@ tyToPat = \case
119121
let mnm = modulename mn
120122
in RefP (LitP $ ModuleName mnm) . LitP . Name $ (tn ^. #name)
121123

122-
appToPat :: Pat -> NonEmpty Pat -> Pat
123-
appToPat fun (p :| ps) = case NE.nonEmpty ps of
124+
appToPat :: Pat -> [Pat] -> Pat
125+
appToPat e [] = e
126+
appToPat fun (p : ps) = case NE.nonEmpty ps of
124127
Nothing -> AppP fun p
125-
Just rest -> AppP fun p `appToPat` rest
128+
Just rest -> AppP fun p `appToPat` NE.toList rest

‎lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClass/Utils.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -234,7 +234,7 @@ mkClassInfos :: [P.Module] -> M.Map P.ModuleName [ClassInfo]
234234
mkClassInfos = foldl' (\acc mdl -> M.insert (mdl ^. #moduleName) (go mdl) acc) M.empty
235235
where
236236
go :: P.Module -> [ClassInfo]
237-
go m = map (defToClassInfo $ m ^. #moduleName) (m ^. #classDefs)
237+
go m = map (defToClassInfo $ m ^. #moduleName) (M.elems $ m ^. #classDefs)
238238

239239
defToClassInfo :: P.ModuleName -> P.ClassDef -> ClassInfo
240240
defToClassInfo mName cd =
@@ -301,7 +301,7 @@ getInstances ctable mn = foldM go S.empty
301301
cref = tyRefToFQClassName (modulename mn) cn
302302

303303
mkModuleClasses :: P.CompilerInput -> M.Map P.ModuleName [ClassInfo]
304-
mkModuleClasses (P.CompilerInput ms) = mkClassInfos ms
304+
mkModuleClasses (P.CompilerInput ms) = mkClassInfos (M.elems ms)
305305

306306
{- |
307307
This constructs the instances defined in each module (NOT the instances in scope in that module)
@@ -334,7 +334,7 @@ moduleScope modls is = go
334334
go :: P.ModuleName -> Either TypeClassError Instances
335335
go mn = case modls ^? (ix mn . #imports) of
336336
Nothing -> Left $ UnknownModule mn
337-
Just impts -> mconcat <$> traverse goImport impts
337+
Just impts -> mconcat <$> traverse goImport (S.toList impts)
338338

339339
-- NOTE: This doesn't do recursive scope fetching anymore.
340340
-- If a user wants an instance rule in scope, they
@@ -392,7 +392,7 @@ mkBuilders ci = do
392392
mbinsts <- lookupOr mn insts $ MissingModuleInstances mn
393393
mbscope <- lookupOr mn scope $ MissingModuleScope mn
394394
mdule <- lookupOr mn modTable $ UnknownModule mn
395-
mbclasses <- resolveClasses classTable mn $ mdule ^. #classDefs
395+
mbclasses <- resolveClasses classTable mn . M.elems $ mdule ^. #classDefs
396396
let mbtydefs =
397397
foldl'
398398
( \accM t ->

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -13,5 +13,6 @@ main =
1313
"Compiler tests"
1414
[ KC.test
1515
, TC.test
16+
, DC.test
1617
, LBC.test
1718
]

0 commit comments

Comments
 (0)