module Language.Haskell.ER.Dictionary where

import Language.Haskell.TH
import Language.Haskell.ER.HaskellRewrite as HaskellRewrite
import Language.Haskell.ER.Syntax
import Language.Haskell.ER.BaseRewrite -- to remove
--import Language.Haskell.ER.Subst -- to remove
import Text.Html hiding (combine)
import Data.Tree
import Data.List hiding (insert)
import qualified Data.Map as Map

data Entry = Collection String [Entry]
	   | Basic String		-- transformation label
	     	   String		-- full transformation name (for lookup)
	           UniHaskellRewrite	-- rewriting over something
		   (Maybe Bool)		-- if this is recommended local use only

data Dictionary = Dictionary (Map.Map String UniHaskellRewrite) [Entry]

dictToHtml :: Dictionary -> Html
dictToHtml (Dictionary _ es) = table ! [theclass "tree"] 
	   	       	     << concatHtml [ entryToHtml [i] e 
	       	       	   	    	   | (e,i) <- zip es [0..]
					   ]

-- assumes inside <table>..</table>
entryToHtml :: Path -> Entry -> Html
entryToHtml path (Collection name es) = 
	    (tr << th << ((image ! [ src "downarrow.gif"
	    	      	       	   , strAttr "onclick"
				     $ "toggle(this,'" ++ pathToId path ++ "')" 
	    	      	       	 ]) +++ lineToHtml (" " ++ name))) +++
	    (tr << td << table ! [theclass "tree", identifier $ pathToId path] 
	    	<< concatHtml [ entryToHtml (path ++ [i]) e 
	       	       	   	    	       | (e,i) <- zip es [0..]
					       ])

entryToHtml path (Basic name fullname _ recommend) =
	    (tr << td ! [ identifier $ fullname
			, theclass $ case recommend of
	      		        Just True -> "singlerewrite"
	      		        _         -> "rewrite"
	    	      	] << (image ! [ src $ case recommend of
			     	      	        Just True -> "target.gif"
			     	      	        _ -> "proof.gif"
			     	      ]
			  +++ lineToHtml (" " ++ name)))
{-
	    li ! [ theclass $ case recommend of
	      		        Just True -> "singlerewrite"
	      		        _         -> "rewrite"
	         ] << leaf path name 
-}
-- We want each leaf to have 	    
-- * name
-- * what it acts on { Dec, Exp, Code, ... }
-- * how it acts (prefix, postfix, once, etc)
leaf :: Path -> String -> Html
leaf path name = 
     anchor ! [ href "#"
     	      , identifier $ full_name
	      ] << name
  where
      full_name :: String
      full_name = foldr (\ a as -> show a ++ "," ++ as) 
      		     	  (show $ last path) (init path)

pathToId :: Path -> String
pathToId []   = "root"
pathToId path = foldr (\ a as -> show a ++ "," ++ as) 
      		     	  (show $ last path) (init path)


------------------------------------------------------------------------------

performRewrite :: (Equationable eq)
	       => [Dec]
	       -> (Dictionary,String)
	       -> (eq,SubstOrder) 
	       -> Q (eq,[Tree (Path,RewriteInfo)])
performRewrite decs
	       (Dictionary fm _,dict_path)
  	       (code,code_substorder) = do
    case Map.lookup dict_path fm of
      Nothing -> do runIO $ print $ "Can not find " ++ show (dict_path,fm)
      	      	    error "opps"
      Just rr -> do
          runIO $ print (dict_path,code_substorder)
	  (decs,infos,new_decs) 
    	     <- HaskellRewrite.runRewrite (HaskellRewrite.substUsing' code_substorder rr) decs code
          return (bindDecs new_decs decs,infos)
  
-----------------------------------------------------------------------------

generateDictionary :: [UniHaskellRewrite]
		   -> Dictionary
generateDictionary rewrites = Dictionary dict (map (fn "") trees)
  where fn pre (Node (name,local) []) = Basic name fullname (find fullname) local 
  	   -- We rebuild the path here, needlessley
           where at = case local of { Just True -> "@" ; _ -> "" }
	   	 fullname = at ++ pre ++ "/" ++ name
        fn pre (Node (name,_) others) = Collection name $ map (fn (pre ++ "/" ++ name)) others

	dict :: Map.Map String UniHaskellRewrite
	dict = Map.fromList $ map (\ a -> (show a,a)) rewrites

        find :: String -> UniHaskellRewrite
  	find name = case Map.lookup name dict of
	     	      Nothing -> error $ "bad lookup for : " ++ show (name,dict)
		      Just r -> r

	trees = merge'
	        [ mkNode name' rec
	      	| name <- Map.keys dict
		, let (rec,name') =
		        case name of
		         '/':rest     -> (Nothing,rest)
			 '@':'/':rest -> (Just True,rest) -- please apply at specific local
		         _            -> error $ "bad rewrite name (needs / or @?): " ++ name
		]

        mkNode name rec = 
	       	      case span (/= '/') name of
       	                (pre,'/':post) -> Node (pre,Nothing) [mkNode post rec]
		        (pre,[]) -> Node (pre,rec) []

merge' :: (Eq a,Ord a) => [Tree a] -> [Tree a]
merge' = map (\ as -> if length as == 1 then head as
       	     	      else Node (rootLabel $ head as)
		      	   	(merge' (concatMap subForest as))
	      )
       . groupBy (\ a b -> rootLabel a == rootLabel b) 
       . sortBy (\ a b -> rootLabel a `compare` rootLabel b)  


filterDictionary :: (Subst exp) => [Dec] -> Path -> exp -> Dictionary -> Q Dictionary
filterDictionary decs path exp (Dictionary fm entries) = do
   entries' <- fnList entries
   return $ Dictionary fm entries'	-- keep the same finite map of trans
 where
      fnList entries = do
         entries1 <- mapM fn entries
	 let entries2 = [ entry | Just entry <- entries1 ]
	 return $ entries2

      fn (Collection "hacks" _) = return $ Nothing
      fn (Collection "Eureka" _) = return $ Nothing		-- magic markers!
      fn (Collection str entries) = do
         entries' <- fnList entries 
	 if null entries' then return $ Nothing
	    	 	  else return $ Just $ Collection str entries'

      fn basic@(Basic _ _ rr _)     = do
      	    b <- oraclePred (substUsing' (addThePath path) rr) decs exp
	    if b then return $ Just basic
	         else return $ Nothing

      addThePath []     = Here
      addThePath (x:xs) = Path x $ addThePath xs

------------------------------------------------------------------------------

-- Not really dictionary stuff

showInfoInHtml :: [Tree (Path,RewriteInfo)] -> Html
showInfoInHtml [] = noHtml
showInfoInHtml trees
	       = ulist << concatHtml
	       	    [ li << showInfoInHtml' tree
		    | tree <- trees
		    ]
showInfoInHtml' :: Tree (Path,RewriteInfo) -> Html
showInfoInHtml' (Node (path,info) trees) 
	       = show' info +++ showInfoInHtml trees
   where
     show' :: RewriteInfo  -> Html
     show' (RewriteInfo msg) = bold << ("applied " ++ show msg)
     show' (RewriteMessage msg) = italics << msg

------------------------------------------------------------------------------