Converting functions in data dependencies. (digital-asset#4182)

* Converting functions in data dependencies. changelog_begin changelog_end * Add NoOverloadedStrings to the set of extensions in generated packages. * Just use the fn as its own right hand side * Restore order of package map (not that it makes a difference) * Adjust imports * Weird lint but ok * Make the test pass somehow * Dont preprocess enums in GHC.Prim * Preprocess enums everywhere, and add mod ref as needed. * Revert preprocessor changes * Dont expose old-style typeclasses * Dont convert newstyle typeclasses temporarily either * Add test for function importing
axman6 · Jan 27, 2020 · 3c93b5e · 3c93b5e
1 parent 8b7878f
commit 3c93b5e
Show file tree

Hide file tree

Showing 4 changed files with 244 additions and 31 deletions.
diff --git a/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DataDependencies.hs b/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/DataDependencies.hs
@@ -28,6 +28,7 @@ import "ghc-lib-parser" Name
 import "ghc-lib-parser" Outputable (alwaysQualify, ppr, showSDocForUser)
 import "ghc-lib-parser" PrelNames
 import "ghc-lib-parser" RdrName
+import "ghc-lib-parser" TcEvidence (HsWrapper (WpHole))
 import "ghc-lib-parser" TysPrim
 import "ghc-lib-parser" TysWiredIn
 
@@ -37,7 +38,8 @@ import DA.Daml.Preprocessor.Generics
 import SdkVersion
 
 data Env = Env
-    { envGetUnitId :: LF.PackageRef -> UnitId
+    { envPkgs :: MS.Map UnitId LF.Package
+    , envGetUnitId :: LF.PackageRef -> UnitId
     , envStablePackages :: MS.Map LF.PackageId (UnitId, LF.ModuleName)
     , envQualify :: Bool
     , envSdkPrefix :: Maybe String
@@ -63,9 +65,12 @@ generateSrcFromLf env = noLoc mod
             , hsmodHaddockModHeader = Nothing
             , hsmodExports = Nothing
             }
-    decls = do
-        LF.DefDataType {..} <- NM.toList $ LF.moduleDataTypes $ envMod env
-        guard $ LF.getIsSerializable dataSerializable
+
+    decls = dataTypeDecls ++ valueDecls
+
+    dataTypeDecls = do
+        dtype@LF.DefDataType {..} <- 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) $
@@ -77,6 +82,36 @@ generateSrcFromLf env = noLoc mod
         let occName = mkOccName varName $ T.unpack $ sanitize dataTypeCon0
         pure $ mkDataDecl env thisModule occName dataParams (convDataCons dataTypeCon0 dataCons)
 
+    valueDecls = do
+        dval@LF.DefValue {..} <- NM.toList $ LF.moduleValues $ envMod env
+        guard $ shouldExposeDefValue dval
+        let (lfName, lfType) = dvalBinder
+            ltype = noLoc $ convType env lfType :: LHsType GhcPs
+            lname = mkRdrName (LF.unExprValName lfName) :: Located RdrName
+            sig = TypeSig noExt [lname] (HsWC noExt $ HsIB noExt ltype)
+            lsigD = noLoc $ SigD noExt sig :: LHsDecl GhcPs
+            lexpr = noLoc $ HsPar noExt $ noLoc $ HsVar noExt lname :: LHsExpr GhcPs
+            lgrhs = noLoc $ GRHS noExt [] lexpr :: LGRHS GhcPs (LHsExpr GhcPs)
+            grhss = GRHSs noExt [lgrhs] (noLoc $ EmptyLocalBinds noExt)
+            matchContext = FunRhs lname Prefix NoSrcStrict
+            lmatch = noLoc $ Match noExt matchContext [] Nothing grhss
+            lalts = noLoc [lmatch]
+            bind = FunBind noExt lname (MG noExt lalts Generated) WpHole []
+            lvalD = noLoc $ ValD noExt bind :: LHsDecl GhcPs
+        [ lsigD, lvalD ]
+
+    shouldExposeDefDataType :: LF.DefDataType -> Bool
+    shouldExposeDefDataType typeDef
+        = not (defDataTypeIsOldTypeClass typeDef)
+
+    shouldExposeDefValue :: LF.DefValue -> Bool
+    shouldExposeDefValue LF.DefValue{..}
+        | (lfName, lfType) <- dvalBinder
+        = not (LF.getIsTest dvalIsTest)
+        && not ("$" `T.isPrefixOf` LF.unExprValName lfName)
+        && not (typeHasOldTypeclass env lfType)
+        && (LF.moduleNameString lfModName /= "GHC.Prim")
+
     convDataCons :: T.Text -> LF.DataCons -> [LConDecl GhcPs]
     convDataCons dataTypeCon0 = \case
             LF.DataRecord fields ->
@@ -132,19 +167,40 @@ generateSrcFromLf env = noLoc mod
         ]
     isStable LF.PRSelf = False
     isStable (LF.PRImport pkgId) = pkgId `MS.member` envStablePackages env
