-- | 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 (Loc -> Loc -> Bool
(Loc -> Loc -> Bool) -> (Loc -> Loc -> Bool) -> Eq Loc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Loc -> Loc -> Bool
== :: Loc -> Loc -> Bool
$c/= :: Loc -> Loc -> Bool
/= :: Loc -> Loc -> Bool
Eq, Eq Loc
Eq Loc =>
(Loc -> Loc -> Ordering)
-> (Loc -> Loc -> Bool)
-> (Loc -> Loc -> Bool)
-> (Loc -> Loc -> Bool)
-> (Loc -> Loc -> Bool)
-> (Loc -> Loc -> Loc)
-> (Loc -> Loc -> Loc)
-> Ord Loc
Loc -> Loc -> Bool
Loc -> Loc -> Ordering
Loc -> Loc -> Loc
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Loc -> Loc -> Ordering
compare :: Loc -> Loc -> Ordering
$c< :: Loc -> Loc -> Bool
< :: Loc -> Loc -> Bool
$c<= :: Loc -> Loc -> Bool
<= :: Loc -> Loc -> Bool
$c> :: Loc -> Loc -> Bool
> :: Loc -> Loc -> Bool
$c>= :: Loc -> Loc -> Bool
>= :: Loc -> Loc -> Bool
$cmax :: Loc -> Loc -> Loc
max :: Loc -> Loc -> Loc
$cmin :: Loc -> Loc -> Loc
min :: Loc -> Loc -> Loc
Ord, Int -> Loc -> String -> String
[Loc] -> String -> String
Loc -> String
(Int -> Loc -> String -> String)
-> (Loc -> String) -> ([Loc] -> String -> String) -> Show Loc
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Loc -> String -> String
showsPrec :: Int -> Loc -> String -> String
$cshow :: Loc -> String
show :: Loc -> String
$cshowList :: [Loc] -> String -> String
showList :: [Loc] -> String -> String
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 :: Bool -> Int -> String -> String
hscolour Bool
anchor Int
n = Bool -> Int -> (String, AnnMap) -> String
hsannot Bool
anchor Int
n ((String, AnnMap) -> String)
-> (String -> (String, AnnMap)) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String, AnnMap)
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 :: Bool -> Int -> (String, AnnMap) -> String
hsannot Bool
anchor Int
n = 
    String -> String
CSS.pre
    (String -> String)
-> ((String, AnnMap) -> String) -> (String, AnnMap) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
anchor then -- renderNewLinesAnchors n .
                      (Either String (TokenType, String, Maybe String) -> String)
-> [Either String (TokenType, String, Maybe String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((TokenType, String, Maybe String) -> String)
-> Either String (TokenType, String, Maybe String) -> String
forall a. (a -> String) -> Either String a -> String
renderAnchors (TokenType, String, Maybe String) -> String
renderAnnotToken)
                      ([Either String (TokenType, String, Maybe String)] -> String)
-> ([(TokenType, String, Maybe String)]
    -> [Either String (TokenType, String, Maybe String)])
-> [(TokenType, String, Maybe String)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TokenType, String, Maybe String)]
-> [Either String (TokenType, String, Maybe String)]
forall a.
[(TokenType, String, a)] -> [Either String (TokenType, String, a)]
insertAnnotAnchors
                 else ((TokenType, String, Maybe String) -> String)
-> [(TokenType, String, Maybe String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TokenType, String, Maybe String) -> String
renderAnnotToken)
    ([(TokenType, String, Maybe String)] -> String)
-> ((String, AnnMap) -> [(TokenType, String, Maybe String)])
-> (String, AnnMap)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, AnnMap) -> [(TokenType, String, Maybe String)]
annotTokenise

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

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

plusLoc :: Loc -> String -> Loc
plusLoc :: Loc -> String -> Loc
plusLoc (L (Int
l, Int
c)) String
s 
  = case Char
'\n' Char -> String -> [Int]
forall a. Eq a => a -> [a] -> [Int]
`elemIndices` String
s of
      [] -> (Int, Int) -> Loc
L (Int
l, (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n))
      [Int]
is -> (Int, Int) -> Loc
L ((Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
is), (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
is))
    where n :: Int
n = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s

renderAnnotToken :: (TokenType, String, Maybe String) -> String
renderAnnotToken :: (TokenType, String, Maybe String) -> String
renderAnnotToken (TokenType
x,String
y, Maybe String
Nothing) 
  = (TokenType, String) -> String
CSS.renderToken (TokenType
x, String
y)
renderAnnotToken (TokenType
x,String
y, Just String
ann)
  = String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
template (String -> String
escape String
ann) ((TokenType, String) -> String
CSS.renderToken (TokenType
x, String
y))
    where template :: String
template = String
"<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 :: forall a.
[(TokenType, String, a)] -> [Either String (TokenType, String, a)]
insertAnnotAnchors [(TokenType, String, a)]
toks 
  = [((TokenType, String), (TokenType, String, a))]
-> [Either String (TokenType, String)]
-> [Either String (TokenType, String, a)]
forall b c a. Eq b => [(b, c)] -> [Either a b] -> [Either a c]
stitch ([(TokenType, String)]
-> [(TokenType, String, a)]
-> [((TokenType, String), (TokenType, String, a))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(TokenType, String)]
toks' [(TokenType, String, a)]
toks) ([Either String (TokenType, String)]
 -> [Either String (TokenType, String, a)])
-> [Either String (TokenType, String)]
-> [Either String (TokenType, String, a)]
forall a b. (a -> b) -> a -> b
$ [(TokenType, String)] -> [Either String (TokenType, String)]
insertAnchors [(TokenType, String)]
toks'
  where toks' :: [(TokenType, String)]
