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
$c== :: Loc -> Loc -> Bool
== :: Loc -> Loc -> Bool
$c/= :: Loc -> Loc -> Bool
/= :: 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
$ccompare :: Loc -> Loc -> Ordering
compare :: Loc -> Loc -> Ordering
$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
>= :: Loc -> Loc -> Bool
$cmax :: Loc -> Loc -> Loc
max :: Loc -> Loc -> Loc
$cmin :: Loc -> Loc -> Loc
min :: Loc -> Loc -> Loc
Ord, Int -> Loc -> [Char] -> [Char]
[Loc] -> [Char] -> [Char]
Loc -> [Char]
(Int -> Loc -> [Char] -> [Char])
-> (Loc -> [Char]) -> ([Loc] -> [Char] -> [Char]) -> Show Loc
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Loc -> [Char] -> [Char]
showsPrec :: Int -> Loc -> [Char] -> [Char]
$cshow :: Loc -> [Char]
show :: Loc -> [Char]
$cshowList :: [Loc] -> [Char] -> [Char]
showList :: [Loc] -> [Char] -> [Char]
Show)
hscolour :: Bool
-> Int
-> String
-> String
hscolour :: Bool -> Int -> [Char] -> [Char]
hscolour Bool
anchor Int
n = Bool -> Int -> ([Char], AnnMap) -> [Char]
hsannot Bool
anchor Int
n (([Char], AnnMap) -> [Char])
-> ([Char] -> ([Char], AnnMap)) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ([Char], AnnMap)
splitSrcAndAnns
hsannot :: Bool
-> Int
-> (String, AnnMap)
-> String
hsannot :: Bool -> Int -> ([Char], AnnMap) -> [Char]
hsannot Bool
anchor Int
n =
[Char] -> [Char]
CSS.pre
([Char] -> [Char])
-> (([Char], AnnMap) -> [Char]) -> ([Char], AnnMap) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
anchor then
(Either [Char] (TokenType, [Char], Maybe [Char]) -> [Char])
-> [Either [Char] (TokenType, [Char], Maybe [Char])] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((TokenType, [Char], Maybe [Char]) -> [Char])
-> Either [Char] (TokenType, [Char], Maybe [Char]) -> [Char]
forall a. (a -> [Char]) -> Either [Char] a -> [Char]
renderAnchors (TokenType, [Char], Maybe [Char]) -> [Char]
renderAnnotToken)
([Either [Char] (TokenType, [Char], Maybe [Char])] -> [Char])
-> ([(TokenType, [Char], Maybe [Char])]
-> [Either [Char] (TokenType, [Char], Maybe [Char])])
-> [(TokenType, [Char], Maybe [Char])]
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TokenType, [Char], Maybe [Char])]
-> [Either [Char] (TokenType, [Char], Maybe [Char])]
forall a.
[(TokenType, [Char], a)] -> [Either [Char] (TokenType, [Char], a)]
insertAnnotAnchors
else ((TokenType, [Char], Maybe [Char]) -> [Char])
-> [(TokenType, [Char], Maybe [Char])] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TokenType, [Char], Maybe [Char]) -> [Char]
renderAnnotToken)
([(TokenType, [Char], Maybe [Char])] -> [Char])
-> (([Char], AnnMap) -> [(TokenType, [Char], Maybe [Char])])
-> ([Char], AnnMap)
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], AnnMap) -> [(TokenType, [Char], Maybe [Char])]
annotTokenise
annotTokenise :: (String, AnnMap) -> [(TokenType, String, Maybe String)]
annotTokenise :: ([Char], AnnMap) -> [(TokenType, [Char], Maybe [Char])]
annotTokenise ([Char]
src, Ann Map Loc ([Char], [Char])
annm)
= ((TokenType, [Char])
-> Maybe ([Char], [Char]) -> (TokenType, [Char], Maybe [Char]))
-> [(TokenType, [Char])]
-> [Maybe ([Char], [Char])]
-> [(TokenType, [Char], Maybe [Char])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(TokenType
x,[Char]
y) Maybe ([Char], [Char])
z -> (TokenType
x,[Char]
y, ([Char], [Char]) -> [Char]
forall a b. (a, b) -> b
snd (([Char], [Char]) -> [Char])
-> Maybe ([Char], [Char]) -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Maybe ([Char], [Char])
z)) [(TokenType, [Char])]
toks [Maybe ([Char], [Char])]
annots
where toks :: [(TokenType, [Char])]
toks = [Char] -> [(TokenType, [Char])]
tokenise [Char]
src
spans :: [Loc]
spans = [[Char]] -> [Loc]
tokenSpans ([[Char]] -> [Loc]) -> [[Char]] -> [Loc]
forall a b. (a -> b) -> a -> b
$ ((TokenType, [Char]) -> [Char])
-> [(TokenType, [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (TokenType, [Char]) -> [Char]
forall a b. (a, b) -> b
snd [(TokenType, [Char])]
toks
annots :: [Maybe ([Char], [Char])]
annots = (Loc -> Maybe ([Char], [Char]))
-> [Loc] -> [Maybe ([Char], [Char])]
forall a b. (a -> b) -> [a] -> [b]
map (Loc -> Map Loc ([Char], [Char]) -> Maybe ([Char], [Char])
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Loc ([Char], [Char])
annm) [Loc]
spans
tokenSpans :: [String] -> [Loc]
tokenSpans :: [[Char]] -> [Loc]
tokenSpans = (Loc -> [Char] -> Loc) -> Loc -> [[Char]] -> [Loc]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Loc -> [Char] -> Loc
plusLoc ((Int, Int) -> Loc
L (Int
1, Int
1))
plusLoc :: Loc -> String -> Loc
plusLoc :: Loc -> [Char] -> Loc
plusLoc (L (Int
l, Int
c)) [Char]
s
= case Char
'\n' Char -> [Char] -> [Int]
forall a. Eq a => a -> [a] -> [Int]
`elemIndices` [Char]
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 a. [a] -> 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 a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
is))
where n :: Int
n = [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s
renderAnnotToken :: (TokenType, String, Maybe String) -> String
renderAnnotToken :: (TokenType, [Char], Maybe [Char]) -> [Char]
renderAnnotToken (TokenType
x,[Char]
y, Maybe [Char]
Nothing)
= (TokenType, [Char]) -> [Char]
CSS.renderToken (TokenType
x, [Char]
y)
renderAnnotToken (TokenType
x,[Char]
y, Just [Char]
ann)
= [Char] -> [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
template ([Char] -> [Char]
escape [Char]
ann) ((TokenType, [Char]) -> [Char]
CSS.renderToken (TokenType
x, [Char]
y))
where template :: [Char]
template = [Char]
"<a class=annot href=\"#\"><span class=annottext>%s</span>%s</a>"
insertAnnotAnchors :: [(TokenType, String, a)] -> [Either String (TokenType, String, a)]
insertAnnotAnchors :: forall a.
[(TokenType, [Char], a)] -> [Either [Char] (TokenType, [Char], a)]
insertAnnotAnchors [(TokenType, [Char], a)]
toks
= [((TokenType, [Char]), (TokenType, [Char], a))]
-> [Either [Char] (TokenType, [Char])]
-> [Either [Char] (TokenType, [Char], a)]
forall b c a. Eq b => [(b, c)] -> [Either a b] -> [Either a c]
stitch ([(TokenType, [Char])]
-> [(TokenType, [Char], a)]
-> [((TokenType, [Char]), (TokenType, [Char], a))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(TokenType, [Char])]
toks' [(TokenType, [Char], a)]
toks) ([Either [Char] (TokenType, [Char])]
-> [Either [Char] (TokenType, [Char], a)])
-> [Either [Char] (TokenType, [Char])]
-> [Either [Char] (TokenType, [Char], a)]
forall a b. (a -> b) -> a -> b
$ [(TokenType, [Char])] -> [Either [Char] (TokenType, [Char])]
insertAnchors [(TokenType, [Char])]
toks'
where toks' :: [(TokenType, [Char])]
toks' = [(TokenType
x,[Char]
y) | (TokenType
x,[Char]
y,a
_) <- [(TokenType, [Char], 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)
= (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
= [Char] -> [Either a c]
forall a. HasCallStack => [Char] -> a
error [Char]
"stitch"
stitch [(b, c)]
_ []
= []
splitSrcAndAnns :: String -> (String, AnnMap)
splitSrcAndAnns :: [Char] -> ([Char], AnnMap)
splitSrcAndAnns [Char]
s =
let ls :: [[Char]]
ls = [Char] -> [[Char]]
lines [Char]
s in
case ([Char] -> Bool) -> [[Char]] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex ([Char]
breakS [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
==) [[Char]]
ls of
Maybe Int
Nothing -> ([Char]
s, Map Loc ([Char], [Char]) -> AnnMap
Ann Map Loc ([Char], [Char])
forall k a. Map k a
M.empty)
Just Int
i -> ([Char]
src, AnnMap
ann)
where ([[Char]]
codes, [Char]
_:[Char]
mname:[[Char]]
annots) = Int -> [[Char]] -> ([[Char]], [[Char]])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [[Char]]
ls
ann :: AnnMap
ann = [Char] -> [Char] -> AnnMap
annotParse [Char]
mname ([Char] -> AnnMap) -> [Char] -> AnnMap
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[Char]]
annots
src :: [Char]
src = [[Char]] -> [Char]
unlines [[Char]]
codes
srcModuleName :: String -> String
srcModuleName :: [Char] -> [Char]
srcModuleName = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"Main" (Maybe [Char] -> [Char])
-> ([Char] -> Maybe [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TokenType, [Char])] -> Maybe [Char]
tokenModule ([(TokenType, [Char])] -> Maybe [Char])
-> ([Char] -> [(TokenType, [Char])]) -> [Char] -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [(TokenType, [Char])]
tokenise
tokenModule :: [(TokenType, [Char])] -> Maybe [Char]
tokenModule [(TokenType, [Char])]
toks
= do i <- ((TokenType, [Char]) -> Bool) -> [(TokenType, [Char])] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex ((TokenType
Keyword, [Char]
"module") (TokenType, [Char]) -> (TokenType, [Char]) -> Bool
forall a. Eq a => a -> a -> Bool
==) [(TokenType, [Char])]
toks
let (_, toks') = splitAt (i+2) toks
j <- findIndex ((Space ==) . fst) toks'
let (toks'', _) = splitAt j toks'
return $ concatMap snd toks''
breakS :: [Char]
breakS = [Char]
"MOUSEOVER ANNOTATIONS"
annotParse :: String -> String -> AnnMap
annotParse :: [Char] -> [Char] -> AnnMap
annotParse [Char]
mname = Map Loc ([Char], [Char]) -> AnnMap
Ann (Map Loc ([Char], [Char]) -> AnnMap)
-> ([Char] -> Map Loc ([Char], [Char])) -> [Char] -> AnnMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Loc, ([Char], [Char]))] -> Map Loc ([Char], [Char])
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Loc, ([Char], [Char]))] -> Map Loc ([Char], [Char]))
-> ([Char] -> [(Loc, ([Char], [Char]))])
-> [Char]
-> Map Loc ([Char], [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Int -> [[Char]] -> [(Loc, ([Char], [Char]))]
parseLines [Char]
mname Int
0 ([[Char]] -> [(Loc, ([Char], [Char]))])
-> ([Char] -> [[Char]]) -> [Char] -> [(Loc, ([Char], [Char]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines
parseLines :: [Char] -> Int -> [[Char]] -> [(Loc, ([Char], [Char]))]
parseLines [Char]
mname Int
i []
= []
parseLines [Char]
mname Int
i ([Char]
"":[[Char]]
ls)
= [Char] -> Int -> [[Char]] -> [(Loc, ([Char], [Char]))]
parseLines [Char]
mname (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [[Char]]
ls
parseLines [Char]
mname Int
i ([Char]
x:[Char]
f:[Char]
l:[Char]
c:[Char]
n:[[Char]]
rest)
| [Char]
f [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
mname
= [Char] -> Int -> [[Char]] -> [(Loc, ([Char], [Char]))]
parseLines [Char]
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) [[Char]]
rest'
| Bool
otherwise
= ((Int, Int) -> Loc
L (Int
line, Int
col), ([Char]
x, [Char]
anns)) (Loc, ([Char], [Char]))
-> [(Loc, ([Char], [Char]))] -> [(Loc, ([Char], [Char]))]
forall a. a -> [a] -> [a]
: [Char] -> Int -> [[Char]] -> [(Loc, ([Char], [Char]))]
parseLines [Char]
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) [[Char]]
rest'
where line :: Int
line = ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
l) :: Int
col :: Int
col = ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
c) :: Int
num :: Int
num = ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
n) :: Int
anns :: [Char]
anns = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
take Int
num [[Char]]
rest
rest' :: [[Char]]
rest' = Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
drop Int
num [[Char]]
rest
parseLines [Char]
_ Int
i [[Char]]
_
= [Char] -> [(Loc, ([Char], [Char]))]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [(Loc, ([Char], [Char]))])
-> [Char] -> [(Loc, ([Char], [Char]))]
forall a b. (a -> b) -> a -> b
$ [Char]
"Error Parsing Annot Input on Line: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i
takeFileName :: [Char] -> [Char]
takeFileName [Char]
s = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
slashWhite [Char]
s
where slashWhite :: Char -> Char
slashWhite Char
'/' = Char
' '
instance Show AnnMap where
show :: AnnMap -> [Char]
show (Ann Map Loc ([Char], [Char])
m) = [Char]
"\n\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (((Loc, ([Char], [Char])) -> [Char])
-> [(Loc, ([Char], [Char]))] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Loc, ([Char], [Char])) -> [Char]
ppAnnot ([(Loc, ([Char], [Char]))] -> [Char])
-> [(Loc, ([Char], [Char]))] -> [Char]
forall a b. (a -> b) -> a -> b
$ Map Loc ([Char], [Char]) -> [(Loc, ([Char], [Char]))]
forall k a. Map k a -> [(k, a)]
M.toList Map Loc ([Char], [Char])
m)
where ppAnnot :: (Loc, ([Char], [Char])) -> [Char]
ppAnnot (L (Int
l, Int
c), ([Char]
x,[Char]
s)) = [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
l [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[Char]] -> Int) -> [[Char]] -> Int
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
lines [Char]
s) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n\n\n"