-- | 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 :: Map Loc (String, String) -> AnnMapAnn (M.Map Loc (String, String))                    
newtype Loc    = L :: (Int, Int) -> LocL (Int, Int) deriving (D:Eq :: (a -> a -> Bool) -> (a -> a -> Bool) -> T:Eq aEq, D:Ord ::
  Eq a =>
  (a -> a -> Ordering)
  -> (a -> a -> Bool)
  -> (a -> a -> Bool)
  -> (a -> a -> Bool)
  -> (a -> a -> Bool)
  -> (a -> a -> a)
  -> (a -> a -> a)
  -> T:Ord aOrd, D:Show ::
  (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> T:Show aShow)

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

hscolour :: Bool -> String -> Stringhscolour anchor :: Boolanchor = hsannot :: Bool -> (String, AnnMap) -> Stringhsannot anchor :: Boolanchor (.) :: (b -> c) -> (a -> b) -> a -> c. splitSrcAndAnns :: String -> (String, AnnMap)splitSrcAndAnns

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

hsannot :: Bool -> (String, AnnMap) -> Stringhsannot anchor :: Boolanchor = 
    pre :: String -> StringCSS.pre
    (.) :: (b -> c) -> (a -> b) -> a -> c. (if anchor :: Boolanchor then -- renderNewLinesAnchors .
                      concatMap :: (a -> [b]) -> [a] -> [b]concatMap (renderAnchors :: (a -> String) -> Either String a -> StringrenderAnchors renderAnnotToken :: (TokenType, String, Maybe String) -> StringrenderAnnotToken)
                      (.) :: (b -> c) -> (a -> b) -> a -> c. insertAnnotAnchors ::
  [(TokenType, String, a)] -> [Either String (TokenType, String, a)]insertAnnotAnchors
                 else concatMap :: (a -> [b]) -> [a] -> [b]concatMap renderAnnotToken :: (TokenType, String, Maybe String) -> StringrenderAnnotToken)
    (.) :: (b -> c) -> (a -> b) -> a -> c. annotTokenise ::
  (String, AnnMap) -> [(TokenType, String, Maybe String)]annotTokenise

annotTokenise  :: (String, AnnMap) -> [(TokenType, String, Maybe String)] 
annotTokenise ::
  (String, AnnMap) -> [(TokenType, String, Maybe String)]annotTokenise (src :: Stringsrc, Ann annm :: Map Loc (String, String)annm) 
  = zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]zipWith (\(x :: TokenTypex,y :: Stringy) z :: Maybe (String, String)z -> (x :: [Char]x,y :: Stringy, snd :: (a, b) -> bsnd fmap :: Functor f => forall a b. (a -> b) -> f a -> f b`fmap` z :: Maybe (String, String)z)) toks :: [(TokenType, String)]toks annots :: [Maybe (String, String)]annots 
  where toks :: [(TokenType, String)]toks       = tokenise :: String -> [(TokenType, String)]tokenise src :: Stringsrc 
        spans :: [Loc]spans      = tokenSpans :: [String] -> [Loc]tokenSpans ($) :: (a -> b) -> a -> b$ map :: (a -> b) -> [a] -> [b]map snd :: (a, b) -> bsnd toks :: [(TokenType, String)]toks 
        annots :: [Maybe (String, String)]annots     = map :: (a -> b) -> [a] -> [b]map (lookup :: Ord k => k -> Map k a -> Maybe a`M.lookup` annm :: Map Loc (String, String)annm) spans :: [Loc]spans

tokenSpans :: [String] -> [Loc]
tokenSpans :: [String] -> [Loc]tokenSpans = scanl :: (a -> b -> a) -> a -> [b] -> [a]scanl plusLoc :: Loc -> String -> LocplusLoc (L :: (Int, Int) -> LocL (1, 1)) 

