digital-asset/daml
1
1
Fork 0
mirror of https://github.com/digital-asset/daml.git synced 2024-09-20 09:17:43 +03:00
Code Issues Projects Releases Wiki Activity

Refactor Env construction in LFConversion. (#12092)

Browse Source 
Use RecordWildCards to avoid repetition, and enforce consistent naming.

changelog_begin
changelog_end
This commit is contained in:
Sofia Faro 2021-12-10 11:04:08 +00:00 committed by GitHub
parent 99c6be5272
commit 178411d0c5
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
1 changed files with 21 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion.hs
View File

@ -506,7 +506,7 @@ convertModule
-> [GHC.Module] -> [GHC.Module]
-> ModDetails -> ModDetails
-> Either FileDiagnostic LF.Module -> Either FileDiagnostic LF.Module
convertModule lfVersion pkgMap stablePackages isGenerated file x depOrphanModules details = runConvertM (ConversionEnv file Nothing) $ do convertModule envLfVersion envPkgMap envStablePackages envIsGenerated file x depOrphanModules details = runConvertM (ConversionEnv file Nothing) $ do
definitions <- concatMapM (\bind -> resetFreshVarCounters >> convertBind env bind) binds definitions <- concatMapM (\bind -> resetFreshVarCounters >> convertBind env bind) binds
types <- concatMapM (convertTypeDef env) (eltsUFM (cm_types x)) types <- concatMapM (convertTypeDef env) (eltsUFM (cm_types x))
depOrphanModules <- convertDepOrphanModules env depOrphanModules depOrphanModules <- convertDepOrphanModules env depOrphanModules
@ -522,11 +522,11 @@ convertModule lfVersion pkgMap stablePackages isGenerated file x depOrphanModule
++ interfaces ++ interfaces
++ depOrphanModules ++ depOrphanModules
++ exports ++ exports
pure (LF.moduleFromDefinitions lfModName (Just $ fromNormalizedFilePath file) flags defs) pure (LF.moduleFromDefinitions envLFModuleName (Just $ fromNormalizedFilePath file) flags defs)
where where
ghcModName = GHC.moduleName $ cm_module x envGHCModuleName = GHC.moduleName $ cm_module x
thisUnitId = GHC.moduleUnitId $ cm_module x envModuleUnitId = GHC.moduleUnitId $ cm_module x
lfModName = convertModuleName ghcModName envLFModuleName = convertModuleName envGHCModuleName
flags = LF.daml12FeatureFlags flags = LF.daml12FeatureFlags
binds = binds =
[ bind [ bind
@ -538,23 +538,23 @@ convertModule lfVersion pkgMap stablePackages isGenerated file x depOrphanModule
| otherwise -> [(name, body)] | otherwise -> [(name, body)]
Rec binds -> binds Rec binds -> binds
] ]
interfaceCons = interfaceNames lfVersion (eltsUFM (cm_types x)) envInterfaces = interfaceNames envLfVersion (eltsUFM (cm_types x))
tplImplements = MS.fromListWith (++) envImplements = MS.fromListWith (++)
[ (mkTypeCon [getOccText tpl], [iface]) [ (mkTypeCon [getOccText tpl], [iface])
| (name, _val) <- binds | (name, _val) <- binds
, "_implements_" `T.isPrefixOf` getOccText name , "_implements_" `T.isPrefixOf` getOccText name
, TypeCon implementsT [TypeCon tpl [], TypeCon iface []] <- [varType name] , TypeCon implementsT [TypeCon tpl [], TypeCon iface []] <- [varType name]
, NameIn DA_Internal_Desugar "ImplementsT" <- [implementsT] , NameIn DA_Internal_Desugar "ImplementsT" <- [implementsT]
] ]
ifaceRequires = MS.fromListWith (++) envRequires = MS.fromListWith (++)
[ (mkTypeCon [getOccText iface1], [iface2]) [ (mkTypeCon [getOccText iface1], [iface2])
| (name, _val) <- binds | (name, _val) <- binds
, "_requires_" `T.isPrefixOf` getOccText name , "_requires_" `T.isPrefixOf` getOccText name
, TypeCon requiresT [TypeCon iface1 [], TypeCon iface2 []] <- [varType name] , TypeCon requiresT [TypeCon iface1 [], TypeCon iface2 []] <- [varType name]
, NameIn DA_Internal_Desugar "RequiresT" <- [requiresT] , NameIn DA_Internal_Desugar "RequiresT" <- [requiresT]
] ]
tplInterfaceMethodInstances :: MS.Map (GHC.Module, TypeConName, TypeConName) [(T.Text, GHC.Expr GHC.CoreBndr)] envInterfaceMethodInstances :: MS.Map (GHC.Module, TypeConName, TypeConName) [(T.Text, GHC.Expr GHC.CoreBndr)]
tplInterfaceMethodInstances = MS.fromListWith (++) envInterfaceMethodInstances = MS.fromListWith (++)
[ [
( (mod, mkTypeCon [getOccText iface], mkTypeCon [getOccText tpl]) ( (mod, mkTypeCon [getOccText iface], mkTypeCon [getOccText tpl])
, [(methodName, body)] , [(methodName, body)]
@ -578,48 +578,31 @@ convertModule lfVersion pkgMap stablePackages isGenerated file x depOrphanModule
`App` body `App` body
<- [untick val] <- [untick val]
] ]
choiceData = MS.fromListWith (++) envChoiceData = MS.fromListWith (++)
[ (mkTypeCon [getOccText tplTy], [ChoiceData ty v]) [ (mkTypeCon [getOccText tplTy], [ChoiceData ty v])
| (name, v) <- binds | (name, v) <- binds
, "_choice_" `T.isPrefixOf` getOccText name , "_choice_" `T.isPrefixOf` getOccText name
, ty@(TypeCon _ [_, _, TypeCon _ [TypeCon tplTy _], _]) <- [varType name] , ty@(TypeCon _ [_, _, TypeCon _ [TypeCon tplTy _], _]) <- [varType name]
] ]
ifChoiceData = MS.fromListWith (++) envInterfaceChoiceData = MS.fromListWith (++)
[ (mkTypeCon [getOccText tplTy], [ChoiceData ty v]) [ (mkTypeCon [getOccText tplTy], [ChoiceData ty v])
| (name, v) <- binds | (name, v) <- binds
, "_interface_choice_" `T.isPrefixOf` getOccText name , "_interface_choice_" `T.isPrefixOf` getOccText name
, ty@(TypeCon _ [_, TypeCon _ [TypeCon tplTy _]]) <- [varType name] , ty@(TypeCon _ [_, TypeCon _ [TypeCon tplTy _]]) <- [varType name]
] ]
templateBinds = scrapeTemplateBinds binds envTemplateBinds = scrapeTemplateBinds binds
interfaceBinds = scrapeInterfaceBinds binds envInterfaceBinds = scrapeInterfaceBinds binds
exceptionBinds envExceptionBinds
| lfVersion `supports` featureExceptions = | envLfVersion `supports` featureExceptions =
scrapeExceptionBinds binds scrapeExceptionBinds binds
| otherwise = | otherwise =
MS.empty MS.empty
env = Env envAliases = MS.empty
{ envLFModuleName = lfModName envTypeVars = MS.empty
, envGHCModuleName = ghcModName envTypeVarNames = S.empty
, envModuleUnitId = thisUnitId envModInstanceInfo = modInstanceInfoFromDetails details
, envAliases = MS.empty env = Env {..}
, envPkgMap = pkgMap
, envStablePackages = stablePackages
, envLfVersion = lfVersion
, envInterfaces = interfaceCons
, envInterfaceChoiceData = ifChoiceData
, envTemplateBinds = templateBinds
, envInterfaceBinds = interfaceBinds
, envExceptionBinds = exceptionBinds
, envImplements = tplImplements
, envRequires = ifaceRequires
, envInterfaceMethodInstances = tplInterfaceMethodInstances
, envChoiceData = choiceData
, envIsGenerated = isGenerated
, envTypeVars = MS.empty
, envTypeVarNames = S.empty
, envModInstanceInfo = modInstanceInfoFromDetails details
}
data Consuming = PreConsuming data Consuming = PreConsuming
| Consuming | Consuming