-    modRefs =
-        nubSort $
-        [ (isStable pkg, envGetUnitId env pkg, LF.ModuleName (["CurrentSdk" | isStable pkg] <> LF.unModuleName modRef))
-        | typeDef <- NM.toList $ LF.moduleDataTypes $ envMod env
-        -- We only care about references from serializable types
-        -- since those are the only ones that we reconstruct.
-        , LF.getIsSerializable (LF.dataSerializable typeDef)
-        , (pkg, modRef) <- toListOf monoTraverse typeDef
-        ] ++
-        (map (\t -> (\(a,b) -> (True,a,b)) $ builtinToModuleRef t) $
-         concat $ do
-             dataTy <- NM.toList $ LF.moduleDataTypes $ envMod env
-             pure $ toListOf (dataConsType . builtinType) $ LF.dataCons dataTy)
+
+    modRefs :: [(Bool, GHC.UnitId, LF.ModuleName)]
+    modRefs = nubSort . concat . concat $
+        [ [ modRefsFromDefDataType typeDef
+          | typeDef <- NM.toList (LF.moduleDataTypes (envMod env))
+          , shouldExposeDefDataType typeDef ]
+        , [ modRefsFromDefValue valueDef
+          | valueDef <- NM.toList (LF.moduleValues (envMod env))
+          , shouldExposeDefValue valueDef ]
+        ]
+
+    modRefsFromDefDataType :: LF.DefDataType -> [(Bool, GHC.UnitId, LF.ModuleName)]
+    modRefsFromDefDataType typeDef = concat
+        [ [ (isStable pkg, envGetUnitId env pkg, modRef)
+          | (pkg, modRef) <- toListOf monoTraverse typeDef ]
+        , [ (True, pkg, modRef)
+          | b <- toListOf (dataConsType . builtinType) (LF.dataCons typeDef)
+          , (pkg, modRef) <- [builtinToModuleRef b] ]
+        , [ (True, primUnitId, sdkGhcTypes)
+          | LF.DataEnum [_] <- [LF.dataCons typeDef]
+          ] -- ^ single constructor enums spawn a reference to
+            -- CurrentSdk.GHC.Types.DamlEnum in the daml-preprocessor.
+        ]
+
+    modRefsFromDefValue :: LF.DefValue -> [(Bool, GHC.UnitId, LF.ModuleName)]
+    modRefsFromDefValue LF.DefValue{..} | (_, dvalType) <- dvalBinder = concat
+        [ [ (isStable pkg, envGetUnitId env pkg, modRef)
+          | (pkg, modRef) <- toListOf monoTraverse dvalType ]
+        , [ (True, pkg, modRef)
+          | b <- toListOf builtinType dvalType
+          , (pkg, modRef) <- [builtinToModuleRef b] ]
+        ]
+
+    builtinToModuleRef :: LF.BuiltinType -> (GHC.UnitId, LF.ModuleName)
     builtinToModuleRef = \case
             LF.BTInt64 -> (primUnitId, sdkGhcTypes)
             LF.BTDecimal -> (primUnitId, sdkGhcTypes)
@@ -367,12 +423,13 @@ mkTyConTypeUnqual = mkTyConType False
 
 -- | Generate the full source for a daml-lf package.
 generateSrcPkgFromLf ::
-       (LF.PackageRef -> UnitId)
+       MS.Map UnitId LF.Package
+    -> (LF.PackageRef -> UnitId)
     -> MS.Map LF.PackageId (UnitId, LF.ModuleName)
     -> Maybe String
     -> LF.Package
     -> [(NormalizedFilePath, String)]
-generateSrcPkgFromLf getUnitId stablePkgs mbSdkPrefix pkg = do
+generateSrcPkgFromLf pkgs getUnitId stablePkgs mbSdkPrefix pkg = do
     mod <- NM.toList $ LF.packageModules pkg
     let fp =
             toNormalizedFilePath $
