Skip to content

Commit

Permalink
daml2ts : Better multi-dar support (digital-asset#4641)
Browse files Browse the repository at this point in the history 
* Step (1) Add error detection for different names/same package

changelog_begin
changelog_end

* Step (2) : Generate TS for a package once and only once.
  • Loading branch information
@shayne-fletcher
shayne-fletcher authored Feb 21, 2020
1 parent c03ded3 commit 6d6b632
Show file tree
Hide file tree
Showing 3 changed files with 155 additions and 50 deletions.
103 changes: 55 additions & 48 deletions language-support/ts/codegen/src/TsCodeGenMain.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,6 +14,7 @@ import qualified Data.Text.Extended as T
import qualified "zip-archive" Codec.Archive.Zip as Zip
import qualified Data.Map as Map

import Control.Monad
import Control.Monad.Extra
import DA.Daml.LF.Ast
import DA.Daml.LF.Ast.Optics
Expand Down Expand Up @@ -47,63 +48,62 @@ optionsParserInfo = info (optionsParser <**> helper)
<> progDesc "Generate TypeScript bindings from a DAR"
)

readPackages :: [FilePath] -> IO [(PackageId, (Package, Maybe String))]
readPackages dars = concatMapM readPackage dars
where
readPackage dar = do
dar <- B.readFile dar
let archive = Zip.toArchive $ BSL.fromStrict dar
dalfs <- either fail pure $ DAR.readDalfs archive
DAR.DalfManifest{packageName} <- either fail pure $ DAR.readDalfManifest archive
forM ((DAR.mainDalf dalfs, packageName) : map (, Nothing) (DAR.dalfs dalfs)) $
\(dalf, mbPkgName) -> do
(pkgId, pkg) <- either (fail . show) pure $ Archive.decodeArchive Archive.DecodeAsMain (BSL.toStrict dalf)
pure (pkgId, (pkg, mbPkgName))

mergePackageMap :: [(PackageId, (Package, Maybe String))] -> Either String (Map.Map PackageId (Maybe String, Package))
mergePackageMap ps = foldM merge Map.empty ps
where
merge :: Map.Map PackageId (Maybe String, Package) -> (PackageId, (Package, Maybe String)) -> Either String (Map.Map PackageId (Maybe String, Package))
merge pkgs (pkgId, (pkg, mbPkgName)) = do
let pkgNames = mapMaybe fst (Map.elems pkgs)
-- Check if there is a package with the same name but a
-- different package id.
whenJust mbPkgName $ \name -> when (pkgId `Map.notMember` pkgs && name `elem` pkgNames) $
Left $ "Duplicate name '" <> name <> "' for different packages detected"
let update mbOld = case mbOld of
Nothing -> pure (Just (mbPkgName, pkg))
Just (mbOldPkgName, _) -> do
-- Check if we have colliding names for the same
-- package.
whenJust (liftA2 (,) mbOldPkgName mbPkgName) $ \(name1, name2) ->
when (name1 /= name2) $ Left $ "Different names ('" <> name1 <> "' and '" <> name2 <> "') for the same package detected"
pure (Just (mbOldPkgName <|> mbPkgName, pkg))
Map.alterF update pkgId pkgs

main :: IO ()
main = do
opts@Options{..} <- execParser optionsParserInfo
foldM_ (processDar opts) Map.empty optInputDars
where
-- Generate the ts for a single DAR. 'processed' is a map of
-- package ids of processed DALFs (the same package can appear
-- in multiple DARs - avoid regenerating them where possible).
processDar :: Options -> Map.Map PackageId [String] -> FilePath -> IO (Map.Map PackageId [String])
processDar opts pkgs dar = do
dar <- B.readFile dar
let archive = Zip.toArchive $ BSL.fromStrict dar
dalfs <- either fail pure $ DAR.readDalfs archive
DAR.DalfManifest{packageName} <- either fail pure $ DAR.readDalfManifest archive
let allDalfsInDar = (DAR.mainDalf dalfs, packageName) : map (, Nothing) (DAR.dalfs dalfs)
foldM (processDalf opts) pkgs allDalfsInDar

