Skip to content
Snippets Groups Projects
Select Git revision
  • 3bcc4a608e078733c210e8927421b255a6829cad
  • main default protected
  • 75389691-a67c-422a-91e9-aa58bfb5-main-patch-32205
  • test-pipe
  • extended-scripts
  • structured-badges
  • guix-pipeline
  • cabal-pipeline
8 results

Substitute.hs

Blame
  • Dirgraph.hs 2.94 KiB
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE LambdaCase       #-}
    {-# LANGUAGE TupleSections    #-}
    
    -- | Simple directed graphs, for dependency checking
    module Dirgraph where
    
    import           Universum
    
    import           CheckMap        (MapResult (mapresultDepends))
    import           Data.Map.Strict (mapMaybeWithKey, mapWithKey, traverseWithKey)
    import qualified Data.Map.Strict as M
    import           Data.Set        ((\\))
    import qualified Data.Set        as S
    import           Paths           (normalise)
    import           Text.Dot        (Dot, (.->.))
    import qualified Text.Dot        as D
    import           Types           (Dep (LocalMap))
    
    -- | a simple directed graph
    type Graph a = Map a (Set a)
    
    nodes :: Graph a -> Set a
    nodes = M.keysSet
    
    -- | simple directed graph of exits
    resultToGraph :: Map FilePath (MapResult a) -> Graph FilePath
    resultToGraph = fmap (S.fromList . mapMaybe onlyLocalMaps . mapresultDepends)
      where onlyLocalMaps = \case
              LocalMap path -> Just (normalise "" path)
              _             -> Nothing
    
    -- | invert edges of a directed graph
    invertGraph :: (Eq a, Ord a) => Graph a -> Graph a
    invertGraph graph = mapWithKey collectFroms graph
      where collectFroms to _ = S.fromList . elems . mapMaybeWithKey (select to) $ graph
            select to from elems = if to `elem` elems then Just from else Nothing
    
    -- | all nodes reachable from some entrypoint
    reachableFrom :: Ord a => a -> Graph a -> Set a
    reachableFrom entrypoint graph = recursive mempty (S.singleton entrypoint)
      where recursive seen current
              | null current = seen
              | otherwise    = recursive (S.union seen current) (next \\ seen)
              where next = S.unions
                     . S.fromList -- for some reason set is not filterable?
                     . mapMaybe (`M.lookup` graph)
                     . S.toList
                     $ current
    
    unreachableFrom :: Ord a => a -> Graph a -> Set a
    unreachableFrom entrypoint graph =
      nodes graph \\ reachableFrom entrypoint graph
    
    takeSubGraph :: (Eq a, Ord a) => Int -> a -> Graph a -> Graph a
    takeSubGraph i start graph
      | i <= 0 = mempty
      | i == 1 =
        M.singleton start reachable
        `M.union` M.fromList ((,mempty) <$> S.toList reachable)
      | otherwise =
        M.singleton start reachable
        `M.union` (M.unionsWith S.union
                   . S.map (flip (takeSubGraph (i-1)) graph)
                   $ reachable)
      where reachable = fromMaybe mempty (M.lookup start graph)
    
    graphToDot :: Graph FilePath -> Dot ()
    graphToDot graph = do
      main <- D.node [("label","main.json")]
      nodes' <- M.traverseMaybeWithKey
        (\name edges -> if name /= "main.json"
          then D.node [("label",name)] <&> (, edges) <&> Just
          else pure Nothing
        )
        graph
    
      let reachable = fromMaybe mempty (M.lookup "main.json" graph)
      let nodes = M.insert "main.json" (main,reachable) nodes'
      forM_ nodes $ \(node, edges) ->
        forM_ edges $ \key ->
          case M.lookup key nodes of
            Just (other,_) -> node .->. other
            _              -> pure ()