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 decls e ->
let (ignores,vars) = get_vars_decls (ignores++ignore) decls
in vars ++ get_vars_exp (ignores++ignore) e
HsIf e1 e2 e3 -> get_vars_exps ignore [e1,e2,e3]
HsCase e alts ->
get_vars_exp ignore e ++ concatMap (get_vars_alt ignore) alts
HsDo stmts -> snd $ get_vars_stmts ignore stmts
HsTuple es -> get_vars_exps ignore es
HsList es -> get_vars_exps ignore es
HsParen e -> get_vars_exp ignore e
HsLeftSection e1 e2 -> get_vars_exps ignore [e1,e2]
HsRightSection e1 e2 -> get_vars_exps ignore [e1,e2]
HsRecConstr _ ups -> concatMap (get_vars_fieldupdate ignore) ups
HsRecUpdate e ups -> error "undefined HsRecUpdate"
HsEnumFrom e -> get_vars_exp ignore e
HsEnumFromTo e1 e2 -> get_vars_exps ignore [e1,e2]
HsEnumFromThen e1 e2 -> get_vars_exps ignore [e1,e2]
HsEnumFromThenTo e1 e2 e3 -> get_vars_exps ignore [e1,e2,e3]
HsListComp e stmts ->
let (ignores, vars) = get_vars_stmts ignore stmts
in vars ++ get_vars_exp ignores e
HsExpTypeSig _ e _ -> get_vars_exp ignore e
HsAsPat _ e -> get_vars_exp ignore e
HsIrrPat e -> get_vars_exp ignore e
_ -> []
get_vars_fieldupdate :: [HsName] -> HsFieldUpdate -> [HsName]
get_vars_fieldupdate ignore fu = case fu of
HsFieldUpdate _ exp -> get_vars_exp ignore exp
get_vars_stmts :: [HsName] -> [HsStmt] -> ([HsName], [HsName])
get_vars_stmts ignore stmts = case stmts of
[] -> ([],[])
(stmt:stmts) ->
let (newignore,r) = case stmt of
HsGenerator pat exp -> (get_vars_pat pat, get_vars_exp ignore exp)
HsQualifier exp -> ([], get_vars_exp ignore exp)
HsLetStmt decls ->
let (names, vars) = get_vars_decls ignore decls
in (names, vars)
(newignores,rs) = get_vars_stmts newignore stmts
in (newignore++newignores, r++rs)
get_vars_alt :: [HsName] -> HsAlt -> [HsName]
get_vars_alt ignore alt = case alt of
HsAlt _ pat alts decls ->
let vars = case alts of
HsUnGuardedAlt e -> get_vars_exp ignore e
HsGuardedAlts guardedalts ->
concatMap (get_vars_guardedalt ignore) guardedalts
patvars = get_vars_pat pat
in vars \\ patvars
get_vars_guardedalt :: [HsName] -> HsGuardedAlt -> [HsName]
get_vars_guardedalt ignore alt = case alt of
HsGuardedAlt _ e1 e2 -> get_vars_exps ignore [e1,e2]
get_vars_pats :: [HsPat] -> [HsName]
get_vars_pats = concatMap get_vars_pat
get_vars_pat :: HsPat -> [HsName]
get_vars_pat pat = case pat of
HsPVar name -> [name]
HsPNeg pat -> get_vars_pat pat
HsPInfixApp p1 _ p2 -> get_vars_pats [p1,p2]
HsPApp _ ps -> get_vars_pats ps
HsPTuple ps -> get_vars_pats ps
HsPList ps -> get_vars_pats ps
HsPParen p -> get_vars_pat p
HsPRec _ _ -> error "undefined HsPRec"
HsPAsPat _ p -> get_vars_pat p
HsPIrrPat p -> get_vars_pat p
_ -> []
_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
