diff --git a/dhall-lsp-server/src/Dhall/LSP/Backend/Dhall.hs b/dhall-lsp-server/src/Dhall/LSP/Backend/Dhall.hs index cf2c96e..86328b6 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Backend/Dhall.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Backend/Dhall.hs @@ -8,7 +8,6 @@ module Dhall.LSP.Backend.Dhall ( fromNormal, Cache, emptyCache, - cacheExpr, invalidate, DhallError(..), parse, @@ -28,15 +27,15 @@ import qualified Dhall.Parser.Token as Dhall import qualified Dhall.Parser as Dhall import qualified Dhall.TypeCheck as Dhall -import qualified Text.Dot as Dot +import qualified Data.Graph as Graph import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import qualified Network.URI as URI import qualified Language.Haskell.LSP.Types as LSP.Types import qualified Data.Text as Text import qualified Text.Megaparsec as Megaparsec import Data.List.NonEmpty (NonEmpty((:|))) -import Crypto.Hash (Digest, SHA256) import Data.Text (Text) import System.FilePath (splitDirectories, takeFileName, takeDirectory) import Lens.Family (view, set) @@ -77,23 +76,16 @@ newtype WellTyped = WellTyped {fromWellTyped :: Expr Src X} -- | A fully normalised expression. newtype Normal = Normal {fromNormal :: Expr Src X} +-- An import graph, represented by list of import dependencies. +type ImportGraph = [Dhall.Depends] + -- | A cache maps Dhall imports to fully normalised expressions. By reusing -- caches we can speeds up diagnostics etc. significantly! -newtype Cache = Cache (Map.Map Dhall.Import (Dot.NodeId, Expr Src X)) +data Cache = Cache ImportGraph (Map.Map Dhall.Import (Expr Src X)) -- | The initial cache. emptyCache :: Cache -emptyCache = Cache Map.empty - --- | Cache a given normal expression. -cacheExpr :: FileIdentifier -> Normal -> Cache -> Cache -cacheExpr fileid (Normal expr) (Cache c) = - let unhashedImport = importFromFileIdentifier fileid - alpha = Dhall.alphaNormalize expr -- we need to alpha-normalise before - hash = Dhall.hashExpression maxBound alpha -- calculating the hash - hashedImport = hashedImportFromFileIdentifier fileid hash - in Cache $ Map.insert unhashedImport (Dot.userNodeId 0, expr) - $ Map.insert hashedImport (Dot.userNodeId 0, expr) c +emptyCache = Cache [] Map.empty -- Construct the unhashed import corresponding to the given file. importFromFileIdentifier :: FileIdentifier -> Dhall.Import @@ -102,25 +94,39 @@ importFromFileIdentifier (FileIdentifier importType) = importMode = Dhall.Code } --- Construct the hashed import corresponding to the given file. -hashedImportFromFileIdentifier :: FileIdentifier -> Digest SHA256 -> Dhall.Import -hashedImportFromFileIdentifier (FileIdentifier importType) hash = - Dhall.Import { importHashed = Dhall.ImportHashed (Just hash) importType, - importMode = Dhall.Code } - -- | Invalidate any _unhashed_ imports of the given file. Hashed imports are -- kept around as per -- https://github.com/dhall-lang/dhall-lang/blob/master/standard/imports.md. --- Note to future self: this doesn't correctly invalidate reverse --- dependencies, i.e. other cached expressions that imported the invalidated --- one. We need to change the representation of the import graph in --- Dhall.Import in order to be able to implement this correctly! +-- Transitively invalidates any imports depending on the changed file. invalidate :: FileIdentifier -> Cache -> Cache -invalidate (FileIdentifier fileid) (Cache cache) = - Cache $ Map.delete codeImport (Map.delete textImport cache) +invalidate (FileIdentifier fileid) (Cache dependencies cache) = + Cache dependencies' $ Map.withoutKeys cache invalidImports where - codeImport = Dhall.Import (Dhall.ImportHashed Nothing fileid) Dhall.Code - textImport = Dhall.Import (Dhall.ImportHashed Nothing fileid) Dhall.RawText + imports = map Dhall.parent dependencies ++ map Dhall.child dependencies + + adjacencyLists = foldr + -- add reversed edges to adjacency lists + (\(Dhall.Depends parent child) -> Map.adjust (parent :) child) + -- starting from the discrete graph + (Map.fromList [ (i,[]) | i <- imports]) + dependencies + + (graph, importFromVertex, vertexFromImport) = Graph.graphFromEdges + [(node, node, neighbours) | (node, neighbours) <- Map.assocs adjacencyLists] + + -- compute the reverse dependencies, i.e. the imports reachable in the transposed graph + reachableImports import_ = + map (\(i,_,_) -> i) . map importFromVertex . concat $ + do vertex <- vertexFromImport import_ + return (Graph.reachable graph vertex) + + codeImport = Dhall.Import (Dhall.ImportHashed Nothing fileid) Dhall.Code + textImport = Dhall.Import (Dhall.ImportHashed Nothing fileid) Dhall.RawText + invalidImports = Set.fromList $ codeImport : reachableImports codeImport + ++ textImport : reachableImports textImport + + dependencies' = filter (\(Dhall.Depends parent child) -> Set.notMember parent invalidImports + && Set.notMember child invalidImports) dependencies -- | A Dhall error. Covers parsing, resolving of imports, typechecking and -- normalisation. @@ -141,16 +147,18 @@ parseWithHeader = first ErrorParse . Dhall.exprAndHeaderFromText "" -- | Resolve all imports in an expression. load :: FileIdentifier -> Expr Src Dhall.Import -> Cache -> IO (Either DhallError (Cache, Expr Src X)) -load fileid expr (Cache cache) = do +load fileid expr (Cache graph cache) = do let emptyStatus = Dhall.emptyStatus "" - status = -- reuse cache + status = -- reuse cache and import graph set Dhall.cache cache . + set Dhall.graph graph . -- set "root import" set Dhall.stack (importFromFileIdentifier fileid :| []) $ emptyStatus (do (expr', status') <- runStateT (Dhall.loadWith expr) status - let cache' = Cache $ view Dhall.cache status' - return . Right $ (cache', expr')) + let cache' = view Dhall.cache status' + graph' = view Dhall.graph status' + return . Right $ (Cache graph' cache', expr')) `catch` (\e -> return . Left $ ErrorImportSourced e) `catch` (\e -> return . Left $ ErrorInternal e) diff --git a/dhall-lsp-server/src/Dhall/LSP/Handlers.hs b/dhall-lsp-server/src/Dhall/LSP/Handlers.hs index d03d0b9..1866c01 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Handlers.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Handlers.hs @@ -13,8 +13,7 @@ import Dhall.Parser (Src(..)) import Dhall.TypeCheck (X) import Dhall.LSP.Backend.Dhall (FileIdentifier, parse, load, typecheck, - normalize, fileIdentifierFromFilePath, fileIdentifierFromURI, invalidate, - cacheExpr, parseWithHeader) + fileIdentifierFromFilePath, fileIdentifierFromURI, invalidate, parseWithHeader) import Dhall.LSP.Backend.Diagnostics (Range(..), Diagnosis(..), explain, rangeFromDhall, diagnose) import Dhall.LSP.Backend.Formatting (formatExprWithHeader) @@ -198,12 +197,10 @@ diagnosticsHandler uri = do (cache', expr') <- case loaded of Right x -> return x Left err -> throwE err - welltyped <- case typecheck expr' of + _ <- case typecheck expr' of Right (wt, _typ) -> return wt Left err -> throwE err - let normal = normalize welltyped - -- cache the new expression - assign importCache (cacheExpr fileIdentifier normal cache') + assign importCache cache' return Nothing let suggestions = diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 16459d4..d56d9a6 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -111,6 +111,8 @@ module Dhall.Import ( , emptyStatus , stack , cache + , Depends(..) + , graph , manager , standardVersion , normalizer @@ -164,7 +166,6 @@ import Dhall.Core import Dhall.Import.HTTP #endif import Dhall.Import.Types -import Text.Dot ((.->.), userNodeId) import Dhall.Parser (Parser(..), ParseError(..), Src(..), SourcedException(..)) import Dhall.TypeCheck (X(..)) @@ -784,15 +785,10 @@ loadWith expr₀ = case expr₀ of then throwMissingImport (Imported _stack (Cycle import₀)) else do case Map.lookup child _cache of - Just (childNode, expr) -> do - zoom dot . State.modify $ \getDot -> do - parentNode <- getDot - - -- Add edge between parent and child - parentNode .->. childNode - - -- Return parent NodeId - pure parentNode + Just expr -> do + zoom graph . State.modify $ + -- Add the edge `parent -> child` to the import graph + \edges -> Depends parent child : edges pure expr Nothing -> do @@ -831,29 +827,14 @@ loadWith expr₀ = case expr₀ of let stackWithNewImport = NonEmpty.cons newImport _stack - let childNodeId = userNodeId _nextNodeId - - -- Increment the next node id - zoom nextNodeId $ State.modify succ - - -- Make current node the dot graph - zoom dot . State.put $ importNode childNodeId child - zoom stack (State.put stackWithNewImport) expr'' <- loadWith resolvedExpression zoom stack (State.put _stack) - zoom dot . State.modify $ \getSubDot -> do - parentNode <- _dot - - -- Get current node back from sub-graph - childNode <- getSubDot - - -- Add edge between parent and child - parentNode .->. childNode - - -- Return parent NodeId - pure parentNode + zoom graph . State.modify $ + -- Add the edge `parent -> newImport` to the import graph, + -- where `newImport` is `child` with normalized headers. + \edges -> Depends parent newImport : edges _cacher child expr'' @@ -870,7 +851,7 @@ loadWith expr₀ = case expr₀ of expr''' <- case Dhall.TypeCheck.typeWith _startingContext expr'' of Left err -> throwM (Imported _stack' err) Right _ -> return (Dhall.Core.normalizeWith _normalizer expr'') - zoom cache (State.modify' (Map.insert child (childNodeId, expr'''))) + zoom cache (State.modify' (Map.insert child expr''')) return expr''' case hash (importHashed import₀) of diff --git a/dhall/src/Dhall/Import/Types.hs b/dhall/src/Dhall/Import/Types.hs index 3da97b5..8f33ff7 100644 --- a/dhall/src/Dhall/Import/Types.hs +++ b/dhall/src/Dhall/Import/Types.hs @@ -22,13 +22,11 @@ import Dhall.Core , ImportMode (..) , ImportType (..) , ReifiedNormalizer(..) - , pretty ) import Dhall.Parser (Src) import Dhall.TypeCheck (X) import Lens.Family (LensLike') import System.FilePath (isRelative, splitDirectories) -import Text.Dot (Dot, NodeId, userNode, userNodeId) import qualified Dhall.Binary import qualified Dhall.Context @@ -43,19 +41,20 @@ data Resolved = Resolved -- downstream imports } +-- | `parent` imports (i.e. depends on) `child` +data Depends = Depends { parent :: Import, child :: Import } + -- | State threaded throughout the import process data Status m = Status { _stack :: NonEmpty Import -- ^ Stack of `Import`s that we've imported along the way to get to the -- current point - , _dot :: Dot NodeId - -- ^ Graph of all the imports visited so far + , _graph :: [Depends] + -- ^ Graph of all the imports visited so far, represented by a list of + -- import dependencies. - , _nextNodeId :: Int - -- ^ Next node id to be used for the dot graph generation - - , _cache :: Map Import (NodeId, Expr Src X) + , _cache :: Map Import (Expr Src X) -- ^ Cache of imported expressions with their node id in order to avoid -- importing the same expression twice with different values @@ -83,9 +82,7 @@ emptyStatusWith _resolver _cacher rootDirectory = Status {..} where _stack = pure rootImport - _dot = importNode (userNodeId 0) rootImport - - _nextNodeId = 1 + _graph = [] _cache = Map.empty @@ -114,26 +111,13 @@ emptyStatusWith _resolver _cacher rootDirectory = Status {..} , importMode = Code } -importNode :: NodeId -> Import -> Dot NodeId -importNode nodeId i = do - userNode - nodeId - [ ("label", Data.Text.unpack $ pretty i) - , ("shape", "box") - , ("style", "rounded") - ] - pure nodeId - stack :: Functor f => LensLike' f (Status m) (NonEmpty Import) stack k s = fmap (\x -> s { _stack = x }) (k (_stack s)) -dot :: Functor f => LensLike' f (Status m) (Dot NodeId) -dot k s = fmap (\x -> s { _dot = x }) (k (_dot s)) +graph :: Functor f => LensLike' f (Status m) [Depends] +graph k s = fmap (\x -> s { _graph = x }) (k (_graph s)) -nextNodeId :: Functor f => LensLike' f (Status m) Int -nextNodeId k s = fmap (\x -> s { _nextNodeId = x }) (k (_nextNodeId s)) - -cache :: Functor f => LensLike' f (Status m) (Map Import (NodeId, Expr Src X)) +cache :: Functor f => LensLike' f (Status m) (Map Import (Expr Src X)) cache k s = fmap (\x -> s { _cache = x }) (k (_cache s)) manager :: Functor f => LensLike' f (Status m) (Maybe Dynamic) diff --git a/dhall/src/Dhall/Main.hs b/dhall/src/Dhall/Main.hs index 6be10b1..aa2d586 100644 --- a/dhall/src/Dhall/Main.hs +++ b/dhall/src/Dhall/Main.hs @@ -21,14 +21,15 @@ module Dhall.Main import Control.Applicative (optional, (<|>)) import Control.Exception (SomeException) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid ((<>)) import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty) import Data.Version (showVersion) import Dhall.Binary (StandardVersion) -import Dhall.Core (Expr(..), Import) +import Dhall.Core (Expr(..), Import, pretty) import Dhall.Freeze (Intent(..), Scope(..)) -import Dhall.Import (Imported(..)) +import Dhall.Import (Imported(..), Depends(..)) import Dhall.Parser (Src) import Dhall.Pretty (Ann, CharacterSet(..), annToAnsiStyle, layoutOpts) import Dhall.TypeCheck (DetailedTypeError(..), TypeError, X) @@ -36,6 +37,7 @@ import Lens.Family (set) import Options.Applicative (Parser, ParserInfo) import System.Exit (exitFailure) import System.IO (Handle) +import Text.Dot ((.->.)) import qualified Codec.CBOR.JSON import qualified Codec.CBOR.Read @@ -389,12 +391,31 @@ command (Options {..}) = do Resolve { resolveMode = Just Dot, ..} -> do expression <- getExpression file - (Dhall.Import.Types.Status { _dot}) <- + (Dhall.Import.Types.Status { _graph, _stack }) <- State.execStateT (Dhall.Import.loadWith expression) (toStatus file) - putStr . ("strict " <>) . Text.Dot.showDot $ - Text.Dot.attribute ("rankdir", "LR") >> - _dot + let (rootImport :| _) = _stack + imports = rootImport : map parent _graph ++ map child _graph + importIds = Data.Map.fromList (zip imports [Text.Dot.userNodeId i | i <- [0..]]) + + let dotNode (i, nodeId) = + Text.Dot.userNode + nodeId + [ ("label", Data.Text.unpack $ pretty i) + , ("shape", "box") + , ("style", "rounded") + ] + + let dotEdge (Depends parent child) = + case (Data.Map.lookup parent importIds, Data.Map.lookup child importIds) of + (Just from, Just to) -> from .->. to + _ -> pure () + + let dot = do Text.Dot.attribute ("rankdir", "LR") + mapM_ dotNode (Data.Map.assocs importIds) + mapM_ dotEdge _graph + + putStr . ("strict " <>) . Text.Dot.showDot $ dot Resolve { resolveMode = Just ListImmediateDependencies, ..} -> do expression <- getExpression file