module FrontEnd.DependAnalysis (debugDeclBindGroups) where

import Data.List (nub,intercalate)
import FrontEnd.HsSyn
import FrontEnd.Rename(unRename)
import FrontEnd.Syn.Traverse

-- 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 = f ns getAlias getName getDeps 0 [] where
    f (n:ns) getAlias getName getDeps groupNum history
            = show groupNum ++ " = " ++ bgString ++ "\n"
            ++ f ns getAlias getName getDeps (groupNum + 1) newHistory
            where
            bgString = showBindGroup (expandBindGroup n getAlias getDeps newHistory)
            newHistory = history ++ [(groupNum, [ getName x | x <- n ])]
    f [] _ _ _ _ _ = ""
                                           -- Bind group number    -- History information of names already processed

-- 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  = b $ sl bg
	depString = b $ sl (map show $ nub deps)
	errString = b $ sl errors
        sl x  = intercalate ", " x
        b s = "[" ++ s ++ "]"

-- 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

-- from declsdepends
debugDeclBindGroups :: [[HsDecl]] -> String
debugDeclBindGroups groups = debugBindGroups groups
    (show . unRename . getDeclName) getDeclName getDeclDeps