----------------------------------------------------------------------------- -- | -- scons2dot - Generates graphviz file of scons dependency information -- Copyright (C) 2008 Leandro Penz -- -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License along -- with this program; if not, write to the Free Software Foundation, Inc., -- 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ----------------------------------------------------------------------------- module Main where import Data.List import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Maybe as Maybe import System.Process import System.IO import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -- PROGRAM_NAME = "scons2dot" -- PROGRAM_VERSION = "0.9" newtype Node = Node ByteString deriving (Eq, Ord) type Level = Int type Properties = (Level, Bool, Bool, Maybe Bool, Bool, Bool, Bool, Bool, Bool, Bool) -- (exists, repository, builder explicit, sideeffect, precious, always, current, noclean, nocache) class BS a where toBS :: a -> ByteString frBS :: ByteString -> a instance BS Node where toBS (Node n) = n frBS = Node lineOk :: ByteString -> Bool lineOk str = not (B.null str) && B.index str 0 == '[' && B.index str 10 == ']' && any ( \ i -> B.index str i == '+') [11, 13, 15] getLevel :: ByteString -> Level getLevel str = quot (B.length $ B.takeWhile ('+' /=) str) 2 getNode :: ByteString -> Node getNode = getNodeInternal . B.unpack where getNodeInternal :: String -> Node getNodeInternal ('+':'-':cs) = Node $ B.pack cs getNodeInternal (_:cs) = getNodeInternal cs getNodeInternal [] = error "Unreachable" getProperties :: Int -> ByteString -> Properties getProperties i str0 = getPropertiesInternal i (B.unpack str0) where getPropertiesInternal level ('[':e:r:b:s:p:a:c:n:h:']':_) = (level, exists, repository, builder, sideeffect, precious, always, current, noclean, nocache) where exists = e == 'E' repository = r == 'R' builder = if b == ' ' then Nothing else Just (b == 'B') sideeffect = s == 'S' precious = p == 'P' always = a == 'A' current = c == 'C' noclean = n == 'N' nocache = h == 'H' getPropertiesInternal _ str = error $ "Unable to parse " ++ str lineInfo :: ByteString -> (Level, Node, Properties) lineInfo str = if B.null str then error "empty str in lineInfo" else (level, getNode str2, getProperties level str) where level = getLevel str2 strskip s = if B.null s then error "empty string in lineInfo strskip" else (if B.head s == '[' then B.dropWhile (']' /=) s else s) str2 = strskip str buildData :: [(Level, Node, Properties)] -> (Set.Set (Node, Node), Map.Map Node Properties) buildData lineinfo = (onlyInteresting folderfinal, mfinal) where (_, _, folderfinal, mfinal) = foldl folder ([], 0, [], Map.empty) lineinfo folder :: ([Node], Int, [(Node, Node, Int, [Node])], Map.Map Node Properties) -> (Level, Node, Properties) -> ([Node], Int, [(Node, Node, Int, [Node])], Map.Map Node Properties) folder (pilha, _, relacoes, m) (newlevel, eu, props) = let newpilha = (drop (length pilha - newlevel) pilha) newrel = [(head newpilha, eu, newlevel, newpilha) | length newpilha > 0 ] newlist = relacoes ++ newrel newmap = Map.insert eu props m in (eu:newpilha, newlevel, newlist, newmap) onlyInteresting :: [(Node, Node, Int, [Node])] -> Set.Set (Node, Node) onlyInteresting a = Set.fromList $ map elemtuple a where elemtuple (e1, e2, _, _) = (e1, e2) getDescendents :: Node -> Set.Set (Node, Node) -> Set.Set Node getDescendents e s = Set.union filhos descendents where meus = Set.filter ( \ (p, _) -> p == e) s filhos = Set.map snd meus descendents = Set.unions [d | d <- map (flip getDescendents s) (Set.toList filhos)] getToEliminate :: (Node, Node) -> Set.Set (Node, Node) -> Set.Set (Node, Node) getToEliminate (pai, filho) s = Set.filter filt s where descendents = getDescendents filho s filt (p, f) = p == pai && Set.member f descendents resumeData :: (Set.Set (Node, Node), Map.Map Node Properties) -> (Set.Set (Node, Node), Map.Map Node Properties) resumeData (sinicial, m) = (Set.fold folder snoroot snoroot, m) where snoroot = sinicial folder :: (Node, Node) -> Set.Set (Node, Node) -> Set.Set (Node, Node) folder eatual satual = Set.fold Set.delete satual (getToEliminate eatual satual) colorProp :: Properties -> ByteString colorProp ( _, True, _, Nothing, False, False, False, False, False, False) = B.pack "" colorProp ( _, _, _, _, _, _, _, True, _, _) = B.pack "color=\"green\"" colorProp ( _, _, _, _, _, _, _, False, _, _) = B.pack "color=\"red2\"" otherProp :: Properties -> ByteString -- (level,exists, rep, build expl, sidef, precious, always, curre, nocln, nocax) otherProp ( 0, _, _, _, _, _, _, True, _, _) = B.pack "shape= \"diamond\"" otherProp ( 0, _, _, _, _, _, _, False, _, _) = B.pack "shape= \"diamond\"" otherProp ( _, True, _, Nothing, False, False, False, False, False, False) = B.pack "shape= \"rectangle\" style=\"filled\" fillcolor=\"lightyellow\"" otherProp ( _, _, _, Just False, _, _, _, _, _, _) = B.pack "style=\"filled\" fillcolor=\"lightblue\"" otherProp ( _, _, _, _, True, _, _, _, _, _) = B.pack "style=\"filled\" fillcolor=\"limegreen\"" otherProp ( _, _, _, _, _, True, _, _, _, _) = B.pack "style=\"filled\" fillcolor=\"brown\"" otherProp ( _, _, _, _, _, _, True, _, _, _) = B.pack "style=\"filled\" fillcolor=\"yellow\"" otherProp ( _, _, _, _, _, _, _, _, True, _) = B.pack "style=\"filled\" fillcolor=\"red2\"" otherProp _ = B.empty dotprop :: Properties -> ByteString dotprop prop = B.concat [ colorProp prop, otherProp prop ] makeDot :: (Set.Set (Node, Node), Map.Map Node Properties) -> ByteString makeDot (dat, m) = let dotmap :: (Node, Node) -> ByteString dotmap (pai, eu) = B.concat [B.pack "\t\"", toBS pai, B.pack "\" -> \"", toBS eu, B.pack "\"\n" ] lista = Set.toList dat dot = B.concat $ map dotmap lista propmap e p str = B.concat [ str, B.pack "\t\"", toBS e, B.pack "\" [ ", dotprop p, B.pack " ]\n" ] props = Map.foldWithKey propmap B.empty m in B.concat [ B.pack "digraph {\n\trankdir=LR\n", dot, props, B.pack "}\n" ] main::IO () main = do (_, out, _, _) <- runInteractiveProcess "scons" ["-n", "--tree=all,status"] Nothing Nothing str <- B.hGetContents out B.putStr $ (makeDot . resumeData . buildData . map lineInfo . filter lineOk . B.split '\n') str