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 -> {VV_int:Int | (0 <= VV_int),(x#agV <= 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