plusLoc :: Loc -> String -> Loc
plusLoc :: Loc -> String -> LocplusLoc (L (l :: Intl, c :: Intc)) s :: Strings 
  = case '\n' elemIndices :: Eq a => a -> [a] -> [Int]`elemIndices` s :: Strings of
      [] -> L :: (Int, Int) -> LocL (l :: Intl, (c :: Intc (+) :: Num a => a -> a -> a+ n :: Intn))
      is :: [Int]is -> L :: (Int, Int) -> LocL ((l :: Intl (+) :: Num a => a -> a -> a+ length :: [a] -> Intlength is :: [Int]is), (n :: Intn (-) :: Num a => a -> a -> a- maximum :: Ord a => [a] -> amaximum is :: [Int]is))
    where n :: Intn = length :: [a] -> Intlength s :: Strings

renderAnnotToken :: (TokenType, String, Maybe String) -> String
renderAnnotToken :: (TokenType, String, Maybe String) -> StringrenderAnnotToken (x :: TokenTypex,y :: Stringy, Nothing) 
  = renderToken :: (TokenType, String) -> StringCSS.renderToken (x :: [Char]x, y :: Stringy)
renderAnnotToken (x :: TokenTypex,y :: Stringy, Just ann :: Stringann)
  = printf :: PrintfType r => String -> rprintf template :: [Char]template (escape :: String -> Stringescape ann :: Stringann) (renderToken :: (TokenType, String) -> StringCSS.renderToken (x :: [Char]x, y :: Stringy))
    where template :: [Char]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 ::
  [(TokenType, String, a)] -> [Either String (TokenType, String, a)]insertAnnotAnchors toks :: [(TokenType, String, a)]toks 
  = stitch :: Eq b => [(b, c)] -> [Either a b] -> [Either a c]stitch (zip :: [a] -> [b] -> [(a, b)]zip toks' :: [(TokenType, String)]toks' toks :: [(TokenType, String)]toks) ($) :: (a -> b) -> a -> b$ insertAnchors ::
  [(TokenType, String)] -> [Either Anchor (TokenType, String)]insertAnchors toks' :: [(TokenType, String)]toks'
  where toks' :: [(TokenType, String)]toks' = [(x :: [Char]x,y :: Stringy) | (x :: TokenTypex,y :: Stringy,_) <- toks :: [(TokenType, String)]toks] 

stitch ::  Eq b => [(b, c)] -> [Either a b] -> [Either a c]
stitch :: Eq b => [(b, c)] -> [Either a b] -> [Either a c]stitch xys :: [(b, c)]xys ((Left a :: aa) : rest :: [Either a b]rest)
  = (Left :: a -> Either a bLeft a :: Inta) (:) :: a -> [a] -> [a]: stitch :: Eq b => [(b, c)] -> [Either a b] -> [Either a c]stitch xys :: [(b, c)]xys rest :: [Either a b]rest
stitch ((x :: bx,y :: cy):xys :: [(b, c)]xys) ((Right x' :: bx'):rest :: [Either a b]rest) 
  | x :: [Char]x (==) :: Eq a => a -> a -> Bool== x' :: bx' 
  = (Right :: b -> Either a bRight y :: Stringy) (:) :: a -> [a] -> [a]: stitch :: Eq b => [(b, c)] -> [Either a b] -> [Either a c]stitch xys :: [(b, c)]xys rest :: [Either a b]rest
  | otherwise :: Boolotherwise
  = error :: [Char] -> aerror "stitch"
stitch _ []
  = [] :: [a][]


