content: {-------------------------------------------------------------------------------
  
          Copyright:              The Hatchet Team (see file Contributors)
  
          Module:                 DependAnalysis
  
          Description:            Compute the dependencies between values. Can
                                  be used for computing the dependencies in
                                  variables and also the dependencies in types.
                                  The code is used in type inference and
                                  also kind inference.
  
          Primary Authors:        Bernie Pope, Robert Shelton
  
          Notes:                  See the file License for license information
  
  -------------------------------------------------------------------------------}
  
  module FrontEnd.DependAnalysis (getBindGroups,  debugBindGroups) where
  
  import Data.Graph(stronglyConnComp, SCC(..))
  import Data.List (nub)
  
  -- Given a list of nodes, a function to convert nodes to a unique name, a function
  -- to convert nodes to a list of names on which the node is dependendant, bindgroups
  -- will return a list of bind groups generater from the list of nodes given.
  getBindGroups :: Ord name =>
                   [node]           ->    -- List of nodes
                   (node -> name)   ->    -- Function to convert nodes to a unique name
                   (node -> [name]) ->    -- Function to return dependencies of this node
                   [[node]]               -- Bindgroups
  
  getBindGroups ns fn fd = map f $ stronglyConnComp [ (n, fn n, fd n) | n <- ns] where
      f (AcyclicSCC x) = [x]
      f (CyclicSCC xs) = xs
  {-
  getBindGroups ns getName getDeps
  	= [ mapOnList nameToNodeFM group | group <- nameGroups ]
  	where
  	nameGroups = buildNameGroups nameList nameEdges
  	nameList = map getName ns
  	nameEdges = buildNameEdges ns getName getDeps
  	nameToNodeFM = listToFM [ (getName x, x) | x <- ns ]
  
  getBindGroups ns toName getDeps = filter (not . null) (map (concatMap f) $ Scc.scc ds) where
      f n = case M.lookup n m of
          --Nothing -> error $ "cannot find " ++ show n ++ " in " ++ unlines (map show (sort ds))
          --Just x -> x
          Nothing -> fail "Nothing"
          Just x -> return x
      ds = [ (toName x, getDeps x) | x <- ns ]
      m = M.fromList [ (toName x,x) | x <- ns]
  -}
  
  --
  -- Create a list of edges from a list of nodes.
  --
  {-
  buildNameEdges :: [node]           ->    -- List of nodes
                    (node -> name)   ->    -- Function to convert nodes to a unique name
                    (node -> [name]) ->    -- Function to return dependencies of this node
                    [(name,name)]          -- Edges from list of nodes.
  buildNameEdges [] _ _
  	= []
  buildNameEdges (n:ns) getName getDeps
  	= map mapFunc (getDeps n) ++ (buildNameEdges ns getName getDeps)
  	where
  	mapFunc = ( \ s -> (getName n, s) )
  -}
  
  --
  -- Create a list of groups from a list of names.
  --
  {-
  buildNameGroups :: Ord name      =>
                     [name]        ->    -- list of names
                     [(name,name)] ->    -- List of edges
                     [[name]]            -- List of bindgroups
  buildNameGroups ns es
  	= [ mapOnList intToNameFM group | group <- intGroups ]
  	where
  	intGroups = map preorder $ scc $ buildG (1, sizeFM nameToIntFM) intEdges
  	intEdges = mapOnTuple nameToIntFM es
  	nameToIntFM = listToFM nameIntList
  	intToNameFM = listToFM [ (y,x) | (x,y) <- nameIntList ]
  	nameIntList = zip ns [1..]
  
  --
  -- Use a finitemap to convert a list of type A into a list of type B
  -- NB, not being able to find an element in the FM is not considered
  --     an error.
  --
  mapOnList :: Ord a         =>
               FiniteMap a b ->    -- Finite map from a to b
               [a]           ->    -- List of a
               [b]                 -- List of b
  mapOnList _ [] = []
  mapOnList fm (a:as)
  	= case (lookupFM fm a) of
  			Just b  -> b : mapOnList fm as
  			Nothing -> mapOnList fm as
  
  --
  -- Use a finitemap to convert a 2 tuple to a different type.
  -- NB, not being able to find an element in the FM is not considered
  --     an error.
  --
  mapOnTuple :: Ord a         =>
                FiniteMap a b ->
                [(a,a)]       ->
                [(b,b)]
  mapOnTuple _ [] = []
  mapOnTuple fm ((a1,a2):as)
  	= case (lookupFM fm a1) of
  		Just x  ->
  			case (lookupFM fm a2) of
  				Just y  -> (x,y) : (mapOnTuple fm as)
  				Nothing -> mapOnTuple fm as
  		Nothing -> mapOnTuple fm as
  
  -}
  
  --------------------------------------------------------------------------------
  -- showBindGroups
  --------------------------------------------------------------------------------
  
  --
  -- Display bind group information in a human readable (or as close to) form.
  --
  {-
  showBindGroups :: [[node]]        ->     -- List of nodes
  		  (node->String)  ->     -- Function to convert a node to a string
                    String                 -- Printable string
  showBindGroups ns getAlias
  	= showBindGroups_ ns getAlias 0
  -}
  
  --
  -- Recursive function which does the work of showBindGroups.
  --
  {-
  showBindGroups_ :: [[node]]        ->     -- List of nodes
  		   (node->String)  ->     -- Function to convert a node to a string
                     Int             ->     -- Bind group number
                     String                 -- Printable string
  showBindGroups_ [] _ _
  	= ""
  showBindGroups_ (n:ns) getAlias groupNum
  	= "Bindgroup " ++ show groupNum ++ " = "
  	  ++ bgString ++ "\n"
  	  ++ showBindGroups_ ns getAlias (groupNum + 1)
  	where
  	bgString = wrapString "EMPTY" (listToString n getAlias)
  -}
  
  --------------------------------------------------------------------------------
  -- debugBindGroups
  --------------------------------------------------------------------------------
  
  --
  -- Display bind group information in a human readable (or as close to) form.
  -- Also display dependencie and error information. Warning this function is slow
  -- and fat. But without forcing name to be of type Ord, it is hard to improve
  -- the algorithm.
  --
  debugBindGroups :: (Eq name) =>
                    [[node]]        ->     -- List of nodes
  		  (node->String)  ->     -- Function to produce a printable name for the node
                    (node->name)    ->     -- Function to convert nodes to a unique name
  		  (node->[name])  ->     -- Function to return dependencies of this node
                    String                 -- Printable string
  debugBindGroups ns getAlias getName getDeps
  	= debugBindGroups_ ns getAlias getName getDeps 0 []
  
  --
  -- Recursive function which does the work of showBindGroups.
  --
  debugBindGroups_ :: (Eq name) =>
                     [[node]]        ->     -- List of nodes
                     (node->String)  ->     -- Function to produce a printable name for the node
                     (node->name)    ->     -- Function to convert nodes to a unique name
  		   (node->[name])  ->     -- Function to return dependencies of this node
                     Int             ->     -- Bind group number
  		   [(Int,[name])]  ->     -- History information of names already processed
                     String                 -- Printable string
  debugBindGroups_ [] _ _ _ _ _
  	= ""
  debugBindGroups_ (n:ns) getAlias getName getDeps groupNum history
  	= show groupNum ++ " = "
  	  ++ bgString ++ "\n"
  	  ++ debugBindGroups_ ns getAlias getName getDeps (groupNum + 1) newHistory
  	where
  	bgString = showBindGroup (expandBindGroup n getAlias getDeps newHistory)
  	newHistory = history ++ [(groupNum, [ getName x | x <- n ])]
  
  --
  -- Expand bindgroups, generating dependancie and error information.
  --
  expandBindGroup :: (Eq name) =>
                     [node]         ->               -- List of nodes
                     (node->String) ->               -- Function to produce a printable name for the node
  		   (node->[name]) ->               -- Function to return dependencies of this node
                     [(Int,[name])] ->               -- History information of names already processed
                     ([String], [Int], [String])     -- Printable string in form (bindgroup, bgnums, Errors)
  expandBindGroup [] _ _ _
  	= ([],[],[])
  expandBindGroup (n:ns) getAlias getDeps history
  	= if err
  		then (name:a, bgs++b, name:c)
  		else (name:a, bgs++b, c)
  	where
  	name = getAlias n
  	(bgs, err) = inHistory (getDeps n) history
  	(a,b,c) = expandBindGroup ns getAlias getDeps history
  -- NB ticti, you should not be calling inHistory on the name, but instead on the deps.
  
  --
  -- Convert the information generated by expandBindGroup into a printable
  -- form.
  --
  showBindGroup :: ([String],[Int],[String]) -> String
  showBindGroup (bg, deps, errors)
  	= bgString ++ " " ++ depString ++ " " ++ errString
  	where
  	bgString  = wrapString [] $ listToString bg id
  	depString = wrapString [] $ listToString (nub deps) show
  	errString = wrapString [] $ listToString errors id
  
  --
  -- Convert a list of something, into a printable string.
  --
  listToString :: [a]         ->    -- List of things
                  (a->String) ->    -- Function to convert things to Strings
                  String            -- Single printable String.
  listToString [] _
  	= ""
  listToString [l] lFunc
  	= (lFunc l)
  listToString (l:ls) lFunc
  	= (lFunc l) ++ ", " ++ listToString ls lFunc
  
  --
  -- Given a list of names and the history of visited names, this function
  -- generates a list of bindgroups that are depended upon as well as returning
  -- a boolean value indicating whether all these dependencies are satisfied.
  --
  -- True -> ERROR, a name needed now has not been resolved.
  --
  inHistory :: Eq name =>
               [name]         ->    -- List of names to be searched for
               [(Int,[name])] ->    -- History information of names already processed
               ([Int],Bool)         -- Number of bind group that name is in, or its own alias.
  inHistory [] _
  	= ([],False)
  inHistory (name:names) history
  	= if location < 0
  		then (bgs, False)
  		else (location : bgs, err)
  	where
  	location = searchHistory name history
  	(bgs, err) = inHistory names history
  
  --
  -- Check whether a particular name has occured befor and return the number
  -- of the bindgroup it occured in.
  --
  searchHistory :: Eq name        =>
                   name           ->   -- List of names to be searched for
                   [(Int,[name])] ->   -- History information of names already processed
                   Int                 -- Bindgroup num that name occurred in (-1 is error)
  searchHistory _ []
  	= -1
  searchHistory name ((bgnum, bgnames):history)
  	= if elem name bgnames
  		then bgnum
  		else searchHistory name history
  
  --
  -- Neatly brackets a string using a replacement string (rep) if empty.
  --
  wrapString :: String -> String -> String
  wrapString rep "" = "[" ++ rep ++ "]"
  wrapString _   s  = "[" ++ s ++ "]"
  