-- | Formats Haskell source code as HTML with CSS and Mouseover Type Annotations
module Language.Haskell.HsColour.ACSS (
    hscolour
  , hsannot
  , AnnMap (..)
  , Loc (..)
  , breakS
  , srcModuleName 
  ) where

import Language.Haskell.HsColour.Anchors
import Language.Haskell.HsColour.Classify as Classify
import Language.Haskell.HsColour.HTML (renderAnchors, renderComment,
                                       renderNewLinesAnchors, escape)
import qualified Language.Haskell.HsColour.CSS as CSS

import Data.Maybe  (fromMaybe) 
import qualified Data.Map as M
import Data.List   (isSuffixOf, findIndex, elemIndices, intercalate)
import Data.Char   (isLower, isSpace, isAlphaNum)
import Text.Printf
import Debug.Trace

newtype AnnMap = Ann (M.Map Loc (String, String))                    
newtype Loc    = L (Int, Int) deriving (Eq, Ord, Show)

-- | Formats Haskell source code using HTML and mouse-over annotations 
hscolour :: Bool     -- ^ Whether to include anchors.
         -> Int      -- ^ Starting line number (for line anchors).
         -> String   -- ^ Haskell source code, Annotations as comments at end
         -> String   -- ^ Coloured Haskell source code.

hscolour anchor n = hsannot anchor n . splitSrcAndAnns

-- | Formats Haskell source code using HTML and mouse-over annotations 
hsannot  :: Bool             -- ^ Whether to include anchors.
         -> Int              -- ^ Starting line number (for line anchors).
         -> (String, AnnMap) -- ^ Haskell Source, Annotations
         -> String           -- ^ Coloured Haskell source code.

hsannot anchor n = 
    CSS.pre
    . (if anchor then -- renderNewLinesAnchors n .
                      concatMap (renderAnchors renderAnnotToken)
                      . insertAnnotAnchors
                 else concatMap renderAnnotToken)
    . annotTokenise

annotTokenise  :: (String, AnnMap) -> [(TokenType, String, Maybe String)] 
annotTokenise (src, Ann annm) 
  = zipWith (\(x,y) z -> (x,y, snd `fmap` z)) toks annots 
  where toks       = tokenise src 
        spans      = tokenSpans $ map snd toks 
        annots     = map (`M.lookup` annm) spans

tokenSpans :: [String] -> [Loc]
tokenSpans = scanl plusLoc (L (1, 1)) 

plusLoc :: Loc -> String -> Loc
plusLoc (L (l, c)) s 
  = case '\n' `elemIndices` s of
      [] -> L (l, (c + n))
      is -> L ((l + length is), (n - maximum is))
    where n = length s

renderAnnotToken :: (TokenType, String, Maybe String) -> String
renderAnnotToken (x,y, Nothing) 
  = CSS.renderToken (x, y)
renderAnnotToken (x,y, Just ann)
  = printf template (escape ann) (CSS.renderToken (x, y))
    where template = "<a class=annot href=\"#\"><span class=annottext>%s</span>%s</a>"

{- Example Annotation:
<a class=annot href="#"><span class=annottext>x#agV:Int -&gt; {VV_int:Int | (0 &lt;= VV_int),(x#agV &lt;= VV_int)}</span>
<span class='hs-definition'>NOWTRYTHIS</span></a>
-}


insertAnnotAnchors :: [(TokenType, String, a)] -> [Either String (TokenType, String, a)]
insertAnnotAnchors toks 
  = stitch (zip toks' toks) $ insertAnchors toks'
  where toks' = [(x,y) | (x,y,_) <- toks] 

stitch ::  Eq b => [(b, c)] -> [Either a b] -> [Either a c]
stitch xys ((Left a) : rest)
  = (Left a) : stitch xys rest
stitch ((x,y):xys) ((Right x'):rest) 
  | x == x' 
  = (Right y) : stitch xys rest
  | otherwise
  = error "stitch"
stitch _ []
  = []


splitSrcAndAnns ::  String -> (String, AnnMap) 
splitSrcAndAnns s = 
  let ls = lines s in
  case findIndex (breakS ==) ls of
    Nothing -> (s, Ann M.empty)
    Just i  -> (src, {- trace ("annm =" ++ show ann) -} ann)
               where (codes, _:mname:annots) = splitAt i ls
                     ann   = annotParse mname $ dropWhile isSpace $ unlines annots
                     src   = unlines codes
                     -- mname = srcModuleName src

srcModuleName :: String -> String
srcModuleName = fromMaybe "Main" . tokenModule . tokenise
  
tokenModule toks 
  = do i <- findIndex ((Keyword, "module") ==) toks 
       let (_, toks')  = splitAt (i+2) toks
       j <- findIndex ((Space ==) . fst) toks'
       let (toks'', _) = splitAt j toks'
       return $ concatMap snd toks''

breakS = "MOUSEOVER ANNOTATIONS" 

annotParse :: String -> String -> AnnMap
annotParse mname = Ann . M.fromList . parseLines mname 0 . lines

parseLines mname i [] 
  = []
parseLines mname i ("":ls)      
  = parseLines mname (i+1) ls
parseLines mname i (x:f:l:c:n:rest) 
  | f /= mname -- `isSuffixOf` mname 
  = {- trace ("wrong annot f = " ++ f ++ " mname = " ++ mname) $ -} parseLines mname (i + 5 + num) rest'
  | otherwise 
  = (L (line, col), (x, anns)) : parseLines mname (i + 5 + num) rest'
    where line  = (read l) :: Int
          col   = (read c) :: Int
          num   = (read n) :: Int
          anns  = intercalate "\n" $ take num rest
          rest' = drop num rest
parseLines _ i _              
  = error $ "Error Parsing Annot Input on Line: " ++ show i

takeFileName s = map slashWhite s
  where slashWhite '/' = ' '

instance Show AnnMap where
  show (Ann m) = "\n\n" ++ (concatMap ppAnnot $ M.toList m)
    where ppAnnot (L (l, c), (x,s)) =  x ++ "\n" 
                                    ++ show l ++ "\n"
                                    ++ show c ++ "\n"
                                    ++ show (length $ lines s) ++ "\n"
                                    ++ s ++ "\n\n\n"