Skip to content

Commit

Permalink
Fix handling of packages in damlc visual (digital-asset#5789)
Browse files Browse the repository at this point in the history 
* Fix handling of packages in damlc visual

Previously we just ran the analysis on the modules of the main
package. This failed for obvious reasons as soon as you reference a
template from another package which happens pretty
frequently (e.g. for anything that uses finlib).

This PR fixes this to run the analysis on the whole World which is
self-contained. This required a bunch of reshuffling to make sure that
we always reference fully qualified identifiers but most of it is
very mechanical.

Note that currently you cannot distinguish between templates with
identical names in the resulting graph (they will be separate but you
have no idea which one is which). This was already an issue
before if you have the same template name in different modules so I
consider this an orthogonal issue.

This fixes the expected failure we already had and I added another
test that checks that colliding template names do at least show up as
separate nodes in the graph. I also manually tested this against
ex-bond-issuance.

Disclaimier: I’m aware that the code is very messy but I tried to
resist the urge to rewrite it completely and only change what was
necessary.

fixes digital-asset#5776

changelog_begin

- [DAML Compiler] ``damlc visual`` now works properly in projects
  consisting of multiple packages.

changelog_end

* Rename templateChoiceId to templateId

changelog_begin
changelog_end
  • Loading branch information
@cocreature
cocreature authored May 4, 2020
1 parent 4c99f67 commit 8f9cdee
Show file tree
Hide file tree
Showing 7 changed files with 184 additions and 90 deletions.
7 changes: 6 additions & 1 deletion compiler/daml-lf-ast/src/DA/Daml/LF/Ast/World.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,6 +7,7 @@ module DA.Daml.LF.Ast.World(
World,
DalfPackage(..),
getWorldSelf,
getWorldImported,
initWorld,
initWorldSelf,
extendWorldSelf,
Expand Down Expand Up @@ -42,10 +43,12 @@ data World = World
, _worldSelf :: Package
}


getWorldSelf :: World -> Package
getWorldSelf = _worldSelf

makeLensesFor [("_worldSelf","worldSelf")] ''World
getWorldImported :: World -> [ExternalPackage]
getWorldImported world = map (uncurry ExternalPackage) $ HMS.toList (_worldImported world)

-- | A package where all references to `PRSelf` have been rewritten
-- to `PRImport`.
Expand All @@ -56,6 +59,8 @@ data ExternalPackage = ExternalPackage

instance NFData ExternalPackage

makeLensesFor [("_worldSelf","worldSelf")] ''World

data DalfPackage = DalfPackage
{ dalfPackageId :: PackageId
, dalfPackagePkg :: ExternalPackage
Expand Down
6 changes: 2 additions & 4 deletions compiler/damlc/daml-ide-core/test/Development/IDE/Core/API/Testing.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -526,11 +526,9 @@ timedSection targetDiffTime block = do
expectedGraph :: D.NormalizedFilePath -> ExpectedGraph -> ShakeTest ()
expectedGraph damlFilePath expectedGraph = do
ideState <- ShakeTest $ Reader.asks steService
mbDalf <- liftIO $ API.runActionSync ideState (API.getDalf damlFilePath)
expectNoErrors
Just lfPkg <- pure mbDalf
wrld <- Reader.liftIO $ API.runActionSync ideState (API.worldForFile damlFilePath)
whenLeft (graphTest wrld lfPkg expectedGraph) $ throwError . ExpectedGraphProps
expectNoErrors
whenLeft (graphTest wrld expectedGraph) $ throwError . ExpectedGraphProps

-- | Example testing scenario.
example :: ShakeTest ()
Expand Down
7 changes: 3 additions & 4 deletions compiler/damlc/daml-ide-core/test/Development/IDE/Core/API/Testing/Visualize.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,7 +12,6 @@ module Development.IDE.Core.API.Testing.Visualize

import Control.Monad
import Data.Bifunctor
import qualified Data.NameMap as NM
import qualified Data.Text as T

import qualified DA.Daml.LF.Ast as LF
Expand Down Expand Up @@ -57,9 +56,9 @@ data FailedGraphExpectation = FailedGraphExpectation
}
deriving (Eq, Show)

graphTest :: LF.World -> LF.Package -> ExpectedGraph -> Either FailedGraphExpectation ()
graphTest wrld pkg expectedGraph = do
let actualGraph = V.graphFromModule (NM.toList $ LF.packageModules pkg) wrld
graphTest :: LF.World -> ExpectedGraph -> Either FailedGraphExpectation ()
graphTest wrld expectedGraph = do
let actualGraph = V.graphFromWorld wrld
let actual = graphToExpectedGraph actualGraph
unless (expectedGraph == actual) $
Left $ FailedGraphExpectation expectedGraph actual
14 changes: 3 additions & 11 deletions compiler/damlc/daml-ide/src/DA/Daml/LanguageServer/Visualize.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,15 +11,11 @@ import Development.IDE.LSP.Server
import Development.IDE.Types.Logger
import qualified Data.Text as T
import Development.IDE.Core.Rules
import Development.IDE.Core.Rules.Daml
import Development.IDE.Core.Service.Daml
import Development.IDE.Core.Shake
import Development.IDE.Core.RuleTypes.Daml
import Language.Haskell.LSP.Messages
import qualified Language.Haskell.LSP.Core as LSP
import Development.IDE.Types.Location
import qualified Data.Map.Strict as Map
import qualified Data.NameMap as NM
import qualified DA.Daml.LF.Ast as LF
import qualified DA.Daml.Visual as Visual

collectTexts :: List Aeson.Value -> Maybe NormalizedFilePath
Expand All @@ -35,12 +31,8 @@ onCommand ide execParsms = case execParsms of
case collectTexts _arguments of
Just mod -> do
logInfo (ideLogger ide) "Generating visualization for current daml project"
WhnfPackage package <- runAction ide (use_ GeneratePackage mod)
pkgMap <- runAction ide (use_ GeneratePackageMap mod)
let modules = NM.toList $ LF.packageModules package
let extpkgs = map LF.dalfPackagePkg $ Map.elems pkgMap
let wrld = LF.initWorldSelf extpkgs package
let dots = T.pack $ Visual.dotFileGen modules wrld
world <- runAction ide (worldForFile mod)
let dots = T.pack $ Visual.dotFileGen world
return $ Right $ Aeson.String dots
Nothing -> do
logError (ideLogger ide) "Expected a single module to visualize, got multiple module"
Expand Down
1 change: 1 addition & 0 deletions compiler/damlc/daml-visual/BUILD.bazel
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,6 +17,7 @@ da_haskell_library(
"containers",
"extra",
"filepath",
"mtl",
"open-browser",
"text",
"safe",
Expand Down
158 changes: 96 additions & 62 deletions compiler/damlc/daml-visual/src/DA/Daml/Visual.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,15 +12,14 @@ module DA.Daml.Visual
, SubGraph(..)
, ChoiceDetails(..)
, dotFileGen
, graphFromModule
, graphFromWorld
, execVisualHtml
) where


import qualified DA.Daml.LF.Ast as LF
import DA.Daml.LF.Ast.World as AST
import DA.Daml.LF.Reader
import Data.Bifunctor (bimap)
import qualified Data.NameMap as NM
import qualified Data.Set as Set
import qualified DA.Pretty as DAP
Expand All @@ -31,6 +30,7 @@ import qualified Data.ByteString as B
import Data.Generics.Uniplate.Data
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import Data.Tuple.Extra (both)
import GHC.Generics
import Data.Aeson
import Text.Mustache
Expand All @@ -41,32 +41,33 @@ import DA.Bazel.Runfiles
import System.FilePath
import Safe
import Control.Monad
import Control.Monad.State

type IsConsuming = Bool
type InternalChcName = LF.ChoiceName

data Action = ACreate (LF.Qualified LF.TypeConName)
| AExercise (LF.Qualified LF.TypeConName) LF.ChoiceName deriving (Eq, Ord, Show )

data ChoiceAndAction = ChoiceAndAction
{ choiceName :: LF.ChoiceName
, internalChcName :: InternalChcName -- as we have choices with same name across modules
, choiceConsuming :: IsConsuming
, actions :: Set.Set Action
} deriving (Show)


data TemplateChoices = TemplateChoices
{ template :: LF.Template
, modName :: LF.ModuleName
{ template :: LF.Qualified LF.Template
, choiceAndActions :: [ChoiceAndAction]
} deriving (Show)

templateId :: TemplateChoices -> LF.Qualified LF.TypeConName
templateId TemplateChoices{..} =
fmap LF.tplTypeCon template

data ChoiceDetails = ChoiceDetails
{ nodeId :: Int
, consuming :: Bool
, displayChoiceName :: LF.ChoiceName
, uniqChoiceName :: InternalChcName
} deriving (Show, Eq)

data SubGraph = SubGraph
Expand Down Expand Up @@ -190,13 +191,14 @@ templatePossibleUpdates :: LF.World -> LF.Template -> [ChoiceAndAction]
templatePossibleUpdates world tpl = map toActions $ NM.toList $ LF.tplChoices tpl
where toActions c = ChoiceAndAction {
choiceName = LF.chcName c
, internalChcName = LF.ChoiceName $ tplNameUnqual tpl <> (LF.unChoiceName .LF.chcName) c
, choiceConsuming = LF.chcConsuming c
, actions = startFromChoice world c
}

moduleAndTemplates :: LF.World -> LF.Module -> [TemplateChoices]
moduleAndTemplates world mod = map (\t -> TemplateChoices t (LF.moduleName mod) (templatePossibleUpdates world t)) $ NM.toList $ LF.moduleTemplates mod
moduleAndTemplates :: LF.World -> LF.PackageRef -> LF.Module -> [TemplateChoices]
moduleAndTemplates world pkgRef mod =
map (\t -> TemplateChoices (LF.Qualified pkgRef (LF.moduleName mod) t) (templatePossibleUpdates world t))
(NM.toList $ LF.moduleTemplates mod)

dalfBytesToPakage :: BSL.ByteString -> ExternalPackage
dalfBytesToPakage bytes = case Archive.decodeArchive Archive.DecodeAsDependency $ BSL.toStrict bytes of
Expand All @@ -213,25 +215,40 @@ darToWorld Dalfs{..} = case Archive.decodeArchive Archive.DecodeAsMain $ BSL.toS
tplNameUnqual :: LF.Template -> T.Text
tplNameUnqual LF.Template {..} = headNote "tplNameUnqual" (LF.unTypeConName tplTypeCon)

choiceNameWithId :: [TemplateChoices] -> Map.Map InternalChcName ChoiceDetails
choiceNameWithId tplChcActions = Map.fromList choiceWithIds
where choiceWithIds = zipWith (\ChoiceAndAction {..} id -> (internalChcName, ChoiceDetails id choiceConsuming choiceName internalChcName)) choiceActions [0..]
choiceActions = concatMap (\t -> createChoice (template t) : choiceAndActions t) tplChcActions
createChoice tpl = ChoiceAndAction
{ choiceName = LF.ChoiceName "Create"
, internalChcName = LF.ChoiceName $ tplNameUnqual tpl <> "_Create"
, choiceConsuming = False
, actions = Set.empty
}

nodeIdForChoice :: Map.Map LF.ChoiceName ChoiceDetails -> LF.ChoiceName -> ChoiceDetails
data ChoiceIdentifier = ChoiceIdentifier
{ choiceIdTemplate :: !(LF.Qualified LF.TypeConName)
, choiceIdName :: !LF.ChoiceName
} deriving (Eq, Show, Ord)

choiceNameWithId :: [TemplateChoices] -> Map.Map ChoiceIdentifier ChoiceDetails
choiceNameWithId tplChcActions = Map.unions (evalState (mapM f tplChcActions) 0)
where
f :: TemplateChoices -> State Int (Map.Map ChoiceIdentifier ChoiceDetails)
f tpl@TemplateChoices{..} = do
choices <- forM (createChoice : choiceAndActions) $ \ChoiceAndAction{..} -> do
id <- get
put (id + 1)
let choiceId = ChoiceIdentifier (templateId tpl) choiceName
pure (choiceId, ChoiceDetails id choiceConsuming choiceName)
pure (Map.fromList choices)
createChoice = ChoiceAndAction
{ choiceName = LF.ChoiceName "Create"
, choiceConsuming = False
, actions = Set.empty
}

nodeIdForChoice :: Map.Map ChoiceIdentifier ChoiceDetails -> ChoiceIdentifier -> ChoiceDetails
nodeIdForChoice nodeLookUp chc = case Map.lookup chc nodeLookUp of
Just node -> node
Nothing -> error "Template node lookup failed"

addCreateChoice :: TemplateChoices -> Map.Map LF.ChoiceName ChoiceDetails -> ChoiceDetails
addCreateChoice TemplateChoices {..} lookupData = nodeIdForChoice lookupData tplNameCreateChoice
where tplNameCreateChoice = LF.ChoiceName $ T.pack $ DAP.renderPretty (headNote "addCreateChoice" (LF.unTypeConName (LF.tplTypeCon template))) ++ "_Create"
addCreateChoice :: TemplateChoices -> Map.Map ChoiceIdentifier ChoiceDetails -> ChoiceDetails
addCreateChoice tpl@TemplateChoices{..} lookupData = nodeIdForChoice lookupData tplNameCreateChoice
where
tplNameCreateChoice =
ChoiceIdentifier
(templateId tpl)
createChoiceName

labledField :: T.Text -> T.Text -> T.Text
labledField fname "" = fname
Expand All @@ -250,29 +267,38 @@ typeConFields qName world = case LF.lookupDataType qName world of
LF.DataEnum _ -> [""]
Left _ -> error "malformed template constructor"

constructSubgraphsWithLables :: LF.World -> Map.Map LF.ChoiceName ChoiceDetails -> TemplateChoices -> SubGraph
constructSubgraphsWithLables wrld lookupData tpla@TemplateChoices {..} = SubGraph nodesWithCreate fieldsInTemplate template
where choicesInTemplate = map internalChcName choiceAndActions
fieldsInTemplate = typeConFields qualTpl wrld
nodes = map (nodeIdForChoice lookupData) choicesInTemplate
qualTpl = LF.Qualified LF.PRSelf modName (LF.tplTypeCon template)
nodesWithCreate = addCreateChoice tpla lookupData : nodes

tplNamet :: LF.TypeConName -> T.Text
tplNamet tplConName = headNote "tplNamet" (LF.unTypeConName tplConName)

actionToChoice :: Action -> LF.ChoiceName
actionToChoice (ACreate LF.Qualified {..}) = LF.ChoiceName $ tplNamet qualObject <> "_Create"
actionToChoice (AExercise LF.Qualified {..} (LF.ChoiceName chcT)) = LF.ChoiceName $ tplNamet qualObject <> chcT

choiceActionToChoicePairs :: ChoiceAndAction -> [(LF.ChoiceName, LF.ChoiceName)]
choiceActionToChoicePairs ChoiceAndAction{..} = pairs
where pairs = map (\ac -> (internalChcName, actionToChoice ac)) (Set.elems actions)

graphEdges :: Map.Map LF.ChoiceName ChoiceDetails -> [TemplateChoices] -> [(ChoiceDetails, ChoiceDetails)]
graphEdges lookupData tplChcActions = map (bimap (nodeIdForChoice lookupData) (nodeIdForChoice lookupData)) choicePairsForTemplates
where chcActionsFromAllTemplates = concatMap choiceAndActions tplChcActions
choicePairsForTemplates = concatMap choiceActionToChoicePairs chcActionsFromAllTemplates
constructSubgraphsWithLables :: LF.World -> Map.Map ChoiceIdentifier ChoiceDetails -> TemplateChoices -> SubGraph
constructSubgraphsWithLables wrld lookupData tpla@TemplateChoices {..} =
SubGraph (addCreateChoice tpla lookupData : choices) fieldsInTemplate (LF.qualObject template)
where
fieldsInTemplate = typeConFields (templateId tpla) wrld
choicesInTemplate =
map (\c -> ChoiceIdentifier (templateId tpla) (choiceName c))
choiceAndActions
choices = map (nodeIdForChoice lookupData) choicesInTemplate

createChoiceName :: LF.ChoiceName
createChoiceName = LF.ChoiceName "Create"

actionToChoice :: Action -> ChoiceIdentifier
actionToChoice (ACreate tpl@LF.Qualified {..}) =
ChoiceIdentifier tpl createChoiceName
actionToChoice (AExercise tpl chcT) =
ChoiceIdentifier tpl chcT

choiceActionToChoicePairs :: LF.Qualified LF.TypeConName -> ChoiceAndAction -> [(ChoiceIdentifier, ChoiceIdentifier)]
choiceActionToChoicePairs tpl ChoiceAndAction{..} =
map (\a -> (choiceId, actionToChoice a)) (Set.elems actions)
where
choiceId = ChoiceIdentifier tpl choiceName

graphEdges :: Map.Map ChoiceIdentifier ChoiceDetails -> [TemplateChoices] -> [(ChoiceDetails, ChoiceDetails)]
graphEdges lookupData tplChcActions =
map (both (nodeIdForChoice lookupData)) $
concat $
concatMap
(\tpl -> map (choiceActionToChoicePairs (templateId tpl)) (choiceAndActions tpl))
tplChcActions

subGraphHeader :: SubGraph -> String
subGraphHeader sg = "subgraph cluster_" ++ (DAP.renderPretty $ head (LF.unTypeConName $ LF.tplTypeCon $ clusterTemplate sg)) ++ "{\n"
Expand Down Expand Up @@ -304,15 +330,24 @@ constructDotGraph graph = "digraph G {\ncompound=true;\n" ++ "rankdir=LR;\n"++
edgesLines = unlines $ map (uncurry drawEdge) (edges graph)
graphLines = subgraphsLines ++ edgesLines

graphFromModule :: [LF.Module] -> LF.World -> Graph
graphFromModule modules world = Graph subGraphs edges
where templatesAndModules = concatMap (moduleAndTemplates world) modules
nodes = choiceNameWithId templatesAndModules
subGraphs = map (constructSubgraphsWithLables world nodes) templatesAndModules
edges = graphEdges nodes templatesAndModules

dotFileGen :: [LF.Module] -> LF.World -> String
dotFileGen modules world = constructDotGraph $ graphFromModule modules world
graphFromWorld :: LF.World -> Graph
graphFromWorld world = Graph subGraphs edges
where
templatesAndModules = concat
[ moduleAndTemplates world pkgRef mod
| (pkgRef, pkg) <- pkgs
, mod <- NM.toList $ LF.packageModules pkg
]
nodes = choiceNameWithId templatesAndModules
subGraphs = map (constructSubgraphsWithLables world nodes) templatesAndModules
edges = graphEdges nodes templatesAndModules
pkgs =
(LF.PRSelf, getWorldSelf world)
: map (\ExternalPackage{..} -> (LF.PRImport extPackageId, extPackagePkg))
(getWorldImported world)

dotFileGen :: LF.World -> String
dotFileGen world = constructDotGraph $ graphFromWorld world

webPageTemplate :: T.Text
webPageTemplate =
Expand Down Expand Up @@ -355,8 +390,7 @@ execVisualHtml darFilePath webFilePath oBrowser = do
d3js <- readFile $ staticDir </> "d3.min.js"
d3plusjs <- readFile $ staticDir </> "d3plus.min.js"
let world = darToWorld dalfs
modules = NM.toList $ LF.packageModules $ getWorldSelf world
graph = graphFromModule modules world
graph = graphFromWorld world
d3G = graphToD3Graph graph
linksJson = DT.decodeUtf8 $ BSL.toStrict $ encode $ d3links d3G
nodesJson = DT.decodeUtf8 $ BSL.toStrict $ encode $ d3nodes d3G
Expand All @@ -375,7 +409,7 @@ execVisual darFilePath dotFilePath = do
darBytes <- B.readFile darFilePath
dalfs <- either fail pure $ readDalfs $ ZIPArchive.toArchive (BSL.fromStrict darBytes)
let world = darToWorld dalfs
modules = NM.toList $ LF.packageModules $ getWorldSelf world
result = dotFileGen world
case dotFilePath of
Just outDotFile -> writeFile outDotFile (dotFileGen modules world)
Nothing -> putStrLn (dotFileGen modules world)
Just outDotFile -> writeFile outDotFile result
Nothing -> putStrLn result
Loading

0 comments on commit 8f9cdee

Please sign in to comment.