-
Notifications
You must be signed in to change notification settings - Fork 205
/
DataDependencies.hs
1408 lines (1258 loc) · 57.5 KB
/
DataDependencies.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
-- Copyright (c) 2021 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
module DA.Daml.Compiler.DataDependencies
( Config (..)
, generateSrcPkgFromLf
, prefixDependencyModule
) where
import DA.Pretty
import Control.Applicative
import Control.Monad
import Control.Monad.State.Strict
import Data.Char (isDigit)
import qualified Data.DList as DL
import Data.Foldable (fold)
import Data.Hashable (Hashable)
import qualified Data.HashMap.Strict as HMS
import Data.List.Extra
import Data.Ord (Down (Down))
import Data.Semigroup.FixedPoint
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Map.Strict as MS
import Data.Maybe
import Data.Either
import qualified Data.NameMap as NM
import qualified Data.Text as T
import Development.IDE.Types.Location
import GHC.Generics (Generic)
import Safe
import System.FilePath
import "ghc-lib-parser" Bag
import "ghc-lib-parser" BasicTypes
import "ghc-lib-parser" FastString
import "ghc-lib-parser" FieldLabel (FieldLbl (..))
import "ghc-lib" GHC
import "ghc-lib-parser" Module
import "ghc-lib-parser" Name
import "ghc-lib-parser" Outputable (ppr, showSDocForUser)
import "ghc-lib-parser" RdrName
import "ghc-lib-parser" TcEvidence (HsWrapper (WpHole))
import "ghc-lib-parser" TysPrim
import "ghc-lib-parser" TysWiredIn
import qualified DA.Daml.LF.Ast as LF
import qualified DA.Daml.LF.Ast.Type as LF
import qualified DA.Daml.LF.Ast.Alpha as LF
import qualified DA.Daml.LF.TypeChecker.Check as LF
import qualified DA.Daml.LF.TypeChecker.Env as LF
import qualified DA.Daml.LFConversion.MetadataEncoding as LFC
import DA.Daml.Options
import SdkVersion
data Config = Config
{ configPackages :: MS.Map LF.PackageId LF.Package
-- ^ All packages we know about, i.e., dependencies,
-- data-dependencies and stable packages.
, configGetUnitId :: LF.PackageRef -> UnitId
-- ^ maps a package reference to a unit id
, configSelfPkgId :: LF.PackageId
-- ^ package id for this package, we need it to build a closed LF.World
, configStablePackages :: MS.Map LF.PackageId UnitId
-- ^ map from a package id of a stable package to the unit id
-- of the corresponding package, i.e., daml-prim/daml-stdlib.
, configDependencyPackages :: Set LF.PackageId
-- ^ set of package ids for dependencies (not data-dependencies)
, configSdkPrefix :: [T.Text]
-- ^ prefix to use for current SDK in data-dependencies
}
data Env = Env
{ envConfig :: Config
, envQualifyThisModule :: Bool
-- ^ True if refences to this module should be qualified
, envWorld :: LF.World
-- ^ World built from dependencies, stable packages, and current package.
, envHiddenRefMap :: HMS.HashMap Ref Bool
-- ^ Set of references that should be hidden, not exposed.
, envDepClassMap :: DepClassMap
-- ^ Map of typeclasses from dependencies.
, envDepInstances :: MS.Map LF.TypeSynName [LF.Qualified LF.Type]
-- ^ Map of instances from dependencies.
-- We only store the name since the real check happens in `isDuplicate`.
, envMod :: LF.Module
-- ^ The module under consideration.
}
-- | Build an LF world up from the Config data.
buildWorld :: Config -> LF.World
buildWorld Config{..} =
fromMaybe (error "Failed to build LF World for data-dependencies") $ do
let packageIds = concat
[ [configSelfPkgId] -- We need to add this here,
-- instead of relying on the self argument below,
-- because package references in the current
-- package have also been rewritten during decoding.
, MS.keys configPackages
]
mkExtPackage pkgId = do
pkg <- MS.lookup pkgId configPackages
Just (LF.ExternalPackage pkgId pkg)
extPackages <- mapM mkExtPackage packageIds
self <- MS.lookup configSelfPkgId configPackages
Just (LF.initWorldSelf extPackages self)
envLfVersion :: Env -> LF.Version
envLfVersion = LF.packageLfVersion . LF.getWorldSelf . envWorld
-- | Type classes coming from dependencies. This maps a (module, synonym)
-- name pair to a corresponding dependency package id and synonym definition.
newtype DepClassMap = DepClassMap
{ unDepClassMap :: MS.Map
(LF.ModuleName, LF.TypeSynName)
(LF.PackageId, LF.DefTypeSyn)
}
buildDepClassMap :: Config -> DepClassMap
buildDepClassMap Config{..} = DepClassMap $ MS.fromList
[ ((moduleName, synName), (packageId, dsyn))
| packageId <- Set.toList configDependencyPackages
, Just LF.Package{..} <- [MS.lookup packageId configPackages]
, LF.Module{..} <- NM.toList packageModules
, [email protected]{..} <- NM.toList moduleSynonyms
]
buildDepInstances :: Config -> MS.Map LF.TypeSynName [LF.Qualified LF.Type]
buildDepInstances Config{..} = MS.fromListWith (<>)
[ (clsName, [LF.Qualified (LF.PRImport packageId) moduleName (snd dvalBinder)])
| packageId <- Set.toList configDependencyPackages
, Just LF.Package{..} <- [MS.lookup packageId configPackages]
, LF.Module{..} <- NM.toList packageModules
, [email protected]{..} <- NM.toList moduleValues
, Just dfun <- [getDFunSig dval]
, let clsName = LF.qualObject $ dfhName $ dfsHead dfun
]
envLookupDepClass :: LF.TypeSynName -> Env -> Maybe (LF.PackageId, LF.DefTypeSyn)
envLookupDepClass synName env =
let modName = LF.moduleName (envMod env)
classMap = unDepClassMap (envDepClassMap env)
in MS.lookup (modName, synName) classMap
-- | Determine whether two type synonym definitions are similar enough to
-- reexport one as the other. This is done by computing alpha equivalence
-- after expanding all type synonyms.
safeToReexport :: Env -> LF.DefTypeSyn -> LF.DefTypeSyn -> Bool
safeToReexport env syn1 syn2 =
-- this should never fail so we just call `error` if it does
either (error . ("Internal LF type error: " <>) . renderPretty) id $ do
LF.runGamma (envWorld env) (envLfVersion env) $ do
esyn1 <- LF.expandTypeSynonyms (closedType syn1)
esyn2 <- LF.expandTypeSynonyms (closedType syn2)
pure (LF.alphaType esyn1 esyn2)
where
-- | Turn a type synonym definition into a closed type.
closedType :: LF.DefTypeSyn -> LF.Type
closedType LF.DefTypeSyn{..} = LF.mkTForalls synParams synType
-- | Check if an instance is a duplicate of another one.
-- This is needed to filter out duplicate instances which would
-- result in a type error.
isDuplicate :: Env -> LF.Type -> LF.Type -> Bool
isDuplicate env ty1 ty2 =
fromRight False $ do
LF.runGamma (envWorld env) (envLfVersion env) $ do
esyn1 <- LF.expandTypeSynonyms ty1
esyn2 <- LF.expandTypeSynonyms ty2
pure (LF.alphaType esyn1 esyn2)
data ImportOrigin = FromCurrentSdk UnitId | FromPackage LF.PackageId
deriving (Eq, Ord)
-- | A module reference coming from DAML-LF.
data ModRef = ModRef
{ modRefModule :: LF.ModuleName
, modRefOrigin :: ImportOrigin
, modRefImpSpec :: ModRefImpSpec
} deriving (Eq, Ord)
data ModRefImpSpec
= NoImpSpec
-- ^ For open imports, e.g.
--
-- > import SomeModule
| EmptyImpSpec
-- ^ For instances-only imports, e.g.
--
-- > import SomeModule ()
deriving (Eq, Ord)
modRefImport :: Config -> ModRef -> LImportDecl GhcPs
modRefImport Config{..} ModRef{..} = noLoc ImportDecl
{ ideclSourceSrc = NoSourceText
, ideclName = (noLoc . mkModuleName . T.unpack . LF.moduleNameString) modName
, ideclPkgQual = Nothing
, ideclSource = False
, ideclSafe = False
, ideclImplicit = False
, ideclQualified = False
, ideclAs = Nothing
, ideclHiding = impSpec
, ideclExt = noExt
}
where
modName = case modRefOrigin of
FromCurrentSdk _ -> LF.ModuleName (configSdkPrefix <> LF.unModuleName modRefModule)
FromPackage importPkgId
| importPkgId == configSelfPkgId -> modRefModule
-- The module names from the current package are the only ones that are not modified
| otherwise -> prefixDependencyModule importPkgId modRefModule
impSpec = case modRefImpSpec of
NoImpSpec -> Nothing
EmptyImpSpec -> Just (False, noLoc []) -- False = not 'hiding'
data GenState = GenState
{ gsModRefs :: !(Set ModRef)
, gsFreshCounter :: !Int
, gsExtraDecls :: ![LHsDecl GhcPs]
}
initialGenState :: GenState
initialGenState = GenState
{ gsModRefs = mempty
, gsExtraDecls = []
, gsFreshCounter = 1
}
-- | Monad for generating a value together with its module references.
newtype Gen t = Gen (State GenState t)
deriving (Functor, Applicative, Monad)
runGen :: Gen t -> (t, GenState)
runGen (Gen m) = runState m initialGenState
emitModRef :: ModRef -> Gen ()
emitModRef modRef = Gen $ modify' (\gs -> gs { gsModRefs = Set.insert modRef (gsModRefs gs) })
emitHsDecl :: LHsDecl GhcPs -> Gen ()
emitHsDecl decl = Gen $ modify' (\gs -> gs { gsExtraDecls = decl : gsExtraDecls gs })
freshInt :: Gen Int
freshInt = Gen $ state (\gs -> (gsFreshCounter gs, gs { gsFreshCounter = gsFreshCounter gs + 1 }))
freshTypeName :: Env -> Gen (Located RdrName)
freshTypeName env = mkRdrName . (prefix <>) . T.pack . show <$> freshInt
where
prefix :: T.Text
prefix = T.concat
[ "T__DataDependencies__"
, LF.unPackageId (configSelfPkgId (envConfig env))
, "__"
, T.intercalate "_" (LF.unModuleName (LF.moduleName (envMod env)))
, "__"
]
-- | Extract all data definitions from a daml-lf module and generate
-- a haskell source file from it.
generateSrcFromLf ::
Env
-> ParsedSource
generateSrcFromLf env = noLoc mod
where
config = envConfig env
lfModName = LF.moduleName $ envMod env
ghcModName = mkModuleName $ T.unpack $ LF.moduleNameString lfModName
unitId = configGetUnitId config LF.PRSelf
thisModule = mkModule unitId ghcModName
mod =
HsModule
{ hsmodImports = imports
, hsmodName = Just (noLoc ghcModName)
, hsmodDecls = decls <> gsExtraDecls genState
, hsmodDeprecMessage = Nothing
, hsmodHaddockModHeader = Nothing
, hsmodExports = Just (noLoc exports)
}
decls :: [LHsDecl GhcPs]
exports :: [LIE GhcPs]
genState :: GenState
((exports, decls), genState) = runGen
((,) <$> genExports <*> genDecls <* genOrphanDepImports)
modRefs :: Set ModRef
modRefs = gsModRefs genState
genOrphanDepImports :: Gen ()
genOrphanDepImports = sequence_ $ do
Just LF.DefValue{dvalBinder=(_, ty)} <- [NM.lookup LFC.moduleImportsName . LF.moduleValues $ envMod env]
Just quals <- [LFC.decodeModuleImports ty]
LF.Qualified { LF.qualModule, LF.qualPackage } <- Set.toList quals
pure $ emitModRef ModRef
{ modRefModule = qualModule
, modRefOrigin = importOriginFromPackageRef (envConfig env) qualPackage
, modRefImpSpec = EmptyImpSpec
}
genExports :: Gen [LIE GhcPs]
genExports = (++)
<$> (sequence $ selfReexport : classReexports)
<*> allExports
genDecls :: Gen [LHsDecl GhcPs]
genDecls = do
decls <- sequence . concat $
[ classDecls
, synonymDecls
, dataTypeDecls
, valueDecls
]
instDecls <- sequence instanceDecls
pure $ decls <> catMaybes instDecls
classMethodNames :: Set T.Text
classMethodNames = Set.fromList
[ methodName
| LF.DefTypeSyn{..} <- NM.toList . LF.moduleSynonyms $ envMod env
, LF.TStruct fields <- [synType]
, (fieldName, _) <- fields
, Just methodName <- [getClassMethodName fieldName]
]
allExports :: Gen [LIE GhcPs]
allExports = sequence $ do
LF.DefValue {dvalBinder=(name, ty)} <- NM.toList . LF.moduleValues $ envMod env
Just _ <- [LFC.unExportName name] -- We don't really care about the order of exports
Just export <- [LFC.decodeExportInfo ty]
pure $ mkLIE export
where
mkLIE :: LFC.ExportInfo -> Gen (LIE GhcPs)
mkLIE = fmap noLoc . \case
LFC.ExportInfoVal name ->
IEVar NoExt
<$> mkWrappedRdrName name
LFC.ExportInfoTC name pieces fields ->
IEThingWith NoExt
<$> mkWrappedRdrName name
<*> pure NoIEWildcard
<*> mapM mkWrappedRdrName pieces
<*> mapM mkFieldLblRdrName fields
mkWrappedRdrName :: LFC.QualName -> Gen (LIEWrappedName RdrName)
mkWrappedRdrName = fmap (noLoc . IEName . noLoc) . mkRdrName
mkRdrName :: LFC.QualName -> Gen RdrName
mkRdrName (LFC.QualName q) = do
ghcMod <- genModule env (LF.qualPackage q) (LF.qualModule q)
pure $ mkOrig ghcMod (LF.qualObject q)
mkFieldLblRdrName :: FieldLbl LFC.QualName -> Gen (Located (FieldLbl RdrName))
mkFieldLblRdrName = fmap noLoc . traverse mkRdrName
selfReexport :: Gen (LIE GhcPs)
selfReexport = pure . noLoc $
IEModuleContents noExt (noLoc ghcModName)
classReexports :: [Gen (LIE GhcPs)]
classReexports = map snd (MS.elems classReexportMap)
classReexportMap :: MS.Map LF.TypeSynName (LF.PackageId, Gen (LIE GhcPs))
classReexportMap = MS.fromList $ do
[email protected]{..} <- NM.toList . LF.moduleSynonyms $ envMod env
guard $ isJust (getTypeClassFields synType)
LF.TypeSynName [name] <- [synName]
Just (pkgId, depDef) <- [envLookupDepClass synName env]
guard (safeToReexport env synDef depDef)
let occName = mkOccName clsName (T.unpack name)
pure . (\x -> (synName,(pkgId, x))) $ do
ghcMod <- genModule env (LF.PRImport pkgId) (LF.moduleName (envMod env))
pure . noLoc . IEThingAll noExt
. noLoc . IEName . noLoc
$ mkOrig ghcMod occName
reexportedClasses :: MS.Map LF.TypeSynName LF.PackageId
reexportedClasses = MS.map fst classReexportMap
classDecls :: [Gen (LHsDecl GhcPs)]
classDecls = do
[email protected]{..} <- NM.toList . LF.moduleSynonyms $ envMod env
Just fields <- [getTypeClassFields synType]
LF.TypeSynName [name] <- [synName]
guard (synName `MS.notMember` classReexportMap)
guard (shouldExposeDefTypeSyn defTypeSyn)
let occName = mkOccName clsName (T.unpack name)
pure $ do
supers <- sequence
[ convType env reexportedClasses fieldType
| (fieldName, LF.TUnit LF.:-> fieldType) <- fields
, isSuperClassField fieldName
]
methods <- sequence
[ (methodName,) <$> convType env reexportedClasses fieldType
| (fieldName, LF.TUnit LF.:-> fieldType) <- fields
, Just methodName <- [getClassMethodName fieldName]
]
params <- mapM (convTyVarBinder env) synParams
defaultMethods <- sequence
[ do
sig <- convType env reexportedClasses defaultSig
bind <- mkStubBind env (mkRdrName methodName) defaultSig
pure (methodName, sig, bind)
| (fieldName, LF.TUnit LF.:-> _) <- fields
, Just methodName <- [getClassMethodName fieldName]
, Just LF.DefValue { dvalBinder = (_, LF.TForalls _ (LF.TSynApp _ _ LF.:-> defaultSig)) }
<- [NM.lookup (defaultMethodName methodName) (LF.moduleValues (envMod env))]
]
pure . noLoc . TyClD noExt $ ClassDecl
{ tcdCExt = noExt
, tcdCtxt = noLoc (map noLoc supers)
, tcdLName = noLoc $ mkRdrUnqual occName
, tcdTyVars = HsQTvs noExt params
, tcdFixity = Prefix
, tcdFDs = mkFunDeps synName
, tcdSigs =
[ mkOpSig False name ty | (name, ty) <- methods ] ++
[ mkOpSig True name ty | (name, ty, _) <- defaultMethods ] ++
mkMinimalSig synName
, tcdMeths = listToBag
[ noLoc bind | (_, _, bind) <- defaultMethods ]
, tcdATs = [] -- associated types not supported
, tcdATDefs = []
, tcdDocs = []
}
where
mkOpSig :: Bool -> T.Text -> HsType GhcPs -> LSig GhcPs
mkOpSig isDefault methodName methodType =
noLoc $ ClassOpSig noExt isDefault
[mkRdrName methodName]
(HsIB noExt (noLoc methodType))
mkFunDeps :: LF.TypeSynName -> [LHsFunDep GhcPs]
mkFunDeps synName = fromMaybe [] $ do
let values = LF.moduleValues (envMod env)
LF.DefValue{..} <- NM.lookup (LFC.funDepName synName) values
LF.TForalls _ ty <- pure (snd dvalBinder)
funDeps <- LFC.decodeFunDeps ty
pure $ map (noLoc . LFC.mapFunDep (mkRdrName . LF.unTypeVarName)) funDeps
mkMinimalSig :: LF.TypeSynName -> [LSig GhcPs]
mkMinimalSig synName = maybeToList $ do
let values = LF.moduleValues (envMod env)
LF.DefValue{..} <- NM.lookup (LFC.minimalName synName) values
lbf <- LFC.decodeLBooleanFormula (snd dvalBinder)
let lbf' = fmap (fmap mkRdrName) lbf
Just (noLoc (MinimalSig noExt NoSourceText lbf'))
synonymDecls :: [Gen (LHsDecl GhcPs)]
synonymDecls = do
defTypeSyn <- NM.toList . LF.moduleSynonyms $ envMod env
Just (synName, synParams, synType) <- [LFC.decodeTypeSynonym defTypeSyn]
Nothing <- [getTypeClassFields synType]
LF.TypeSynName [name] <- [synName]
guard (shouldExposeDefTypeSyn defTypeSyn)
let occName = mkOccName tcName (T.unpack name)
pure $ do
params <- mapM (convTyVarBinder env) synParams
rhs <- convType env reexportedClasses synType
pure . noLoc . TyClD noExt $ SynDecl
{ tcdSExt = noExt
, tcdLName = noLoc $ mkRdrUnqual occName
, tcdTyVars = HsQTvs noExt params
, tcdFixity = Prefix
, tcdRhs = noLoc rhs
}
dataTypeDecls :: [Gen (LHsDecl GhcPs)]
dataTypeDecls = do
[email protected] {..} <- NM.toList $ LF.moduleDataTypes $ envMod env
guard $ shouldExposeDefDataType dtype
let numberOfNameComponents = length (LF.unTypeConName dataTypeCon)
-- we should never encounter more than two name components in dalfs.
unless (numberOfNameComponents <= 2) $
errTooManyNameComponents $ LF.unTypeConName dataTypeCon
-- skip generated data types of sums of products construction in daml-lf
-- the type will be inlined into the definition of the variant in
-- convDataCons.
[dataTypeCon0] <- [LF.unTypeConName dataTypeCon]
let occName = mkOccName varName (T.unpack dataTypeCon0)
[ mkDataDecl env thisModule occName dataParams =<<
convDataCons dataTypeCon0 dataCons ]
valueDecls :: [Gen (LHsDecl GhcPs)]
valueDecls = do
[email protected] {..} <- NM.toList $ LF.moduleValues $ envMod env
guard $ shouldExposeDefValue dval
let (lfName, lfType) = dvalBinder
ltype = noLoc <$> convType env reexportedClasses lfType :: Gen (LHsType GhcPs)
lname = mkRdrName (LF.unExprValName lfName) :: Located RdrName
sig = TypeSig noExt [lname] . HsWC noExt . HsIB noExt <$> ltype
lsigD = noLoc . SigD noExt <$> sig :: Gen (LHsDecl GhcPs)
let lvalD = noLoc . ValD noExt <$> mkStubBind env lname lfType
[ lsigD, lvalD ]
-- | Generate instance declarations from dictionary functions.
instanceDecls :: [Gen (Maybe (LHsDecl GhcPs))]
instanceDecls = do
[email protected] {..} <- sortOn (Down . nameKey) $ NM.toList $ LF.moduleValues $ envMod env
Just dfunSig <- [getDFunSig dval]
guard (shouldExposeInstance dval)
let clsName = LF.qualObject $ dfhName $ dfsHead dfunSig
case find (isDuplicate env (snd dvalBinder) . LF.qualObject) (MS.findWithDefault [] clsName $ envDepInstances env) of
Just qualInstance ->
-- If the instance already exists, we still
-- need to import it so that we can refer to it from other
-- instances.
[Nothing <$ genModule env (LF.qualPackage qualInstance) (LF.qualModule qualInstance)]
Nothing -> pure $ do
polyTy <- HsIB noExt . noLoc <$> convDFunSig env reexportedClasses dfunSig
binds <- genInstanceBinds dfunSig
pure . Just . noLoc . InstD noExt . ClsInstD noExt $ ClsInstDecl
{ cid_ext = noExt
, cid_poly_ty = polyTy
, cid_binds = binds
, cid_sigs = []
, cid_tyfam_insts = []
, cid_datafam_insts = []
, cid_overlap_mode = getOverlapMode (fst dvalBinder)
}
where
-- Split a DefValue's name, into the lexical part and the numeric part
-- if it exists. For example, the name "$dFooBar123" is split into a
-- pair ("$dFooBar", Just 123), and the name "$dFooBar" would be turned
-- into ("$dFooBar", Nothing). This gives us the correct (or, close
-- enough) order for recreating dictionary function names in GHC without
-- mismatches.
--
-- See issue #7362, and the corresponding regression test in the
-- packaging test suite.
nameKey :: LF.DefValue -> (T.Text, Maybe Int)
nameKey dval =
let name = LF.unExprValName (fst (LF.dvalBinder dval))
(intR,tagR) = T.span isDigit (T.reverse name)
in (T.reverse tagR, readMay (T.unpack (T.reverse intR)))
getOverlapMode :: LF.ExprValName -> Maybe (Located OverlapMode)
getOverlapMode name = do
dval <- NM.lookup (LFC.overlapModeName name) (LF.moduleValues (envMod env))
mode <- LFC.decodeOverlapMode (snd (LF.dvalBinder dval))
Just (noLoc mode)
genInstanceBinds :: DFunSig -> Gen (LHsBinds GhcPs)
genInstanceBinds DFunSig{..}
| DFunHeadNormal{..} <- dfsHead
, Right (LF.TStruct fields) <-
LF.runGamma (envWorld env) (envLfVersion env) $
LF.introTypeVars dfsBinders $ LF.expandSynApp dfhName dfhArgs
= listToBag <$> sequence
[ noLoc <$> mkStubBind env (mkRdrName methodName) methodType
| (fieldName, LF.TUnit LF.:-> methodType) <- fields
, Just methodName <- [getClassMethodName fieldName]
]
| otherwise
= pure emptyBag
hiddenRefMap :: HMS.HashMap Ref Bool
hiddenRefMap = envHiddenRefMap env
isHidden :: Ref -> Bool
isHidden ref =
case HMS.lookup ref hiddenRefMap of
Nothing -> error
("Internal Error: Missing type dependency from hiddenRefMap: "
<> show ref)
Just b -> b
qualify :: a -> LF.Qualified a
qualify x = LF.Qualified
{ qualPackage = LF.PRImport (configSelfPkgId config)
, qualModule = lfModName
, qualObject = x
}
shouldExposeDefDataType :: LF.DefDataType -> Bool
shouldExposeDefDataType LF.DefDataType{..}
= not (isHidden (RTypeCon (qualify dataTypeCon)))
shouldExposeDefTypeSyn :: LF.DefTypeSyn -> Bool
shouldExposeDefTypeSyn LF.DefTypeSyn{..}
= not (isHidden (RTypeSyn (qualify synName)))
shouldExposeDefValue :: LF.DefValue -> Bool
shouldExposeDefValue LF.DefValue{..}
| (lfName, lfType) <- dvalBinder
= not ("$" `T.isPrefixOf` LF.unExprValName lfName)
&& not (any isHidden (DL.toList (refsFromType lfType)))
&& (LF.moduleNameString lfModName /= "GHC.Prim")
&& not (LF.unExprValName lfName `Set.member` classMethodNames)
shouldExposeInstance :: LF.DefValue -> Bool
shouldExposeInstance LF.DefValue{..}
= isDFunBody dvalBody
&& not (isHidden (RValue (qualify (fst dvalBinder))))
convDataCons :: T.Text -> LF.DataCons -> Gen [LConDecl GhcPs]
convDataCons dataTypeCon0 = \case
LF.DataRecord fields -> do
fields' <- mapM (uncurry (mkConDeclField env)) fields
pure [ mkConDecl occName (RecCon (noLoc fields')) ]
LF.DataVariant cons -> do
let hasExactlyOneConstructor = length cons == 1
sequence
[ mkConDecl (occNameFor conName) <$> convConDetails hasExactlyOneConstructor ty
| (conName, ty) <- cons
]
LF.DataEnum cons -> do
when (length cons == 1) (void $ mkGhcType env "DamlEnum")
-- Single constructor enums spawn a reference to
-- GHC.Types.DamlEnum in the daml-preprocessor.
pure
[ mkConDecl (occNameFor conName) (PrefixCon [])
| conName <- cons
]
-- TODO https://github.com/digital-asset/daml/issues/10810
LF.DataInterface -> error "interfaces are not implemented"
where
occName = mkOccName varName (T.unpack dataTypeCon0)
occNameFor (LF.VariantConName c) = mkOccName varName (T.unpack c)
mkConDecl :: OccName -> HsConDeclDetails GhcPs -> LConDecl GhcPs
mkConDecl conName details = noLoc $ ConDeclH98
{ con_ext = noExt
, con_name = noLoc $ mkConRdr env thisModule conName
, con_forall = noLoc False -- No foralls from existentials
, con_ex_tvs = [] -- No existential type vars.
, con_mb_cxt = Nothing
, con_doc = Nothing
, con_args = details
}
convConDetails :: Bool -> LF.Type -> Gen (HsConDeclDetails GhcPs)
convConDetails hasExactlyOneConstructor = \case
-- nullary variant constructor (see issue #7207)
--
-- We translate a variant constructor `C ()` to `C` in DAML. But
-- if it's the only constructor, we leave it as `C ()` to distinguish
-- it from an enum type.
LF.TUnit | not hasExactlyOneConstructor ->
pure $ PrefixCon []
-- variant record constructor
LF.TConApp LF.Qualified{..} _
| LF.TypeConName ns <- qualObject
, length ns == 2 ->
case MS.lookup ns (sumProdRecords $ envMod env) of
Nothing ->
error $ "Internal error: Could not find generated record type: " <> T.unpack (T.intercalate "." ns)
Just fs ->
RecCon . noLoc <$> mapM (uncurry (mkConDeclField env)) fs
-- normal payload
ty ->
PrefixCon . pure . noLoc <$> convType env reexportedClasses ty
-- imports needed by the module declarations
imports
=
[ modRefImport config modRef
| modRef@ModRef{..} <- Set.toList modRefs
-- don’t import ourselves
, not (modRefModule == lfModName && modRefOrigin == FromPackage (configSelfPkgId config))
-- GHC.Prim doesn’t need to and cannot be explicitly imported (it is not exposed since the interface file is black magic
-- hardcoded in GHC).
, modRefModule /= LF.ModuleName ["CurrentSdk", "GHC", "Prim"]
]
getTypeClassFields :: LF.Type -> Maybe [(LF.FieldName, LF.Type)]
getTypeClassFields = \case
LF.TStruct fields | all isTypeClassField fields -> Just fields
LF.TUnit -> Just []
-- Type classes with no fields are translated to TUnit
-- since LF structs need to have a non-zero number of
-- fields.
_ -> Nothing
isTypeClassField :: (LF.FieldName, LF.Type) -> Bool
isTypeClassField = \case
(fieldName, LF.TUnit LF.:-> _) ->
isSuperClassField fieldName || isJust (getClassMethodName fieldName)
_ ->
False
mkConRdr :: Env -> Module -> OccName -> RdrName
mkConRdr env thisModule
| envQualifyThisModule env = mkOrig thisModule
| otherwise = mkRdrUnqual
mkDataDecl :: Env -> Module -> OccName -> [(LF.TypeVarName, LF.Kind)] -> [LConDecl GhcPs] -> Gen (LHsDecl GhcPs)
mkDataDecl env thisModule occName tyVars cons = do
tyVars' <- mapM (convTyVarBinder env) tyVars
pure . noLoc . TyClD noExt $ DataDecl
{ tcdDExt = noExt
, tcdLName = noLoc $ mkConRdr env thisModule occName
, tcdTyVars = HsQTvs noExt tyVars'
, tcdFixity = Prefix
, tcdDataDefn =
HsDataDefn
{ dd_ext = noExt
, dd_ND = DataType
, dd_ctxt = noLoc []
, dd_cType = Nothing
, dd_kindSig = Nothing
, dd_cons = cons
, dd_derivs = noLoc []
}
}
-- | Make a binding of the form "x = error \"data-dependency stub\"". If a qualified name is passed,
-- we turn the left-hand side into the unqualified form of that name (LHS
-- must always be unqualified), and the right-hand side remains qualified.
mkStubBind :: Env -> Located RdrName -> LF.Type -> Gen (HsBind GhcPs)
mkStubBind env lname ty = do
-- Producing an expression that GHC will accept for
-- an arbitrary type:
--
-- 1. A simple recursive binding x = x falls apart in the presence of
-- AllowAmbiguousTypes.
-- 2. TypeApplications could in theory fix this but GHC is
-- extremely pedantic when it comes to which type variables are
-- in scope, e.g., the following is an error
--
-- f :: (forall a. Show a => a -> String)
-- f = f @a -- not in scope error
--
-- So making that actually work is very annoying.
-- 3. One would hope that just calling `error` does the trick but that
-- fails due to ImpredicativeTypes in something like Lens s t a b -> Lens s t a b.
--
-- The solution we use is to count the number of arguments and add wildcard
-- matches so that the type variable in `error`s type only needs to be
-- unified with the non-impredicative result.
lexpr <- mkErrorCall env "data-dependency stub"
let args = countFunArgs ty
let lgrhs = noLoc $ GRHS noExt [] lexpr :: LGRHS GhcPs (LHsExpr GhcPs)
grhss = GRHSs noExt [lgrhs] (noLoc $ EmptyLocalBinds noExt)
lnameUnqual = noLoc . mkRdrUnqual . rdrNameOcc $ unLoc lname
matchContext = FunRhs lnameUnqual Prefix NoSrcStrict
lmatch = noLoc $ Match noExt matchContext (replicate args $ noLoc (WildPat noExt)) Nothing grhss
lalts = noLoc [lmatch]
bind = FunBind noExt lnameUnqual (MG noExt lalts Generated) WpHole []
pure bind
where
countFunArgs = \case
(arg LF.:-> t)
| isConstraint arg -> countFunArgs t
| otherwise -> 1 + countFunArgs t
LF.TForall _ t -> countFunArgs t
_ -> 0
mkErrorCall :: Env -> String -> Gen (LHsExpr GhcPs)
mkErrorCall env msg = do
ghcErr <- genStableModule env primUnitId (LF.ModuleName ["GHC", "Err"])
dataString <- genStableModule env primUnitId (LF.ModuleName ["Data", "String"])
let errorFun = noLoc $ HsVar noExt $ noLoc $ mkOrig ghcErr $ mkOccName varName "error" :: LHsExpr GhcPs
let fromStringFun = noLoc $ HsVar noExt $ noLoc $ mkOrig dataString $ mkOccName varName "fromString" :: LHsExpr GhcPs
let errorMsg = noLoc $ HsLit noExt (HsString (SourceText $ show msg) $ mkFastString msg) :: LHsExpr GhcPs
pure $ noLoc $ HsPar noExt $ noLoc $ HsApp noExt errorFun (noLoc $ HsPar noExt $ noLoc $ HsApp noExt fromStringFun errorMsg)
mkConDeclField :: Env -> LF.FieldName -> LF.Type -> Gen (LConDeclField GhcPs)
mkConDeclField env fieldName fieldTy = do
fieldTy' <- convType env MS.empty fieldTy
pure . noLoc $ ConDeclField
{ cd_fld_ext = noExt
, cd_fld_doc = Nothing
, cd_fld_names =
[ noLoc $ FieldOcc { extFieldOcc = noExt, rdrNameFieldOcc = mkRdrName $ LF.unFieldName fieldName } ]
, cd_fld_type = noLoc fieldTy'
}
isConstraint :: LF.Type -> Bool
isConstraint = \case
LF.TSynApp _ _ -> True
LF.TStruct fields -> and
[ isSuperClassField fieldName && isConstraint fieldType
| (fieldName, fieldType) <- fields
]
_ -> False
genModule :: Env -> LF.PackageRef -> LF.ModuleName -> Gen Module
genModule env pkgRef modName = do
let config = envConfig env
origin = importOriginFromPackageRef config pkgRef
genModuleAux config origin modName
importOriginFromPackageRef :: Config -> LF.PackageRef -> ImportOrigin
importOriginFromPackageRef Config {..} = \case
LF.PRImport pkgId
| Just unitId <- MS.lookup pkgId configStablePackages -> FromCurrentSdk unitId
| otherwise -> FromPackage pkgId
LF.PRSelf -> FromPackage configSelfPkgId
genStableModule :: Env -> UnitId -> LF.ModuleName -> Gen Module
genStableModule env currentSdkPkg = genModuleAux (envConfig env) (FromCurrentSdk currentSdkPkg)
prefixModuleName :: [T.Text] -> LF.ModuleName -> LF.ModuleName
prefixModuleName prefix (LF.ModuleName mod) = LF.ModuleName (prefix <> mod)
prefixDependencyModule :: LF.PackageId -> LF.ModuleName -> LF.ModuleName
prefixDependencyModule (LF.PackageId pkgId) = prefixModuleName ["Pkg_" <> pkgId]
genModuleAux :: Config -> ImportOrigin -> LF.ModuleName -> Gen Module
genModuleAux conf origin moduleName = do
let modRef = ModRef moduleName origin NoImpSpec
let ghcModuleName = (unLoc . ideclName . unLoc . modRefImport conf) modRef
let unitId = case origin of
FromCurrentSdk unitId -> unitId
FromPackage pkgId -> configGetUnitId conf (LF.PRImport pkgId)
emitModRef modRef
pure $ mkModule unitId ghcModuleName
-- | We cannot refer to a class C reexported from the current module M using M.C. Therefore
-- we have to rewrite it to the original module. The map only contains type synonyms reexported
-- from the current module.
rewriteClassReexport :: Env -> MS.Map LF.TypeSynName LF.PackageId -> LF.Qualified LF.TypeSynName -> LF.Qualified LF.TypeSynName
rewriteClassReexport env reexported [email protected]{..}
| Just reexportPkgId <- MS.lookup qualObject reexported
-- Only rewrite a reference to the current module
, case qualPackage of
LF.PRSelf -> True
LF.PRImport synPkgId -> synPkgId == configSelfPkgId (envConfig env)
, LF.moduleName (envMod env) == qualModule
= syn { LF.qualPackage = LF.PRImport reexportPkgId }
| otherwise = syn
convType :: Env -> MS.Map LF.TypeSynName LF.PackageId -> LF.Type -> Gen (HsType GhcPs)
convType env reexported =
\case
LF.TVar tyVarName -> pure $
HsTyVar noExt NotPromoted $ mkRdrName $ LF.unTypeVarName tyVarName
ty1 LF.:-> ty2 -> do
ty1' <- convTypeLiftingConstraintTuples ty1
ty2' <- convType env reexported ty2
pure $ if isConstraint ty1
then HsParTy noExt (noLoc $ HsQualTy noExt (noLoc [noLoc ty1']) (noLoc ty2'))
else HsParTy noExt (noLoc $ HsFunTy noExt (noLoc ty1') (noLoc ty2'))
LF.TSynApp (rewriteClassReexport env reexported -> LF.Qualified{..}) lfArgs -> do
ghcMod <- genModule env qualPackage qualModule
let tyname = case LF.unTypeSynName qualObject of
[n] -> n
ns -> error ("DamlDependencies: unexpected typeclass name " <> show ns)
tyvar = HsTyVar noExt NotPromoted . noLoc
. mkOrig ghcMod . mkOccName clsName $ T.unpack tyname
args <- mapM (convType env reexported) lfArgs
pure $ HsParTy noExt (noLoc $ foldl' (HsAppTy noExt . noLoc) tyvar (map noLoc args))
ty | Just text <- getPromotedText ty ->
pure $ HsTyLit noExt (HsStrTy NoSourceText (mkFastString $ T.unpack text))
LF.TCon LF.Qualified {..}
| qualModule == LF.ModuleName ["DA", "Types"]
, [name] <- LF.unTypeConName qualObject
, Just n <- stripPrefix "Tuple" $ T.unpack name
, Just i <- readMay n
, 2 <= i && i <= 20
-> mkTuple i
LF.TCon LF.Qualified {..} ->
case LF.unTypeConName qualObject of
[name] -> do
ghcMod <- genModule env qualPackage qualModule
pure . HsTyVar noExt NotPromoted . noLoc
. mkOrig ghcMod . mkOccName varName $ T.unpack name
cs -> errTooManyNameComponents cs
LF.TApp ty1 ty2 -> do
ty1' <- convType env reexported ty1
ty2' <- convType env reexported ty2
pure . HsParTy noExt . noLoc $ HsAppTy noExt (noLoc ty1') (noLoc ty2')
LF.TBuiltin builtinTy -> convBuiltInTy env builtinTy
LF.TForall {..} -> do
binder <- convTyVarBinder env forallBinder
body <- convType env reexported forallBody
pure . HsParTy noExt . noLoc $ HsForAllTy noExt [binder] (noLoc body)
ty@(LF.TStruct fls)
| isConstraint ty -> do
fieldTys <- mapM (convTypeLiftingConstraintTuples . snd) fls
pure $ HsTupleTy noExt HsConstraintTuple (map noLoc fieldTys)
| otherwise ->
error ("Unexpected: Bare LF struct type that does not represent constraint tuple in data-dependencies. " <> show ty)
LF.TNat n -> pure $
HsTyLit noExt (HsNumTy NoSourceText (LF.fromTypeLevelNat n))
where
convTypeLiftingConstraintTuples :: LF.Type -> Gen (HsType GhcPs)
convTypeLiftingConstraintTuples = \case
ty@(LF.TStruct fls) | isConstraint ty -> do
-- A constraint tuple. We need to lift it up to a type synonym
-- when it occurs in a function domain, otherwise GHC will
-- expand it out as a regular constraint.
-- See issue https://github.com/digital-asset/daml/issues/9663
let freeVars = map LF.unTypeVarName . Set.toList $ LF.freeVars ty
fieldTys <- mapM (convTypeLiftingConstraintTuples . snd) fls
tupleTyName <- freshTypeName env
emitHsDecl . noLoc . TyClD noExt $ SynDecl
{ tcdSExt = noExt
, tcdLName = tupleTyName
, tcdTyVars = HsQTvs noExt $ map mkUserTyVar freeVars
, tcdFixity = Prefix
, tcdRhs = noLoc $ HsTupleTy noExt HsConstraintTuple (map noLoc fieldTys)
}
pure $ foldl'
(\ accum freeVar ->
HsParTy noExt
. noLoc . HsAppTy noExt (noLoc accum)
. noLoc . HsTyVar noExt NotPromoted
$ mkRdrName freeVar )
(HsTyVar noExt NotPromoted tupleTyName)
freeVars
ty ->
convType env reexported ty
mkTuple :: Int -> Gen (HsType GhcPs)
mkTuple i =
pure $ HsTyVar noExt NotPromoted $
noLoc $ mkRdrUnqual $ occName $ tupleTyConName BoxedTuple i
convBuiltInTy :: Env -> LF.BuiltinType -> Gen (HsType GhcPs)
convBuiltInTy env =
\case
LF.BTInt64 -> mkGhcType env "Int"
LF.BTDecimal -> mkGhcType env "Decimal"
LF.BTText -> mkGhcType env "Text"
LF.BTTimestamp -> mkLfInternalType env "Time"
LF.BTDate -> mkLfInternalType env "Date"
LF.BTParty -> mkLfInternalType env "Party"
LF.BTUnit -> pure $ mkTyConTypeUnqual unitTyCon
LF.BTBool -> mkGhcType env "Bool"
LF.BTList -> pure $ mkTyConTypeUnqual listTyCon
LF.BTUpdate -> mkLfInternalType env "Update"
LF.BTScenario -> mkLfInternalType env "Scenario"
LF.BTContractId -> mkLfInternalType env "ContractId"
LF.BTOptional -> mkLfInternalPrelude env "Optional"
LF.BTTextMap -> mkLfInternalType env "TextMap"
LF.BTGenMap -> mkLfInternalType env "Map"
LF.BTArrow -> pure $ mkTyConTypeUnqual funTyCon
LF.BTNumeric -> mkGhcType env "Numeric"
LF.BTAny -> mkLfInternalType env "Any"
LF.BTTypeRep -> mkLfInternalType env "TypeRep"
LF.BTRoundingMode -> mkGhcType env "RoundingMode"
LF.BTBigNumeric -> mkGhcType env "BigNumeric"
LF.BTAnyException -> mkLfInternalType env "AnyException"
errTooManyNameComponents :: [T.Text] -> a
errTooManyNameComponents cs =
error $
"Internal error: Dalf contains type constructors with more than two name components: " <>
(T.unpack $ T.intercalate "." cs)
convKind :: Env -> LF.Kind -> Gen (LHsKind GhcPs)
convKind env = \case
LF.KStar -> pure . noLoc $ HsStarTy noExt False
LF.KNat -> noLoc <$> mkGhcType env "Nat"
LF.KArrow k1 k2 -> do
k1' <- convKind env k1
k2' <- convKind env k2
pure . noLoc . HsParTy noExt . noLoc $ HsFunTy noExt k1' k2'
convTyVarBinder :: Env -> (LF.TypeVarName, LF.Kind) -> Gen (LHsTyVarBndr GhcPs)
convTyVarBinder env = \case
(LF.TypeVarName tyVar, LF.KStar) ->
pure $ mkUserTyVar tyVar
(LF.TypeVarName tyVar, kind) ->
mkKindedTyVar tyVar <$> convKind env kind
mkUserTyVar :: T.Text -> LHsTyVarBndr GhcPs
mkUserTyVar =
noLoc .
UserTyVar noExt . noLoc . mkRdrUnqual . mkOccName tvName . T.unpack
mkKindedTyVar :: T.Text -> LHsKind GhcPs -> LHsTyVarBndr GhcPs
mkKindedTyVar name = noLoc .
(KindedTyVar noExt . noLoc . mkRdrUnqual . mkOccName tvName $ T.unpack name)
mkRdrName :: T.Text -> Located RdrName
mkRdrName = noLoc . mkRdrUnqual . mkOccName varName . T.unpack
sumProdRecords :: LF.Module -> MS.Map [T.Text] [(LF.FieldName, LF.Type)]
sumProdRecords m =
MS.fromList
[ (dataTyCon, fs)
| LF.DefDataType {..} <- NM.toList $ LF.moduleDataTypes m
, let dataTyCon = LF.unTypeConName dataTypeCon
, length dataTyCon == 2
, LF.DataRecord fs <- [dataCons]
]