toks' = [(TokenType
x,String
y) | (TokenType
x,String
y,a
_) <- [(TokenType, String, a)]
toks] 

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


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

srcModuleName :: String -> String
srcModuleName :: String -> String
srcModuleName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"Main" (Maybe String -> String)
-> (String -> Maybe String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TokenType, String)] -> Maybe String
tokenModule ([(TokenType, String)] -> Maybe String)
-> (String -> [(TokenType, String)]) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(TokenType, String)]
tokenise
  
tokenModule :: [(TokenType, String)] -> Maybe String
tokenModule [(TokenType, String)]
toks 
  = do Int
i <- ((TokenType, String) -> Bool) -> [(TokenType, String)] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex ((TokenType
Keyword, String
"module") (TokenType, String) -> (TokenType, String) -> Bool
forall a. Eq a => a -> a -> Bool
==) [(TokenType, String)]
toks 
       let ([(TokenType, String)]
_, [(TokenType, String)]
toks')  = Int
-> [(TokenType, String)]
-> ([(TokenType, String)], [(TokenType, String)])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) [(TokenType, String)]
toks
       Int
j <- ((TokenType, String) -> Bool) -> [(TokenType, String)] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex ((TokenType
Space TokenType -> TokenType -> Bool
forall a. Eq a => a -> a -> Bool
==) (TokenType -> Bool)
-> ((TokenType, String) -> TokenType)
-> (TokenType, String)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TokenType, String) -> TokenType
forall a b. (a, b) -> a
fst) [(TokenType, String)]
toks'
       let ([(TokenType, String)]
toks'', [(TokenType, String)]
_) = Int
-> [(TokenType, String)]
-> ([(TokenType, String)], [(TokenType, String)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
j [(TokenType, String)]
toks'
       String -> Maybe String
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ((TokenType, String) -> String) -> [(TokenType, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TokenType, String) -> String
forall a b. (a, b) -> b
snd [(TokenType, String)]
toks''

breakS :: String
breakS = String
"MOUSEOVER ANNOTATIONS" 

annotParse :: String -> String -> AnnMap
annotParse :: String -> String -> AnnMap
annotParse String
mname = Map Loc (String, String) -> AnnMap
Ann (Map Loc (String, String) -> AnnMap)
-> (String -> Map Loc (String, String)) -> String -> AnnMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Loc, (String, String))] -> Map Loc (String, String)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Loc, (String, String))] -> Map Loc (String, String))
-> (String -> [(Loc, (String, String))])
-> String
-> Map Loc (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int -> [String] -> [(Loc, (String, String))]
parseLines String
mname Int
0 ([String] -> [(Loc, (String, String))])
-> (String -> [String]) -> String -> [(Loc, (String, String))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

parseLines :: String -> Int -> [String] -> [(Loc, (String, String))]
parseLines String
mname Int
i [] 
  = []
parseLines String
mname Int
i (String
"":[String]
ls)      
  = String -> Int -> [String] -> [(Loc, (String, String))]
parseLines String
mname (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [String]
ls
parseLines String
mname Int
i (String
x:String
f:String
l:String
c:String
n:[String]
rest) 
  | String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
mname -- `isSuffixOf` mname 
  = {- trace ("wrong annot f = " ++ f ++ " mname = " ++ mname) $ -} String -> Int -> [String] -> [(Loc, (String, String))]
parseLines String
mname (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
num) [String]
rest'
  | Bool
otherwise 
  = ((Int, Int) -> Loc
L (Int
line, Int
col), (String
x, String
anns)) (Loc, (String, String))
-> [(Loc, (String, String))] -> [(Loc, (String, String))]
forall a. a -> [a] -> [a]
: String -> Int -> [String] -> [(Loc, (String, String))]
parseLines String
mname (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
num) [String]
rest'
    where line :: Int
line  = (String -> Int
forall a. Read a => String -> a
read String
l) :: Int
          col :: Int
col   = (String -> Int
forall a. Read a => String -> a
read String
c) :: Int
          num :: Int
num   = (String -> Int
forall a. Read a => String -> a
read String
n) :: Int
          anns :: String
anns  = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
num [String]
rest
          rest' :: [String]
rest' = Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
num [String]
rest
parseLines String
_ Int
i [String]
_              
  = String -> [(Loc, (String, String))]
forall a. HasCallStack => String -> a
error (String -> [(Loc, (String, String))])
-> String -> [(Loc, (String, String))]
forall a b. (a -> b) -> a -> b
$ String
"Error Parsing Annot Input on Line: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i

takeFileName :: String -> String
takeFileName String
s = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
slashWhite String
s
  where slashWhite :: Char -> Char
slashWhite Char
'/' = Char
' '

instance Show AnnMap where
  show :: AnnMap -> String
show (Ann Map Loc (String, String)
m) = String
"\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (((Loc, (String, String)) -> String)
-> [(Loc, (String, String))] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Loc, (String, String)) -> String
ppAnnot ([(Loc, (String, String))] -> String)
-> [(Loc, (String, String))] -> String
forall a b. (a -> b) -> a -> b
$ Map Loc (String, String) -> [(Loc, (String, String))]
forall k a. Map k a -> [(k, a)]
M.toList Map Loc (String, String)
m)
    where ppAnnot :: (Loc, (String, String)) -> String
ppAnnot (L (Int
l, Int
c), (String
x,String
s)) =  String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" 
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> Int) -> [String] -> Int
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
s) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n\n"