-- | 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Loc -> Loc -> Bool
$c/= :: Loc -> Loc -> Bool
== :: Loc -> Loc -> Bool
$c== :: Loc -> Loc -> Bool
Eq, Eq 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
min :: Loc -> Loc -> Loc
$cmin :: Loc -> Loc -> Loc
max :: Loc -> Loc -> Loc
$cmax :: Loc -> Loc -> Loc
>= :: Loc -> Loc -> Bool
$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
compare :: Loc -> Loc -> Ordering
$ccompare :: Loc -> Loc -> Ordering
Ord, Int -> Loc -> String -> String
[Loc] -> String -> String
Loc -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Loc] -> String -> String
$cshowList :: [Loc] -> String -> String
show :: Loc -> String
$cshow :: Loc -> String
showsPrec :: Int -> Loc -> String -> String
$cshowsPrec :: Int -> 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 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
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
anchor then -- renderNewLinesAnchors n .
                      forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. (a -> String) -> Either String a -> String
renderAnchors (TokenType, String, Maybe String) -> String
renderAnnotToken)
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
[(TokenType, String, a)] -> [Either String (TokenType, String, a)]
insertAnnotAnchors
                 else forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TokenType, String, Maybe String) -> String
renderAnnotToken)
    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) 
  = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(TokenType
x,String
y) Maybe (String, String)
z -> (TokenType
x,String
y, forall a b. (a, b) -> b
snd 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(TokenType, String)]
toks 
        annots :: [Maybe (String, String)]
annots     = forall a b. (a -> b) -> [a] -> [b]
map (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 = 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' forall a. Eq a => a -> [a] -> [Int]
`elemIndices` String
s of
      [] -> (Int, Int) -> Loc
L (Int
l, (Int
c forall a. Num a => a -> a -> a
+ Int
n))
      [Int]
is -> (Int, Int) -> Loc
L ((Int
l forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
is), (Int
n forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
is))
    where n :: Int
n = 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)
  = 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 
  = forall b c a. Eq b => [(b, c)] -> [Either a b] -> [Either a c]
stitch (forall a b. [a] -> [b] -> [(a, b)]
zip [(TokenType, String)]
toks' [(TokenType, String, a)]
toks) 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)
  = (forall a b. a -> Either a b
Left a
a) forall a. a -> [a] -> [a]
: 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 forall a. Eq a => a -> a -> Bool
== b
x' 
  = (forall a b. b -> Either a b
Right c
y) forall a. a -> [a] -> [a]
: forall b c a. Eq b => [(b, c)] -> [Either a b] -> [Either a c]
stitch [(b, c)]
xys [Either a b]
rest
  | Bool
otherwise
  = 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 forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (String
breakS forall a. Eq a => a -> a -> Bool
==) [String]
ls of
    Maybe Int
Nothing -> (String
s, Map Loc (String, String) -> AnnMap
Ann 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) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [String]
ls
                     ann :: AnnMap
ann   = String -> String -> AnnMap
annotParse String
mname forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace 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 = forall a. a -> Maybe a -> a
fromMaybe String
"Main" forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TokenType, String)] -> Maybe String
tokenModule 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 <- forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex ((TokenType
Keyword, String
"module") forall a. Eq a => a -> a -> Bool
==) [(TokenType, String)]
toks 
       let ([(TokenType, String)]
_, [(TokenType, String)]
toks')  = forall a. Int -> [a] -> ([a], [a])
splitAt (Int
iforall a. Num a => a -> a -> a
+Int
2) [(TokenType, String)]
toks
       Int
j <- forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex ((TokenType
Space forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(TokenType, String)]
toks'
       let ([(TokenType, String)]
toks'', [(TokenType, String)]
_) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
j [(TokenType, String)]
toks'
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int -> [String] -> [(Loc, (String, String))]
parseLines String
mname Int
0 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
iforall 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 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 forall a. Num a => a -> a -> a
+ Int
5 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)) forall a. a -> [a] -> [a]
: String -> Int -> [String] -> [(Loc, (String, String))]
parseLines String
mname (Int
i forall a. Num a => a -> a -> a
+ Int
5 forall a. Num a => a -> a -> a
+ Int
num) [String]
rest'
    where line :: Int
line  = (forall a. Read a => String -> a
read String
l) :: Int
          col :: Int
col   = (forall a. Read a => String -> a
read String
c) :: Int
          num :: Int
num   = (forall a. Read a => String -> a
read String
n) :: Int
          anns :: String
anns  = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
num [String]
rest
          rest' :: [String]
rest' = forall a. Int -> [a] -> [a]
drop Int
num [String]
rest
parseLines String
_ Int
i [String]
_              
  = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Error Parsing Annot Input on Line: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i

takeFileName :: String -> String
takeFileName String
s = 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" forall a. [a] -> [a] -> [a]
++ (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Loc, (String, String)) -> String
ppAnnot forall a b. (a -> b) -> a -> b
$ 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 forall a. [a] -> [a] -> [a]
++ String
"\n" 
                                    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
l forall a. [a] -> [a] -> [a]
++ String
"\n"
                                    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
c forall a. [a] -> [a] -> [a]
++ String
"\n"
                                    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
s) forall a. [a] -> [a] -> [a]
++ String
"\n"
                                    forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
"\n\n\n"