Define encoding/decoding for module imports (#11036)

* Define encoding/decoding for module imports

First step towards closing #10773

changelog_begin
changelog_end

* Update compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/MetadataEncoding.hs

Co-authored-by: Sofia Faro <sofia.faro@digitalasset.com>

compiler/damlc/daml-lf-conversion/BUILD.bazel

@@ -47,6 +47,7 @@ da_haskell_test(
     srcs = glob(["test/**/*.hs"]),
     hackage_deps = [
         "base",
+        "containers",
         "either",
         "ghc-lib-parser",
         "ghc-lib",

compiler/damlc/daml-lf-conversion/src/DA/Daml/LFConversion/MetadataEncoding.hs

@@ -1,6 +1,7 @@
 -- Copyright (c) 2021 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE PatternSynonyms #-}
 
 -- | Encoding/decoding of metadata (i.e. non-semantically-relevant bindings) in LF,
@@ -22,11 +23,15 @@ module DA.Daml.LFConversion.MetadataEncoding
     , encodeOverlapMode
     , decodeOverlapMode
     , mkMetadataStub
+    , moduleImportsName
+    , encodeModuleImports
+    , decodeModuleImports
     ) where
 
 import Safe (readMay)
 import Control.Monad (guard, liftM2)
 import Data.List (sortOn)
+import qualified Data.Set as S
 import qualified Data.Text as T
 
 import qualified "ghc-lib-parser" BasicTypes as GHC
@@ -104,6 +109,10 @@ minimalName (LF.TypeSynName xs) = LF.ExprValName ("$$minimal" <> T.concat xs)
 pattern TEncodedStr :: T.Text -> LF.Type
 pattern TEncodedStr x = LF.TStruct [(LF.FieldName x, LF.TUnit)]
 
+decodeText :: LF.Type -> Maybe T.Text
+decodeText (TEncodedStr x) = Just x
+decodeText _ = Nothing
+
 pattern TEncodedCon :: T.Text -> LF.Type -> LF.Type
 pattern TEncodedCon a b = LF.TStruct [(LF.FieldName a, b)]
 
@@ -153,6 +162,49 @@ decodeOverlapMode = \case
         ]
     _ -> Nothing
 
+--------------------------
+-- INSTANCE PROPAGATION --
+--------------------------
+moduleImportsName :: LF.ExprValName
+moduleImportsName = LF.ExprValName "$$imports"
+
+encodeModuleImports :: S.Set (LF.Qualified ()) -> LF.Type
+encodeModuleImports = encodeTypeList encodeModuleImport . S.toList
+
+encodeModuleImport :: LF.Qualified () -> LF.Type
+encodeModuleImport q =
+    encodeTypeList id
+        [ encodePackageRef (LF.qualPackage q)
+        , encodeModuleName (LF.qualModule q)
+        ]
+
+encodePackageRef :: LF.PackageRef -> LF.Type
+encodePackageRef = \case
+  LF.PRSelf -> LF.TUnit
+  LF.PRImport (LF.PackageId packageId) -> TEncodedStr packageId
+
+encodeModuleName :: LF.ModuleName -> LF.Type
+encodeModuleName (LF.ModuleName components) =
+    encodeTypeList TEncodedStr components
+
+decodeModuleImports :: LF.Type -> Maybe (S.Set (LF.Qualified ()))
+decodeModuleImports = fmap S.fromList . decodeTypeList decodeModuleImport
+
+decodeModuleImport :: LF.Type -> Maybe (LF.Qualified ())
+decodeModuleImport x = do
+    [p, m] <- decodeTypeList Just x
+    packageRef <- decodePackageRef p
+    moduleName <- decodeModuleName m
+    pure (LF.Qualified packageRef moduleName ())
+
+decodePackageRef :: LF.Type -> Maybe LF.PackageRef
+decodePackageRef = \case
+    LF.TUnit -> pure LF.PRSelf
+    TEncodedStr packageId -> pure (LF.PRImport (LF.PackageId packageId))
+    _ -> Nothing
+
+decodeModuleName :: LF.Type -> Maybe LF.ModuleName
+decodeModuleName = fmap LF.ModuleName . decodeTypeList decodeText
 
 ---------------------
 -- STUB GENERATION --

compiler/damlc/daml-lf-conversion/test/DA/Daml/LFConversion/Tests.hs

@@ -10,6 +10,7 @@ import Test.Tasty.HUnit
 import Data.Either.Combinators (whenLeft, whenRight)
 import Data.Maybe (isNothing)
 import Data.Ratio
+import qualified Data.Set as S
 import qualified Data.Text as T
 
 import DA.Daml.LFConversion
@@ -58,8 +59,33 @@ metadataEncodingTests = testGroup "MetadataEncoding"
         , ("overlaps", GHC.Overlaps GHC.NoSourceText)
         , ("incoherent", GHC.Incoherent GHC.NoSourceText)
         ]
+    , roundtripTests "module imports" encodeModuleImports decodeModuleImports
+        [ ("()", S.empty)
+        , ("(Foo.Bar)"
+          , S.fromList
+            [ mkImport Nothing ["Foo", "Bar"]])
+        , ("(\"foo\" Foo.Bar)"
+          , S.fromList
+            [ mkImport (Just "foo") ["Foo", "Bar"]])
+        , ("(Foo.Bar, Baz.Qux.Florp)"
+          , S.fromList
+            [ mkImport Nothing ["Foo", "Bar"]
+            , mkImport Nothing ["Baz", "Qux", "Florp"]])
+        , ("(\"foo\" Foo.Bar, \"baz\" Baz.Qux.Florp)"
+          , S.fromList
+            [ mkImport (Just "foo") ["Foo", "Bar"]
+            , mkImport (Just "baz") ["Baz", "Qux", "Florp"]])
+        ]
     ]
 
+mkImport :: Maybe T.Text -> [T.Text] -> LF.Qualified ()
+mkImport mPackage moduleComponents =
+  LF.Qualified
+    { qualPackage = maybe LF.PRSelf (LF.PRImport . LF.PackageId) mPackage
+    , qualModule = LF.ModuleName moduleComponents
+    , qualObject = ()
+    }
+
 roundtripTests :: (Eq a) => String -> (a -> b) -> (b -> Maybe a) -> [(String, a)] -> TestTree
 roundtripTests groupName encode decode examples =
     roundtripTestsPartial groupName (Just . encode) decode [] examples