splitSrcAndAnns ::  String -> (String, AnnMap) 
splitSrcAndAnns :: String -> (String, AnnMap)splitSrcAndAnns s :: Strings = 
  let ls :: [String]ls = lines :: String -> [String]lines s :: Strings in
  case findIndex :: (a -> Bool) -> [a] -> Maybe IntfindIndex (breakS :: [Char]breakS (==) :: Eq a => a -> a -> Bool==) ls :: [String]ls of
    Nothing -> (s :: Strings, Ann :: Map Loc (String, String) -> AnnMapAnn empty :: Map k aM.empty)
    Just i :: Inti  -> (src :: Stringsrc, {- trace ("annm =" ++ show ann) -} ann :: Stringann)
               where (codes :: [String]codes, _:mname :: Stringmname:annots :: [String]annots) = splitAt :: Int -> [a] -> ([a], [a])splitAt i :: Inti ls :: [String]ls
                     ann :: AnnMapann   = annotParse :: String -> String -> AnnMapannotParse mname :: Stringmname ($) :: (a -> b) -> a -> b$ dropWhile :: (a -> Bool) -> [a] -> [a]dropWhile isSpace :: Char -> BoolisSpace ($) :: (a -> b) -> a -> b$ unlines :: [String] -> Stringunlines annots :: [Maybe (String, String)]annots
                     src :: Stringsrc   = unlines :: [String] -> Stringunlines codes :: [String]codes
                     -- mname = srcModuleName src

srcModuleName :: String -> String
srcModuleName :: String -> StringsrcModuleName = fromMaybe :: a -> Maybe a -> afromMaybe "Main" (.) :: (b -> c) -> (a -> b) -> a -> c. tokenModule :: [(TokenType, [Char])] -> Maybe [Char]tokenModule (.) :: (b -> c) -> (a -> b) -> a -> c. tokenise :: String -> [(TokenType, String)]tokenise
  
tokenModule :: [(TokenType, [Char])] -> Maybe [Char]tokenModule toks :: [(TokenType, [Char])]toks 
  = do i :: Inti <- findIndex :: (a -> Bool) -> [a] -> Maybe IntfindIndex ((Keyword :: TokenTypeKeyword, "module") (==) :: Eq a => a -> a -> Bool==) toks :: [(TokenType, String)]toks 
       let (_, toks' :: [(TokenType, [Char])]toks')  = splitAt :: Int -> [a] -> ([a], [a])splitAt (i :: Inti(+) :: Num a => a -> a -> a+2) toks :: [(TokenType, String)]toks
       j :: Intj <- findIndex :: (a -> Bool) -> [a] -> Maybe IntfindIndex ((Space :: TokenTypeSpace (==) :: Eq a => a -> a -> Bool==) (.) :: (b -> c) -> (a -> b) -> a -> c. fst :: (a, b) -> afst) toks' :: [(TokenType, String)]toks'
       let (toks'' :: [(TokenType, [Char])]toks'', _) = splitAt :: Int -> [a] -> ([a], [a])splitAt j :: Intj toks' :: [(TokenType, String)]toks'
       return :: Monad m => forall a. a -> m areturn ($) :: (a -> b) -> a -> b$ concatMap :: (a -> [b]) -> [a] -> [b]concatMap snd :: (a, b) -> bsnd toks'' :: [(TokenType, [Char])]toks''

breakS :: [Char]breakS = "MOUSEOVER ANNOTATIONS" 

annotParse :: String -> String -> AnnMap
annotParse :: String -> String -> AnnMapannotParse mname :: Stringmname = Ann :: Map Loc (String, String) -> AnnMapAnn (.) :: (b -> c) -> (a -> b) -> a -> c. fromList :: Ord k => [(k, a)] -> Map k aM.fromList (.) :: (b -> c) -> (a -> b) -> a -> c. parseLines ::
  [Char] -> Int -> [[Char]] -> [(Loc, ([Char], [Char]))]parseLines mname :: Stringmname 0 (.) :: (b -> c) -> (a -> b) -> a -> c. lines :: String -> [String]lines

parseLines ::
  [Char] -> Int -> [[Char]] -> [(Loc, ([Char], [Char]))]parseLines mname :: [Char]mname i :: Inti [] 
  = [] :: [a][]
parseLines mname :: [Char]mname i :: Inti ("":ls :: [[Char]]ls)      
  = parseLines ::
  [Char] -> Int -> [[Char]] -> [(Loc, ([Char], [Char]))]parseLines mname :: Stringmname (i :: Inti(+) :: Num a => a -> a -> a+1) ls :: [String]ls
