On 6/6/05, Dimitry Golubovsky <[EMAIL PROTECTED]> wrote:
> Does there exist a tool which given a Haskell source, shows functions
> that are mutually recursive (i. e. call each other, even via calling
> third, etc. functions)? Knowledge of that would help to split the
> module into smaller modules without risk to create recursive modules.
>
When you sent this mail I seemed to recall a simple tool written by
Martin Nordbäck which could take a Haskell module an generate its call
graph. But when I searched the web for it I couldn't find it.
But to my surprise I found it today when wading through the heaps of
old Haskell code that I have around (looking for something completely
different.) I'm attaching it in the hope that you will find it useful.
It may have suffered from slight bit rot but it should be fairly easy
to get it up and running.
Cheers,
/Josef
-- Copyright (C) 2001 Safelogic AB
-- 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.
-- Last change: 2001-04-27
import HsParser
import HsParseMonad
import HsSyn
import List((\\), nub, partition)
import System
import Char(isAlphaNum)
parse_contents :: String -> ParseResult HsModule
parse_contents contents = parse contents (SrcLoc 0 0) 0 []
main :: IO ()
main = do
args <- getArgs
main' args
main' files = do
contents <- mapM readFile files
let allPairs = map get_names contents
let allnames = map fst (concat allPairs)
putStr "digraph call_graph {\n"
let (subgraphs,arrows) = unzip $ map (subgraph allnames) (zip3 (map show [1..]) files allPairs)
putStr $ unlines $ subgraphs
putStr $ unlines $ arrows
putStr "}"
subgraph allnames (num,name,pairs) =
let shown = [ (name, filter (\x -> x `elem` allnames) vars)
| (name, vars) <- pairs]
in ("subgraph cluster_" ++ num ++" {\n" ++
"label=\"" ++ name ++ "\";\n" ++
unlines [ show_name name ++ ";" | (name,_) <- shown ] ++
"}\n",
unlines (map show_arrows shown))
get_names contents =
let result = parse_contents contents
in case result of
Failed string -> error "Parse failed: "
Ok _ (HsModule mod exports imports decls) ->
let pairs = map (get_vars_decl []) decls
-- The first in the pair is the function name, this function
-- returns a list, but there will only be one element in it.
pairs' = [(name,vars) | (name:[],vars) <- pairs]
-- combine all names which are doubled
pairs'' = combine_firsts pairs'
in pairs''
combine_firsts pairs = case pairs of
[] -> []
(name, _):_ ->
let (same_list, other_list) = partition (\(x,_) -> x==name) pairs
in (name, nub (concatMap snd same_list)):combine_firsts other_list
show_arrows :: (HsName, [HsName]) -> String
show_arrows (name, calls) = case calls of
--[] -> show_name name ++ ";\n"
_ -> unlines [show_name name ++ " -> " ++ show_name call ++ ";"
| call <- calls ]
show_name :: HsName -> String
show_name name = case name of
Qual (Module mod) string -> fix_name (mod ++ "_" ++ string)
UnQual string -> fix_name string
fix_name :: String -> String
fix_name name = "\"" ++ name ++ "\""
-- fix_name name = map (\x -> if isAlphaNum x || x == '_' then x else '_') name
get_vars_decls :: [HsName] -> [HsDecl] -> ([HsName], [HsName])
get_vars_decls ignore decls =
let (names,vars) = unzip (map (get_vars_decl ignore) decls)
in (concat names, concat vars)
get_vars_decl :: [HsName] -> HsDecl -> ([HsName], [HsName])
get_vars_decl ignore decl = case decl of
HsFunBind _ [HsMatch _ name pats rhs decls] ->
let patvars = concatMap get_vars_pat pats
vars = get_vars_rhs (ignore++patvars) rhs ++
snd (get_vars_decls (ignore++patvars) decls)
in ([name], nub vars)
HsPatBind _ pat rhs decls ->
let vars = get_vars_rhs ignore rhs ++
snd (get_vars_decls (ignore++names) decls)
names = get_vars_pat pat
in (names, nub vars)
_ -> ([],[])
get_vars_rhs :: [HsName] -> HsRhs -> [HsName]
get_vars_rhs ignore rhs = case rhs of
HsUnGuardedRhs exp -> get_vars_exp ignore exp
HsGuardedRhss guardedrhss ->
concatMap (get_vars_guardedrhs ignore) guardedrhss
get_vars_guardedrhs :: [HsName] -> HsGuardedRhs -> [HsName]
get_vars_guardedrhs ignore rhs = case rhs of
HsGuardedRhs _ e1 e2 -> get_vars_exps ignore [e1,e2]
get_vars_exps :: [HsName] -> [HsExp] -> [HsName]
get_vars_exps ignore exps = concatMap (get_vars_exp ignore) exps
get_vars_exp :: [HsName] -> HsExp -> [HsName]
get_vars_exp ignore exp = case exp of
HsVar name -> if name `elem` ignore then [] else [name]
HsInfixApp e1 e2 e3 -> get_vars_exps ignore [e1,e2,e3]
HsApp e1 e2 -> get_vars_exps ignore [e1,e2]
HsNegApp e -> get_vars_exp ignore e
HsLambda _ e-> get_vars_exp ignore e
HsLet dec