-- Generate the ts for a single DALF. Avoid generating it
-- multiple times where possible.
processDalf :: Options -> Map.Map PackageId [String] -> (BSL.ByteString, Maybe String) -> IO (Map.Map PackageId [String])
processDalf opts pkgs (dalf, mbPkgName) = do
-- If a package id is in 'pkgs' it means it has been
-- processed at least once. The list it is associated with
-- is the set of names it's been written as (for example, as
-- its hash if it's depended upon and perhaps also as a human
-- readable string if it's the main package of a DAR).
(pkgId, pkg) <- either (fail . show) pure $ Archive.decodeArchive Archive.DecodeAsMain (BSL.toStrict dalf)
let pkgNames = concat (Map.elems pkgs)
gen <- case Map.lookup pkgId pkgs of
Nothing -> do
maybe (return ()) (\name -> when (name `elem` pkgNames) $
fail $ "Duplicate name '" <> name <> "' for different packages detected") mbPkgName
return True
Just names -> do
maybe (return ()) (\name -> when (name `notElem` names && name `elem` pkgNames) $
fail $ "Duplicate name '" <> name <> "' for different packages detected") mbPkgName
return (fromMaybe (show $ unPackageId pkgId) mbPkgName `notElem` names)
ps <- readPackages optInputDars
case mergePackageMap ps of
Left err -> fail err
Right pm ->
forM_ (Map.toList pm) $
\(pkgId, (mbPkgName, pkg)) -> do
let id = show $ unPackageId pkgId
let name = fromMaybe id mbPkgName
let asName = if name == id then "itself" else name
if gen
then do
putStrLn $ "Generating " <> id <> " as " <> asName
daml2ts opts pkgId pkg mbPkgName
return $ Map.insertWith (++) pkgId [name] pkgs
else do
putStrLn $ "Skipping generation of " <> id <> " as " <> asName
return pkgs
putStrLn $ "Generating " <> id <> " as " <> asName
daml2ts opts pm pkgId pkg mbPkgName

daml2ts :: Options -> PackageId -> Package -> Maybe String -> IO ()
daml2ts Options{..} pkgId pkg mbPkgName = do
daml2ts :: Options -> Map.Map PackageId (Maybe String, Package) -> PackageId -> Package -> Maybe String -> IO ()
daml2ts Options{..} pm pkgId pkg mbPkgName = do
let outputDir = optOutputDir </> fromMaybe (T.unpack (unPackageId pkgId)) mbPkgName
createDirectoryIfMissing True outputDir
T.writeFileUtf8 (outputDir </> "packageId.ts") $ T.unlines
["export default '" <> unPackageId pkgId <> "';"]
forM_ (packageModules pkg) $ \mod -> do
whenJust (genModule pkgId mod) $ \modTxt -> do
whenJust (genModule pm pkgId mod) $ \modTxt -> do
let outputFile = outputDir </> joinPath (map T.unpack (unModuleName (moduleName mod))) FP.<.> "ts"
createDirectoryIfMissing True (takeDirectory outputFile)
T.writeFileUtf8 outputFile modTxt
Expand All @@ -115,8 +115,8 @@ infixr 6 <.> -- This is the same fixity as '<>'.
(<.>) :: T.Text -> T.Text -> T.Text
(<.>) u v = u <> "." <> v

genModule :: PackageId -> Module -> Maybe T.Text
genModule curPkgId mod
genModule :: Map.Map PackageId (Maybe String, Package) -> PackageId -> Module -> Maybe T.Text
genModule pm curPkgId mod
| null serDefs = Nothing
| otherwise =
let curModName = moduleName mod
Expand All @@ -139,7 +139,14 @@ genModule curPkgId mod
| modRef@(pkgRef, modName) <- Set.toList ((PRSelf, curModName) `Set.delete` Set.unions refs)
, let pkgRefStr = case pkgRef of
PRSelf -> ""
PRImport pkgId -> "../" <> unPackageId pkgId <> "/"
PRImport pkgId ->
-- If the imported package has a symbolic name,
-- then we need to use it in the package path.
"../" <> (case Map.lookup pkgId pm of
Just (Just name, _) -> T.pack name
Just (Nothing, _) -> unPackageId pkgId
Nothing -> error "IMPOSSIBLE : package map malformed"
) <> "/"
, let modNameStr = genModuleRef modRef
]
defs = map (\(def, ser) -> def ++ ser) defSers
Expand Down
100 changes: 99 additions & 1 deletion language-support/ts/codegen/tests/src/DA/Test/Daml2Ts.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -64,7 +64,7 @@ tests damlc daml2ts davl = testGroup "daml2Ts"
assertBool "'Grover.ts' was not created." =<< doesFileExist (groverTs </> "grover-1.0" </> "Grover.ts")
assertBool "'packageId.ts' was not created." =<< doesFileExist (groverTs </> "grover-1.0" </> "packageId.ts")

, testCaseSteps "Dependency test" $ \step -> withTempDir $ \tmpDir -> do
, testCaseSteps "Dependency test" $ \step -> withTempDir $ \tmpDir -> do
let grover = tmpDir </> "grover"
let groverDar = grover </> ".daml" </> "dist" </> "grover-1.0.dar"
step "Creating project 'grover'..."
Expand Down Expand Up @@ -201,6 +201,104 @@ tests damlc daml2ts davl = testGroup "daml2Ts"
(exitCode, _, err) <- readProcessWithExitCode daml2ts ([groverDar, elmoDar] ++ ["-o", elmoTs]) ""
assertBool "A name collision error was expected." (exitCode /= ExitSuccess && isJust (stripInfix "Duplicate name 'grover-1.0' for different packages detected" err))

