1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
-- | 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 -> {VV_int:Int | (0 <= VV_int),(x#agV <= 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"
|
