1-- | Formats Haskell source code as HTML with CSS and Mouseover Type Annotations
2module Language.Haskell.HsColour.ACSS (
3    hscolour
4  , hsannot
5  , AnnMap (..)
6  , Loc (..)
7  , breakS
8  , srcModuleName
9  ) where
10
11import Language.Haskell.HsColour.Anchors
12import Language.Haskell.HsColour.Classify as Classify
13import Language.Haskell.HsColour.HTML (renderAnchors, renderComment,
14                                       renderNewLinesAnchors, escape)
15import qualified Language.Haskell.HsColour.CSS as CSS
16
17import Data.Maybe  (fromMaybe)
18import qualified Data.Map as M
19import Data.List   (isSuffixOf, findIndex, elemIndices, intercalate)
20import Data.Char   (isLower, isSpace, isAlphaNum)
21import Text.Printf
22import Debug.Trace
23
24newtype AnnMap = Ann (M.Map Loc (String, String))
25newtype Loc    = L (Int, Int) deriving (Eq, Ord, Show)
26
27-- | Formats Haskell source code using HTML and mouse-over annotations
28hscolour :: Bool     -- ^ Whether to include anchors.
29         -> Int      -- ^ Starting line number (for line anchors).
30         -> String   -- ^ Haskell source code, Annotations as comments at end
31         -> String   -- ^ Coloured Haskell source code.
32
33hscolour anchor n = hsannot anchor n . splitSrcAndAnns
34
35-- | Formats Haskell source code using HTML and mouse-over annotations
36hsannot  :: Bool             -- ^ Whether to include anchors.
37         -> Int              -- ^ Starting line number (for line anchors).
38         -> (String, AnnMap) -- ^ Haskell Source, Annotations
39         -> String           -- ^ Coloured Haskell source code.
40
41hsannot anchor n =
42    CSS.pre
43    . (if anchor then -- renderNewLinesAnchors n .
44                      concatMap (renderAnchors renderAnnotToken)
45                      . insertAnnotAnchors
46                 else concatMap renderAnnotToken)
47    . annotTokenise
48
49annotTokenise  :: (String, AnnMap) -> [(TokenType, String, Maybe String)]
50annotTokenise (src, Ann annm)
51  = zipWith (\(x,y) z -> (x,y, snd `fmap` z)) toks annots
52  where toks       = tokenise src
53        spans      = tokenSpans $ map snd toks
54        annots     = map (`M.lookup` annm) spans
55
56tokenSpans :: [String] -> [Loc]
57tokenSpans = scanl plusLoc (L (1, 1))
58
59plusLoc :: Loc -> String -> Loc
60plusLoc (L (l, c)) s
61  = case '\n' `elemIndices` s of
62      [] -> L (l, (c + n))
63      is -> L ((l + length is), (n - maximum is))
64    where n = length s
65
66renderAnnotToken :: (TokenType, String, Maybe String) -> String
67renderAnnotToken (x,y, Nothing)
68  = CSS.renderToken (x, y)
69renderAnnotToken (x,y, Just ann)
70  = printf template (escape ann) (CSS.renderToken (x, y))
71    where template = "<a class=annot href=\"#\"><span class=annottext>%s</span>%s</a>"
72
73{- Example Annotation:
74<a class=annot href="#"><span class=annottext>x#agV:Int -&gt; {VV_int:Int | (0 &lt;= VV_int),(x#agV &lt;= VV_int)}</span>
75<span class='hs-definition'>NOWTRYTHIS</span></a>
76-}
77
78
79insertAnnotAnchors :: [(TokenType, String, a)] -> [Either String (TokenType, String, a)]
80insertAnnotAnchors toks
81  = stitch (zip toks' toks) $ insertAnchors toks'
82  where toks' = [(x,y) | (x,y,_) <- toks]
83
84stitch ::  Eq b => [(b, c)] -> [Either a b] -> [Either a c]
85stitch xys ((Left a) : rest)
86  = (Left a) : stitch xys rest
87stitch ((x,y):xys) ((Right x'):rest)
88  | x == x'
89  = (Right y) : stitch xys rest
90  | otherwise
91  = error "stitch"
92stitch _ []
93  = []
94
95
96splitSrcAndAnns ::  String -> (String, AnnMap)
97splitSrcAndAnns s =
98  let ls = lines s in
99  case findIndex (breakS ==) ls of
100    Nothing -> (s, Ann M.empty)
101    Just i  -> (src, {- trace ("annm =" ++ show ann) -} ann)
102               where (codes, _:mname:annots) = splitAt i ls
103                     ann   = annotParse mname $ dropWhile isSpace $ unlines annots
104                     src   = unlines codes
105                     -- mname = srcModuleName src
106
107srcModuleName :: String -> String
108srcModuleName = fromMaybe "Main" . tokenModule . tokenise
109
110tokenModule toks
111  = do i <- findIndex ((Keyword, "module") ==) toks
112       let (_, toks')  = splitAt (i+2) toks
113       j <- findIndex ((Space ==) . fst) toks'
114       let (toks'', _) = splitAt j toks'
115       return $ concatMap snd toks''
116
117breakS = "MOUSEOVER ANNOTATIONS"
118
119annotParse :: String -> String -> AnnMap
120annotParse mname = Ann . M.fromList . parseLines mname 0 . lines
121
122parseLines mname i []
123  = []
124parseLines mname i ("":ls)
125  = parseLines mname (i+1) ls
126parseLines mname i (x:f:l:c:n:rest)
127  | f /= mname -- `isSuffixOf` mname
128  = {- trace ("wrong annot f = " ++ f ++ " mname = " ++ mname) $ -} parseLines mname (i + 5 + num) rest'
129  | otherwise
130  = (L (line, col), (x, anns)) : parseLines mname (i + 5 + num) rest'
131    where line  = (read l) :: Int
132          col   = (read c) :: Int
133          num   = (read n) :: Int
134          anns  = intercalate "\n" $ take num rest
135          rest' = drop num rest
136parseLines _ i _
137  = error $ "Error Parsing Annot Input on Line: " ++ show i
138
139takeFileName s = map slashWhite s
140  where slashWhite '/' = ' '
141
142instance Show AnnMap where
143  show (Ann m) = "\n\n" ++ (concatMap ppAnnot $ M.toList m)
144    where ppAnnot (L (l, c), (x,s)) =  x ++ "\n"
145                                    ++ show l ++ "\n"
146                                    ++ show c ++ "\n"
147                                    ++ show (length $ lines s) ++ "\n"
148                                    ++ s ++ "\n\n\n"
149