, testCaseSteps "Different names for the same package test" $ \step -> withTempDir $ \tmpDir -> do
let grover = tmpDir </> "grover"
let groverDar = grover </> ".daml" </> "dist" </> "grover-1.0.dar"
step "Creating project 'grover'..."
createDirectoryIfMissing True (grover </> "daml")
writeFileUTF8 (grover </> "daml" </> "Grover.daml") $ unlines
[ "daml 1.2"
, "module Grover where"
, "template Grover"
, " with puppeteer : Party"
, " where"
, " signatory puppeteer"
, " choice Grover_GoSuper: ContractId Grover"
, " controller puppeteer"
, " do"
, " return self"
]
writeFileUTF8 (grover </> "daml.yaml") $ unlines
[ "sdk-version: " <> sdkVersion
, "name: grover"
, "version: \"1.0\""
, "source: daml"
, "exposed-modules: [Grover]"
, "dependencies:"
, " - daml-prim"
, " - daml-stdlib"
]
buildProject grover []
assertBool "grover-1.0.dar was not created." =<< doesFileExist groverDar
let superGrover = tmpDir </> "super-grover"
let superGroverDar = superGrover </> ".daml" </> "dist" </> "super-grover-1.0.dar"
step "Creating project 'superGrover'..."
createDirectoryIfMissing True (superGrover </> "daml")
writeFileUTF8 (superGrover </> "daml" </> "Grover.daml") $ unlines
[ "daml 1.2"
, "module Grover where"
, "template Grover"
, " with puppeteer : Party"
, " where"
, " signatory puppeteer"
, " choice Grover_GoSuper: ContractId Grover"
, " controller puppeteer"
, " do"
, " return self"
]
writeFileUTF8 (superGrover </> "daml.yaml") $ unlines
[ "sdk-version: " <> sdkVersion
, "name: super-grover"
, "version: \"1.0\""
, "source: daml"
, "exposed-modules: [Grover]"
, "dependencies:"
, " - daml-prim"
, " - daml-stdlib"
]
buildProject superGrover []
assertBool "super-grover-1.0.dar was not created." =<< doesFileExist superGroverDar
step "Generating TypeScript of 'grover' and 'super-grover'..."
let charliesRestaurantTs = tmpDir </> "charlies-restaurant-ts"
createDirectoryIfMissing True charliesRestaurantTs
(exitCode, _, err) <- readProcessWithExitCode daml2ts ([groverDar, superGroverDar] ++ ["-o", charliesRestaurantTs]) ""
assertBool "An error resulting from the same name for different packages was expected." (exitCode /= ExitSuccess && isJust (stripInfix "Different names ('grover-1.0' and 'super-grover-1.0') for the same package detected" err))

, testCaseSteps "Same package, same name test" $ \step -> withTempDir $ \tmpDir -> do
let grover = tmpDir </> "grover"
let groverDar = grover </> ".daml" </> "dist" </> "grover-1.0.dar"
step "Creating project 'grover'..."
createDirectoryIfMissing True (grover </> "daml")
writeFileUTF8 (grover </> "daml" </> "Grover.daml") $ unlines
[ "daml 1.2"
, "module Grover where"
, "template Grover"
, " with puppeteer : Party"
, " where"
, " signatory puppeteer"
, " choice Grover_GoSuper: ContractId Grover"
, " controller puppeteer"
, " do"
, " return self"
]
writeFileUTF8 (grover </> "daml.yaml") $ unlines
[ "sdk-version: " <> sdkVersion
, "name: grover"
, "version: \"1.0\""
, "source: daml"
, "exposed-modules: [Grover]"
, "dependencies:"
, " - daml-prim"
, " - daml-stdlib"
]
buildProject grover []
assertBool "grover-1.0.dar was not created." =<< doesFileExist groverDar
step "Generating TypeScript of 'grover' and 'grover'..."
let charliesRestaurantTs = tmpDir </> "charlies-restaurant-ts"
createDirectoryIfMissing True charliesRestaurantTs
daml2tsProject [groverDar, groverDar] charliesRestaurantTs
assertBool "'Grover.ts' was not created." =<< doesFileExist (charliesRestaurantTs </> "grover-1.0" </> "Grover.ts")

, testCase "DAVL test" $ withTempDir $ \tmpDir -> do
let davlTs = tmpDir </> "davl-ts"
createDirectoryIfMissing True davlTs
Expand Down
2 changes: 1 addition & 1 deletion language-support/ts/codegen/tests/watch-daml2ts.sh
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,4 +8,4 @@ DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
DAR=$DIR/daml/.daml/dist/daml-1.0.0.dar
GEN=$DIR/ts/generated/src/daml

ghcid --command "da-ghci //:daml2ts" --reload $DAR --test ":main -o $GEN --main-package-name daml-tests $DAR"
ghcid --command "da-ghci //:daml2ts" --reload $DAR --test ":main -o $GEN $DAR"

0 comments on commit 6d6b632

Please sign in to comment.