[module CallDependencies initial record
martin.hofmann@uni-bamberg.de**20081121125627] addfile ./src/Data/CallDependencies.hs
hunk ./src/Data/CallDependencies.hs 1
+
+module Data.CallDependencies( 
+
+        CallDep, Data.CallDependencies.empty,
+        addCall, tryAddCall,
+        admissible 
+        
+       )where
+
+import Data.Map (Map)
+import qualified Data.Map as M (empty, insert, member, lookup)
+import Data.Graph.Inductive (Graph,Gr, Node, LNode, Path, LPath(..), lbft, noNodes, run_, insMapNodeM, insMapEdgesM, insMapEdgeM, delMapEdgeM)
+import qualified Data.Graph.Inductive as G (empty)
+import Language.Haskell.TH
+import Control.Monad (liftM2)
+
+import Debug.Trace
+{-
+ | Computing the transitive closure of calling dependencies. 
+ 
+   Basic Idea:
+   If function 'f' calls function 'g', then 'f' depends on 'g' (f -> g). The 
+   argument(s) of a call could either increase, decrease or remain in size, thus
+   the the dependency could be of kind LT, EQ, GT (-LT->, -EQ->, -GT->).
+   
+   Calling dependencies are transitive, so if f -> g and g -> h then also 
+   f -> h. The kind of the transitive dependency has the maximal type of all 
+   compound dependencies with ordering LT < EQ < GT. 
+   
+   If already a calling dependency f -> g exists, the following possibilities 
+   for g calling f are allowed:
+   
+   f -GT-> g  => g is not allowed to call f
+   f -EQ-> g  => g -LT-> f
+   f -LT-> g  => g -LT-> f or g -EQ-> f
+   
+   Dependencies are stored in a graph with labelled nodes and edges of type 
+   (GR Name Ordering) from the "functional graph library" by Martin Erwig: 
+       http://hackage.haskell.org/cgi-bin/hackage-scripts/package/fgl
+       
+   To retrieve a certain Node, the Name of the calling function and the graph-
+   internal node number are stored in a Map, whereas a Node in a graph is simply
+   an Int value, i.e. the nth Node has the value n.
+  
+-}          
+instance (Eq a, Eq b)   => Eq (Gr a b)
+instance (Ord a, Ord b) => Ord (Gr a b)
+
+data CallDep = CD
+    { callings :: Gr Name Ordering
+    , nodes :: Map Name Node    
+    }
+    deriving(Show, Eq, Ord)
+
+empty :: CallDep
+empty = CD G.empty M.empty
+
+addCall ::(Name, Name, Ordering) -> CallDep -> CallDep
+addCall c cd =  
+    if admissible c cd 
+       then addCallUnsafe c cd 
+       else error "Call not admissible!"
+     
+tryAddCall ::(Monad m) => (Name, Name, Ordering) -> CallDep -> m CallDep
+tryAddCall c cd =  
+    if admissible c cd 
+       then return $ addCallUnsafe c cd 
+       else fail "Call not admissible!"
+
+admissible :: (Name,Name,Ordering) -> CallDep -> Bool
+admissible (f,g,o) (CD cs ns) 
+    | f == g    = o == LT 
+    | otherwise = and $ map (check o)  deps
+    where
+    deps = case liftM2 (,)(asNode f ns) (asNode g ns) of 
+        (Just (nf,ng)) -> dependencies ng nf cs
+        Nothing        -> []
+        
+    --check :: Ordering -> (LNode Ordering) -> Bool
+    check LT (_,LT) = True -- f -LT-> g  => g -LT-> f  
+    check LT (_,EQ) = True -- f -LT-> g  => g -EQ-> f
+    check EQ (_,LT) = True -- f -EQ-> g  => g -LT-> f
+    check _  _      = False
+    
+asNode :: Name -> Map Name Node -> Maybe Node
+asNode n ns =  M.lookup n ns
+
+{-
+ |- Unsafe functions to modify calling dependencies
+-}
+
+-- adds a call only, iff the call does not exist yet, or it is greater then any 
+-- other (possible transitive) call  
+addCallUnsafe :: (Name, Name, Ordering) -> CallDep -> CallDep
+addCallUnsafe c@(f1,f2,o) cd =
+    let (CD cs ns) = foldl (flip addFunUnsafe) cd [f1,f2] 
+    in CD (addEdge c cs) ns
+    
+-- add a calling function as a node if it is not already present and associate 
+-- the node number with the name for later retrieval
+addFunUnsafe :: Name -> CallDep -> CallDep
+addFunUnsafe n cd@(CD cs ns) = 
+    if M.member n ns
+      then cd
+      else let cs' = addNode n cs
+               ns' = M.insert n (noNodes cs')  ns               
+           in CD cs' ns'
+           
+{-
+ |- Unsafe functions to modify a graph
+-}  
+addNode :: (Ord a) => a -> Gr a b -> Gr a b
+addNode n c =  run_ c $
+    do insMapNodeM n   
+    
+addEdge :: (Ord a) => (a,a,b) -> Gr a b -> Gr a b
+addEdge e@(e1,e2,_) c =  run_ c $
+    do delMapEdgeM (e1,e2)
+       insMapEdgeM e     
+
+
+-- HACKS
+-- fgl is rather undocumented and the manual is outdated, so I often only got 
+-- some notion of what a function does, by 'trial and error'
+
+-- This function returns all Nodes reachable from the starting Node, with 
+-- accumulated edge labels as label
+dependencies :: (Ord a, Graph gr) => Node -> Node -> gr a1 a -> [(Node, a)]
+dependencies n1 n2 g = compress $ pathsFromTo n1 n2 g
+
+
+-- compute the transitive closure of the dependencies 
+compress  :: (Ord a) => [[LNode a]] -> [LNode a]
+compress = map (foldl1 accumulate)
+
+-- merge two LNodes by by maxing the Ordering
+accumulate :: Ord a => (LNode a) -> (LNode a) -> (LNode a) 
+accumulate (n,l1) (_,l2) = (n, max l1 l2)            
+
+-- get all nodes starting in 'fn' and filter all paths which do not end on 'tn'
+pathsFromTo :: (Graph gr) => Node -> Node -> gr a l -> [[LNode l]]
+pathsFromTo fn tn g = filter (endsin tn) $ pathsFrom fn g
+    where
+    endsin _ []          = False -- should however, never be the case
+    endsin n ((n',_):xs) = n == n'
+    
+
+-- lbft seems to compute the 'labelled breadth first root tree' from a starting 
+-- node, and the result is a list of labelled paths from each reachable node to
+-- the starting node. this is what pathsFrom is supposed to do (after some more hacking) 
+pathsFrom :: (Graph gr) => Node -> gr a l -> [[LNode l]]
+pathsFrom n g = unPath $ lbft n g 
+
+unLP :: LPath t -> [LNode t]
+unLP (LP a) = a
+
+-- The (LRTRee l) (aka [LPath l]) contains always the starting node and the end 
+-- of each path
+unPath :: [LPath l] -> [[LNode l]]
+unPath = tail.map (init.unLP)
+
+
+-- Testing
+f = mkName "f"
+g = mkName "g"
+h = mkName "h"
+i = mkName "i"
+j = mkName "j"
+
+c1 = addCall (h,i,GT) $ addCall (g,h,EQ) $ addCall (f,g,LT) $ empty
+