parseLines mname :: [Char]mname i :: Inti (x :: [Char]x:f :: [Char]f:l :: [Char]l:c :: [Char]c:n :: [Char]n:rest :: [[Char]]rest) 
  | f :: [Char]f (/=) :: Eq a => a -> a -> Bool/= mname :: Stringmname -- `isSuffixOf` mname 
  = {- trace ("wrong annot f = " ++ f ++ " mname = " ++ mname) $ -} parseLines ::
  [Char] -> Int -> [[Char]] -> [(Loc, ([Char], [Char]))]parseLines mname :: Stringmname (i :: Inti (+) :: Num a => a -> a -> a+ 5 (+) :: Num a => a -> a -> a+ num :: Intnum) rest' :: [[Char]]rest'
  | otherwise :: Boolotherwise 
  = (L :: (Int, Int) -> LocL (line :: Intline, col :: Intcol), (x :: [Char]x, anns :: [Char]anns)) (:) :: a -> [a] -> [a]: parseLines ::
  [Char] -> Int -> [[Char]] -> [(Loc, ([Char], [Char]))]parseLines mname :: Stringmname (i :: Inti (+) :: Num a => a -> a -> a+ 5 (+) :: Num a => a -> a -> a+ num :: Intnum) rest' :: [[Char]]rest'
    where line :: Intline  = (read :: Read a => String -> aread l :: Intl) :: Int
          col :: Intcol   = (read :: Read a => String -> aread c :: Intc) :: Int
          num :: Intnum   = (read :: Read a => String -> aread n :: Intn) :: Int
          anns :: [Char]anns  = intercalate :: [a] -> [[a]] -> [a]intercalate "\n" ($) :: (a -> b) -> a -> b$ take :: Int -> [a] -> [a]take num :: Intnum rest :: [Either a b]rest
          rest' :: [[Char]]rest' = drop :: Int -> [a] -> [a]drop num :: Intnum rest :: [Either a b]rest
parseLines _ i :: Inti _              
  = error :: [Char] -> aerror ($) :: (a -> b) -> a -> b$ "Error Parsing Annot Input on Line: " (++) :: [a] -> [a] -> [a]++ show :: Show a => a -> Stringshow i :: Inti

takeFileName :: [Char] -> [Char]takeFileName s :: [Char]s = map :: (a -> b) -> [a] -> [b]map slashWhite :: Char -> CharslashWhite s :: Strings
  where slashWhite :: Char -> CharslashWhite '/' = ' '

instance D:Show ::
  (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> T:Show aShow AnnMap where
  show (Ann m :: Map Loc (String, String)m) = "\n\n" (++) :: [a] -> [a] -> [a]++ (concatMap :: (a -> [b]) -> [a] -> [b]concatMap ppAnnot :: (Loc, ([Char], String)) -> [Char]ppAnnot ($) :: (a -> b) -> a -> b$ toList :: Map k a -> [(k, a)]M.toList m :: Map Loc (String, String)m)
    where ppAnnot :: (Loc, ([Char], String)) -> [Char]ppAnnot (L (l :: Intl, c :: Intc), (x :: [Char]x,s :: Strings)) =  x :: [Char]x (++) :: [a] -> [a] -> [a]++ "\n" 
                                    (++) :: [a] -> [a] -> [a]++ show :: Show a => a -> Stringshow l :: Intl (++) :: [a] -> [a] -> [a]++ "\n"
                                    (++) :: [a] -> [a] -> [a]++ show :: Show a => a -> Stringshow c :: Intc (++) :: [a] -> [a] -> [a]++ "\n"
                                    (++) :: [a] -> [a] -> [a]++ show :: Show a => a -> Stringshow (length :: [a] -> Intlength ($) :: (a -> b) -> a -> b$ lines :: String -> [String]lines s :: Strings) (++) :: [a] -> [a] -> [a]++ "\n"
                                    (++) :: [a] -> [a] -> [a]++ s :: Strings (++) :: [a] -> [a] -> [a]++ "\n\n\n"