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
/= :: Loc -> Loc -> Bool
$c/= :: Loc -> Loc -> Bool
== :: Loc -> Loc -> Bool
$c== :: 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
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
$cp1Ord :: Eq Loc
Ord, Int -> Loc -> ShowS
[Loc] -> ShowS
Loc -> String
(Int -> Loc -> ShowS)
-> (Loc -> String) -> ([Loc] -> ShowS) -> Show Loc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Loc] -> ShowS
$cshowList :: [Loc] -> ShowS
show :: Loc -> String
$cshow :: Loc -> String
showsPrec :: Int -> Loc -> ShowS
$cshowsPrec :: Int -> Loc -> ShowS
Show)
hscolour :: Bool
-> Int
-> String
-> String
hscolour :: Bool -> Int -> ShowS
hscolour Bool
anchor Int
n = Bool -> Int -> (String, AnnMap) -> String
hsannot Bool
anchor Int
n ((String, AnnMap) -> String)
-> (String -> (String, AnnMap)) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String, AnnMap)
splitSrcAndAnns
hsannot :: Bool
-> Int
-> (String, AnnMap)
-> String
hsannot :: Bool -> Int -> (String, AnnMap) -> String
hsannot Bool
anchor Int
n =
ShowS
CSS.pre
ShowS -> ((String, AnnMap) -> String) -> (String, AnnMap) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
anchor then
(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 (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 (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 (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
is))
where n :: Int
n = String -> 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 -> ShowS
forall r. PrintfType r => String -> r
printf String
template (ShowS
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>"
insertAnnotAnchors :: [(TokenType, String, a)] -> [Either String (TokenType, String, a)]
insertAnnotAnchors :: [(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 :: [(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, 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) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
annots
src :: String
src = [String] -> String
unlines [String]
codes
srcModuleName :: String -> String
srcModuleName :: ShowS
srcModuleName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"Main" (Maybe String -> String) -> (String -> Maybe String) -> ShowS
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 (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
= 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
takeFileName :: ShowS
takeFileName String
s = (Char -> Char) -> ShowS
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 -> ShowS
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([String] -> 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n\n\n"