@@ -384,10 +441,11 @@ generateSrcPkgFromLf getUnitId stablePkgs mbSdkPrefix pkg = do
           (showSDocForUser fakeDynFlags alwaysQualify $
            ppr $ generateSrcFromLf $ env mod))
   where
-    env m = Env getUnitId stablePkgs True mbSdkPrefix m
+    env m = Env pkgs getUnitId stablePkgs True mbSdkPrefix m
     header =
-        ["{-# LANGUAGE NoDamlSyntax #-}"
+        [ "{-# LANGUAGE NoDamlSyntax #-}"
         , "{-# LANGUAGE NoImplicitPrelude #-}"
+        , "{-# LANGUAGE NoOverloadedStrings #-}"
         , "{-# LANGUAGE TypeOperators #-}"
         , "{-# OPTIONS_GHC -Wno-unused-imports #-}"
         ]
@@ -424,7 +482,8 @@ generateGenInstancesPkgFromLf getUnitId stablePkgs mbSdkPrefix pkgId pkg qual =
     catMaybes
         [ generateGenInstanceModule
             Env
-                { envGetUnitId = getUnitId
+                { envPkgs = MS.empty -- for now at least, since this doesn't care about type definitions in other packages like generateSrcFromLf does
+                , envGetUnitId = getUnitId
                 , envStablePackages = stablePkgs
                 , envQualify = False
                 , envMod = mod
@@ -480,3 +539,75 @@ splitUnitId unitId = fromMaybe (unitId, Nothing) $ do
     (name, ver) <- stripInfixEnd "-" unitId
     guard $ all (`elem` '.' : ['0' .. '9']) ver
     pure (name, Just ver)
+
+-- | Returns 'True' if an LF type contains a reference to an
+-- old-style typeclass. See 'tconIsOldTypeclass' for more details.
+typeHasOldTypeclass :: Env -> LF.Type -> Bool
+typeHasOldTypeclass env = \case
+    LF.TVar _ -> False
+    LF.TCon tcon -> tconIsOldTypeclass env tcon
+    LF.TSynApp _ _ -> True
+        -- Type synonyms came after the switch to new-style
+        -- typeclasses, so we can assume there are no old-style
+        -- typeclasses being referenced. HOWEVER, we don't support
+        -- type synonyms here yet. TODO: Fix this, and change
+        -- the above to False.
+    LF.TApp a b -> typeHasOldTypeclass env a || typeHasOldTypeclass env b
+    LF.TBuiltin _ -> False
+    LF.TForall _ b -> typeHasOldTypeclass env b
+    LF.TStruct fields -> any (typeHasOldTypeclass env . snd) fields
+    LF.TNat _ -> False
+
+-- | Determine whether a typecon refers to an old-style
+-- typeclass. By "old-style" I mean a typeclass based on
+-- nominal LF record types. There's no foolproof way of
+-- determining this, but we can approximate it by taking
+-- advantage of the typeclass sanitization that is introduced
+-- during LF conversion: every field in a typeclass dictionary
+-- is represented by a type @() -> _@ due to sanitization.
+-- Thus, if a type is given by a record, and the record has
+-- at least one field, and every field in the record is a
+-- function from unit, then there's a good chance this
+-- record represents an old-style typeclass.
+--
+-- The caveat here is that if a user creates a record that
+-- matches these criteria, it will be treated as an old-style
+-- typeclass and therefore any functions that use this type
+-- will not be exposed via the data-dependency mechanism,
+-- (see 'generateSrcFromLf').
+tconIsOldTypeclass :: Env -> LF.Qualified LF.TypeConName -> Bool
+tconIsOldTypeclass env tcon =
+    case envLookupDataType tcon env of
+        Nothing -> error ("Unknown reference to type " <> show tcon)
+        Just dtype -> defDataTypeIsOldTypeClass dtype
+
+defDataTypeIsOldTypeClass :: LF.DefDataType -> Bool
+defDataTypeIsOldTypeClass LF.DefDataType{..}
+    | LF.DataRecord fields <- dataCons
+    = notNull fields && all isDesugarField fields
+
+    | otherwise
+    = False
+  where
+    isDesugarField :: (LF.FieldName, LF.Type) -> Bool
+    isDesugarField (_fieldName, fieldType) =
+        case fieldType of
+            LF.TUnit LF.:-> _ -> True
+            _ -> False
+
+
+envLookupDataType :: LF.Qualified LF.TypeConName -> Env -> Maybe LF.DefDataType
+envLookupDataType tcon env = do
+    mod <- envLookupModuleOf tcon env
+    NM.lookup (LF.qualObject tcon) (LF.moduleDataTypes mod)
+
+envLookupModuleOf :: LF.Qualified a -> Env -> Maybe LF.Module
+envLookupModuleOf qual = envLookupModule (LF.qualPackage qual) (LF.qualModule qual)
+
+envLookupModule :: LF.PackageRef -> LF.ModuleName -> Env -> Maybe LF.Module
+envLookupModule pkgRef modName env = do
+    pkg <- envLookupPackage pkgRef env
+    NM.lookup modName (LF.packageModules pkg)
+
+envLookupPackage :: LF.PackageRef -> Env -> Maybe LF.Package
+envLookupPackage ref env = MS.lookup (envGetUnitId env ref) (envPkgs env)
diff --git a/compiler/damlc/lib/DA/Cli/Damlc.hs b/compiler/damlc/lib/DA/Cli/Damlc.hs
@@ -806,14 +806,27 @@ execGenerateSrc opts dalfOrDar mbOutDir = Command GenerateSrc Nothing effect
         (pkgId, pkg) <- decode bytes
         opts <- mkOptions opts
         logger <- getLogger opts "generate-src"
-        (pkgMap0, stablePkgIds) <- withDamlIdeState opts { optScenarioService = EnableScenarioService False } logger diagnosticsLogger $ \ideState -> runAction ideState $ do
-          pkgs <-
-              MS.fromList . map (\(unitId, dalfPkg) -> (LF.dalfPackageId dalfPkg, unitId)) . MS.toList <$>
-              useNoFile_ GeneratePackageMap
-          stablePkgIds <- fmap (MS.fromList . map (\(k, pkg) -> (LF.dalfPackageId pkg, k)) . MS.toList) (useNoFile_ GenerateStablePackages)
-          pure (pkgs `MS.union` MS.map fst stablePkgIds, stablePkgIds)
-        let pkgMap = MS.insert pkgId unitId pkgMap0
-        let genSrcs = generateSrcPkgFromLf (getUnitId unitId pkgMap) stablePkgIds (Just "CurrentSdk") pkg
+
+        (dalfPkgMap, stableDalfPkgMap) <- withDamlIdeState opts { optScenarioService = EnableScenarioService False } logger diagnosticsLogger $ \ideState -> runAction ideState $ do
+            dalfPkgMap <- useNoFile_ GeneratePackageMap
+            stableDalfPkgMap <- useNoFile_ GenerateStablePackages
+            pure (dalfPkgMap, stableDalfPkgMap)
+
+        let allDalfPkgs =
+                [ (unitId, dalfPkg)
+                | ((unitId, _modName), dalfPkg) <- MS.toList stableDalfPkgMap ]
+                ++ MS.toList dalfPkgMap
+            pkgMap = MS.insert unitId pkg $ MS.fromList
+                [ (unitId, LF.extPackagePkg (LF.dalfPackagePkg dalfPkg))
+                | (unitId, dalfPkg) <- allDalfPkgs ]
+            unitIdMap = MS.insert pkgId unitId $ MS.fromList
+                [ (LF.dalfPackageId dalfPkg, unitId)
+                | (unitId, dalfPkg) <- allDalfPkgs ]
+            stablePkgIds = MS.fromList
+                [ (LF.dalfPackageId dalfPkg, k)
+                | (k, dalfPkg) <- MS.toList stableDalfPkgMap ]
+            genSrcs = generateSrcPkgFromLf pkgMap (getUnitId unitId unitIdMap) stablePkgIds (Just "CurrentSdk") pkg
+
         forM_ genSrcs $ \(path, src) -> do
             let fp = fromMaybe "" mbOutDir </> fromNormalizedFilePath path
             createDirectoryIfMissing True $ takeDirectory fp

diff --git a/compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs b/compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs
@@ -482,17 +482,21 @@ buildLfPackageGraph
        )
 buildLfPackageGraph pkgs stablePkgs = (depGraph,  vertexToNode')
   where
+    -- mapping unit ids to packages
+    unitIdToPkgMap = MS.fromList [(unitId, pkg) | (_pkgId, pkg, _bs, unitId) <- pkgs]
+
     -- mapping from package id's to unit id's. if the same package is imported with
     -- different unit id's, we would loose a unit id here.
     pkgMap = MS.fromList [(pkgId, unitId) | (pkgId, _pkg, _bs, unitId) <- pkgs]
+
     -- order the packages in topological order
     (depGraph, vertexToNode, _keyToVertex) =
         graphFromEdges
             [ (PackageNode src unitId dalf bs, pkgId, pkgRefs)
             | (pkgId, dalf, bs, unitId) <- pkgs
             , let pkgRefs = [ pid | LF.PRImport pid <- toListOf packageRefs dalf ]
             , let getUid = getUnitId unitId pkgMap
-            , let src = generateSrcPkgFromLf getUid stablePkgs (Just currentSdkPrefix) dalf
+            , let src = generateSrcPkgFromLf unitIdToPkgMap getUid stablePkgs (Just currentSdkPrefix) dalf
             ]
     vertexToNode' v = case vertexToNode v of
         -- We don’t care about outgoing edges.

diff --git a/compiler/damlc/tests/src/DA/Test/Packaging.hs b/compiler/damlc/tests/src/DA/Test/Packaging.hs
@@ -736,6 +736,71 @@ dataDependencyTests damlc repl davlDar = testGroup "Data Dependencies" $
         assertBool "proj-0.1.0.dar was not created." =<< doesFileExist dar
         callProcessSilent damlc ["test", "--target=1.dev", "--project-root", projDir, "--generated-src"]
     | withArchiveChoice <- [False, True]
+    ] <>
+    [ testCaseSteps ("Importing toplevel monomorphic template functions from DAML-LF " <> LF.renderVersion depLfVer <> " to " <> LF.renderVersion targetLfVer) $ \step -> withTempDir $ \tmpDir -> do
+          let proja = tmpDir </> "proja"
+          let projb = tmpDir </> "projb"
+
+          step "Build proja"
+          createDirectoryIfMissing True (proja </> "src")
+          writeFileUTF8 (proja </> "src" </> "A.daml") $ unlines
+              [ "daml 1.2"
+              , "module A where"
+              , ""
+              , "template T"
+              , "  with"
+              , "    p : Party"
+              , "  where"
+              , "    signatory p"
+              , ""
+              , "createT = create @T"
+              , "signatoryT = signatory @T"
+              , "archiveT = archive @T"
+              ]
+          writeFileUTF8 (proja </> "daml.yaml") $ unlines
+              [ "sdk-version: " <> sdkVersion
+              , "name: proja"
+              , "version: 0.0.1"
+              , "source: src"
+              , "dependencies: [daml-prim, daml-stdlib]"
+              ]
+          withCurrentDirectory proja $ callProcessSilent damlc ["build", "--target=" <> LF.renderVersion depLfVer, "-o", proja </> "proja.dar"]
+
+          step "Build projb"
+          createDirectoryIfMissing True (projb </> "src")
+          writeFileUTF8 (projb </> "src" </> "B.daml") $ unlines
+              [ "daml 1.2"
+              , "module B where"
+              , "import A"
+              , "import DA.Assert"
+              , ""
+              , "test = scenario do"
+              , "  alice <- getParty \"Alice\""
+              , "  let t = T alice"
+              , "  signatoryT t === [alice]"
+              , "  cid <- submit alice $ createT t"
+              , "  submit alice $ archiveT cid"
+              ]
+          writeFileUTF8 (projb </> "daml.yaml") $ unlines
+              [ "sdk-version: " <> sdkVersion
+              , "name: projb"
+              , "version: 0.0.1"
+              , "source: src"
+              , "dependencies: [daml-prim, daml-stdlib]"
+              , "data-dependencies: [" <> show (proja </> "proja.dar") <> "]"
+              ]
+          withCurrentDirectory projb $ callProcessSilent damlc
+            [ "build", "--target=" <> LF.renderVersion targetLfVer, "-o", projb </> "projb.dar"
+            , "--hide-all-packages"
+            , "--package", "daml-prim"
+            , "--package", damlStdlib
+            , "--package", "proja-0.0.1"
+            ]
+          callProcessSilent repl ["validate", projb </> "projb.dar"]
+
+    | depLfVer <- LF.supportedOutputVersions
+    , targetLfVer <- LF.supportedOutputVersions
+    , targetLfVer >= depLfVer
     ]