module Language.Haskell.HsColour.Anchors
( insertAnchors
) where
import Language.Haskell.HsColour.Classify
import Language.Haskell.HsColour.General
import Data.List
import Data.Char (isUpper, isLower, isDigit, ord, intToDigit)
type Anchor = String
insertAnchors :: [(TokenType,String)] -> [Either Anchor (TokenType,String)]
insertAnchors :: [(TokenType, String)] -> [Either String (TokenType, String)]
insertAnchors = ST -> [(TokenType, String)] -> [Either String (TokenType, String)]
anchor ST
emptyST
anchor :: ST -> [(TokenType, String)] -> [Either String (TokenType, String)]
anchor :: ST -> [(TokenType, String)] -> [Either String (TokenType, String)]
anchor ST
st [(TokenType, String)]
s = case ST -> [(TokenType, String)] -> Maybe String
identifier ST
st [(TokenType, String)]
s of
Maybe String
Nothing -> ST -> [(TokenType, String)] -> [Either String (TokenType, String)]
emit ST
st [(TokenType, String)]
s
Just String
v -> String -> Either String (TokenType, String)
forall a b. a -> Either a b
Left (String -> String
escape String
v)Either String (TokenType, String)
-> [Either String (TokenType, String)]
-> [Either String (TokenType, String)]
forall a. a -> [a] -> [a]
: ST -> [(TokenType, String)] -> [Either String (TokenType, String)]
emit (String -> ST -> ST
insertST String
v ST
st) [(TokenType, String)]
s
escape :: String -> String
escape :: String -> String
escape = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
enc
where enc :: Char -> String
enc Char
x | Char -> Bool
isDigit Char
x
Bool -> Bool -> Bool
|| Char -> Bool
isURIFragmentValid Char
x
Bool -> Bool -> Bool
|| Char -> Bool
isLower Char
x
Bool -> Bool -> Bool
|| Char -> Bool
isUpper Char
x = [Char
x]
| Char -> Int
ord Char
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
256 = [Char
x]
| Bool
otherwise = [Char
'%',Int -> Char
hexHi (Char -> Int
ord Char
x), Int -> Char
hexLo (Char -> Int
ord Char
x)]
hexHi :: Int -> Char
hexHi Int
d = Int -> Char
intToDigit (Int
dInt -> Int -> Int
forall a. Integral a => a -> a -> a
`div`Int
16)
hexLo :: Int -> Char
hexLo Int
d = Int -> Char
intToDigit (Int
dInt -> Int -> Int
forall a. Integral a => a -> a -> a
`mod`Int
16)
isURIFragmentValid :: Char -> Bool
isURIFragmentValid Char
x = Char
x Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"!$&'()*+,;=/?-._~:@"
emit :: ST -> [(TokenType, String)] -> [Either String (TokenType, String)]
emit :: ST -> [(TokenType, String)] -> [Either String (TokenType, String)]
emit ST
st (t :: (TokenType, String)
t@(TokenType
Space,String
"\n"):[(TokenType, String)]
stream) = (TokenType, String) -> Either String (TokenType, String)
forall a b. b -> Either a b
Right (TokenType, String)
tEither String (TokenType, String)
-> [Either String (TokenType, String)]
-> [Either String (TokenType, String)]
forall a. a -> [a] -> [a]
: ST -> [(TokenType, String)] -> [Either String (TokenType, String)]
anchor ST
st [(TokenType, String)]
stream
emit ST
st ((TokenType, String)
t:[(TokenType, String)]
stream) = (TokenType, String) -> Either String (TokenType, String)
forall a b. b -> Either a b
Right (TokenType, String)
tEither String (TokenType, String)
-> [Either String (TokenType, String)]
-> [Either String (TokenType, String)]
forall a. a -> [a] -> [a]
: ST -> [(TokenType, String)] -> [Either String (TokenType, String)]
emit ST
st [(TokenType, String)]
stream
emit ST
_ [] = []
identifier :: ST -> [(TokenType, String)] -> Maybe String
identifier :: ST -> [(TokenType, String)] -> Maybe String
identifier ST
st t :: [(TokenType, String)]
t@((TokenType
kind,String
v):[(TokenType, String)]
stream) | TokenType
kindTokenType -> [TokenType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`[TokenType
Varid,TokenType
Definition] =
case [(TokenType, String)] -> [(TokenType, String)]
forall t. [(TokenType, t)] -> [(TokenType, t)]
skip [(TokenType, String)]
stream of
((TokenType
Varop,String
v):[(TokenType, String)]
_) | Bool -> Bool
not (String
vString -> ST -> Bool
`inST`ST
st) -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
fix String
v)
[(TokenType, String)]
notVarop
| String
v String -> ST -> Bool
`inST` ST
st -> Maybe String
forall a. Maybe a
Nothing
| Bool
otherwise -> String -> Maybe String
forall a. a -> Maybe a
Just String
v
identifier ST
st t :: [(TokenType, String)]
t@((TokenType
Layout,String
"("):[(TokenType, String)]
stream) =
case [(TokenType, String)]
stream of
((TokenType
Varop,String
v):(TokenType
Layout,String
")"):[(TokenType, String)]
_)
| String
v String -> ST -> Bool
`inST` ST
st -> Maybe String
forall a. Maybe a
Nothing
| Bool
otherwise -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
fix String
v)
[(TokenType, String)]
notVarop -> case [(TokenType, String)] -> [(TokenType, String)]
forall t. [(TokenType, t)] -> [(TokenType, t)]
skip ([(TokenType, String)] -> [(TokenType, String)]
munchParens [(TokenType, String)]
stream) of
((TokenType
Varop,String
v):[(TokenType, String)]
_) | Bool -> Bool
not (String
vString -> ST -> Bool
`inST`ST
st) -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
fix String
v)
[(TokenType, String)]
_ -> Maybe String
forall a. Maybe a
Nothing
identifier ST
st t :: [(TokenType, String)]
t@((TokenType
Keyword,String
"foreign"):[(TokenType, String)]
stream) = Maybe String
forall a. Maybe a
Nothing
identifier ST
st t :: [(TokenType, String)]
t@((TokenType
Keyword,String
"data"):(TokenType
Space,String
_):(TokenType
Keyword,String
"family"):[(TokenType, String)]
stream)
= [(TokenType, String)] -> Maybe String
getConid [(TokenType, String)]
stream
identifier ST
st t :: [(TokenType, String)]
t@((TokenType
Keyword,String
"data"):[(TokenType, String)]
stream) = [(TokenType, String)] -> Maybe String
getConid [(TokenType, String)]
stream
identifier ST
st t :: [(TokenType, String)]
t@((TokenType
Keyword,String
"newtype"):[(TokenType, String)]
stream) = [(TokenType, String)] -> Maybe String
getConid [(TokenType, String)]
stream
identifier ST
st t :: [(TokenType, String)]
t@((TokenType
Keyword,String
"type"):(TokenType
Space,String
_):(TokenType
Keyword,String
"family"):[(TokenType, String)]
stream)
= [(TokenType, String)] -> Maybe String
getConid [(TokenType, String)]
stream
identifier ST
st t :: [(TokenType, String)]
t@((TokenType
Keyword,String
"type"):(TokenType
Space,String
_):(TokenType
Keyword,String
"data"):[(TokenType, String)]
stream)
= [(TokenType, String)] -> Maybe String
getConid [(TokenType, String)]
stream
identifier ST
st t :: [(TokenType, String)]
t@((TokenType
Keyword,String
"type"):[(TokenType, String)]
stream) = [(TokenType, String)] -> Maybe String
getConid [(TokenType, String)]
stream
identifier ST
st t :: [(TokenType, String)]
t@((TokenType
Keyword,String
"class"):[(TokenType, String)]
stream) = [(TokenType, String)] -> Maybe String
getConid [(TokenType, String)]
stream
identifier ST
st t :: [(TokenType, String)]
t@((TokenType
Keyword,String
"instance"):[(TokenType, String)]
stream)= [(TokenType, String)] -> Maybe String
getInstance [(TokenType, String)]
stream
identifier ST
st t :: [(TokenType, String)]
t@((TokenType
Comment,String
_):(TokenType
Space,String
"\n"):[(TokenType, String)]
stream) = ST -> [(TokenType, String)] -> Maybe String
identifier ST
st [(TokenType, String)]
stream
identifier ST
st [(TokenType, String)]
stream = Maybe String
forall a. Maybe a
Nothing
typesig :: [(TokenType,String)] -> Bool
typesig :: [(TokenType, String)] -> Bool
typesig ((TokenType
Keyglyph,String
"::"):[(TokenType, String)]
_) = Bool
True
typesig ((TokenType
Varid,String
_):[(TokenType, String)]
stream) = [(TokenType, String)] -> Bool
typesig [(TokenType, String)]
stream
typesig ((TokenType
Layout,String
"("):(TokenType
Varop,String
_):(TokenType
Layout,String
")"):[(TokenType, String)]
stream) = [(TokenType, String)] -> Bool
typesig [(TokenType, String)]
stream
typesig ((TokenType
Layout,String
","):[(TokenType, String)]
stream) = [(TokenType, String)] -> Bool
typesig [(TokenType, String)]
stream
typesig ((TokenType
Space,String
_):[(TokenType, String)]
stream) = [(TokenType, String)] -> Bool
typesig [(TokenType, String)]
stream
typesig ((TokenType
Comment,String
_):[(TokenType, String)]
stream) = [(TokenType, String)] -> Bool
typesig [(TokenType, String)]
stream
typesig [(TokenType, String)]
_ = Bool
False
munchParens :: [(TokenType, String)] -> [(TokenType, String)]
munchParens :: [(TokenType, String)] -> [(TokenType, String)]
munchParens = Int -> [(TokenType, String)] -> [(TokenType, String)]
forall {t}.
(Eq t, Num t) =>
t -> [(TokenType, String)] -> [(TokenType, String)]
munch (Int
0::Int)
where munch :: t -> [(TokenType, String)] -> [(TokenType, String)]
munch t
0 ((TokenType
Layout,String
")"):[(TokenType, String)]
rest) = [(TokenType, String)]
rest
munch t
n ((TokenType
Layout,String
")"):[(TokenType, String)]
rest) = t -> [(TokenType, String)] -> [(TokenType, String)]
munch (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) [(TokenType, String)]
rest
munch t
n ((TokenType
Layout,String
"("):[(TokenType, String)]
rest) = t -> [(TokenType, String)] -> [(TokenType, String)]
munch (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1) [(TokenType, String)]
rest
munch t
n ((TokenType, String)
_:[(TokenType, String)]
rest) = t -> [(TokenType, String)] -> [(TokenType, String)]
munch t
n [(TokenType, String)]
rest
munch t
_ [] = []
fix :: String -> String
fix :: String -> String
fix (Char
'`':String
v) = Char -> String -> String
forall a. Eq a => a -> [a] -> [a]
dropLast Char
'`' String
v
fix String
v = String
v
skip :: [(TokenType, t)] -> [(TokenType, t)]
skip :: forall t. [(TokenType, t)] -> [(TokenType, t)]
skip ((TokenType
Space,t
_):[(TokenType, t)]
stream) = [(TokenType, t)] -> [(TokenType, t)]
forall t. [(TokenType, t)] -> [(TokenType, t)]
skip [(TokenType, t)]
stream
skip ((TokenType
Comment,t
_):[(TokenType, t)]
stream) = [(TokenType, t)] -> [(TokenType, t)]
forall t. [(TokenType, t)] -> [(TokenType, t)]
skip [(TokenType, t)]
stream
skip [(TokenType, t)]
stream = [(TokenType, t)]
stream
getConid :: [(TokenType, String)] -> Maybe String
getConid :: [(TokenType, String)] -> Maybe String
getConid [(TokenType, String)]
stream =
case [(TokenType, String)] -> [(TokenType, String)]
forall t. [(TokenType, t)] -> [(TokenType, t)]
skip [(TokenType, String)]
stream of
((TokenType
Conid,String
c):[(TokenType, String)]
rest) -> case [(TokenType, String)] -> [(TokenType, String)]
context [(TokenType, String)]
rest of
((TokenType
Keyglyph,String
"="):[(TokenType, String)]
_) -> String -> Maybe String
forall a. a -> Maybe a
Just String
c
((TokenType
Keyglyph,String
"=>"):[(TokenType, String)]
more) ->
case [(TokenType, String)] -> [(TokenType, String)]
forall t. [(TokenType, t)] -> [(TokenType, t)]
skip [(TokenType, String)]
more of
((TokenType
Conid,String
c'):[(TokenType, String)]
_) -> String -> Maybe String
forall a. a -> Maybe a
Just String
c'
[(TokenType, String)]
v -> [(TokenType, String)] -> String -> Maybe String
forall {p} {p} {a}. p -> p -> Maybe a
debug [(TokenType, String)]
v (String
"Conid "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
cString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" =>")
[(TokenType, String)]
v -> [(TokenType, String)] -> String -> Maybe String
forall {p} {p} {a}. p -> p -> Maybe a
debug [(TokenType, String)]
v (String
"Conid "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
cString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" no = or =>")
((TokenType
Layout,String
"("):[(TokenType, String)]
rest) -> case [(TokenType, String)] -> [(TokenType, String)]
context [(TokenType, String)]
rest of
((TokenType
Keyglyph,String
"=>"):[(TokenType, String)]
more) ->
case [(TokenType, String)] -> [(TokenType, String)]
forall t. [(TokenType, t)] -> [(TokenType, t)]
skip [(TokenType, String)]
more of
((TokenType
Conid,String
c'):[(TokenType, String)]
_) -> String -> Maybe String
forall a. a -> Maybe a
Just String
c'
[(TokenType, String)]
v -> [(TokenType, String)] -> String -> Maybe String
forall {p} {p} {a}. p -> p -> Maybe a
debug [(TokenType, String)]
v (String
"(...) =>")
[(TokenType, String)]
v -> [(TokenType, String)] -> String -> Maybe String
forall {p} {p} {a}. p -> p -> Maybe a
debug [(TokenType, String)]
v (String
"(...) no =>")
[(TokenType, String)]
v -> [(TokenType, String)] -> String -> Maybe String
forall {p} {p} {a}. p -> p -> Maybe a
debug [(TokenType, String)]
v (String
"no Conid or (...)")
where debug :: p -> p -> Maybe a
debug p
_ p
_ = Maybe a
forall a. Maybe a
Nothing
context :: [(TokenType, String)] -> [(TokenType, String)]
context :: [(TokenType, String)] -> [(TokenType, String)]
context stream :: [(TokenType, String)]
stream@((TokenType
Keyglyph,String
"="):[(TokenType, String)]
_) = [(TokenType, String)]
stream
context stream :: [(TokenType, String)]
stream@((TokenType
Keyglyph,String
"=>"):[(TokenType, String)]
_) = [(TokenType, String)]
stream
context stream :: [(TokenType, String)]
stream@((TokenType
Keyglyph,String
"⇒"):[(TokenType, String)]
_) = [(TokenType, String)]
stream
context ((TokenType, String)
_:[(TokenType, String)]
stream) = [(TokenType, String)] -> [(TokenType, String)]
context [(TokenType, String)]
stream
context [] = []
getInstance :: [(TokenType, String)] -> Maybe String
getInstance = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> ([(TokenType, String)] -> String)
-> [(TokenType, String)]
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> String
unwords (ST -> String)
-> ([(TokenType, String)] -> ST) -> [(TokenType, String)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"instance"String -> ST -> ST
forall a. a -> [a] -> [a]
:) (ST -> ST)
-> ([(TokenType, String)] -> ST) -> [(TokenType, String)] -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ST
words (String -> ST)
-> ([(TokenType, String)] -> String) -> [(TokenType, String)] -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (ST -> String)
-> ([(TokenType, String)] -> ST) -> [(TokenType, String)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TokenType, String) -> String) -> [(TokenType, String)] -> ST
forall a b. (a -> b) -> [a] -> [b]
map (TokenType, String) -> String
forall a b. (a, b) -> b
snd
([(TokenType, String)] -> ST)
-> ([(TokenType, String)] -> [(TokenType, String)])
-> [(TokenType, String)]
-> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TokenType, String)] -> [(TokenType, String)]
trimContext ([(TokenType, String)] -> [(TokenType, String)])
-> ([(TokenType, String)] -> [(TokenType, String)])
-> [(TokenType, String)]
-> [(TokenType, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TokenType, String) -> Bool)
-> [(TokenType, String)] -> [(TokenType, String)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool)
-> ((TokenType, String) -> Bool) -> (TokenType, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TokenType, String) -> Bool
terminator)
where
trimContext :: [(TokenType, String)] -> [(TokenType, String)]
trimContext [(TokenType, String)]
ts = if (TokenType
Keyglyph,String
"=>") (TokenType, String) -> [(TokenType, String)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(TokenType, String)]
ts
Bool -> Bool -> Bool
|| (TokenType
Keyglyph,String
"⇒") (TokenType, String) -> [(TokenType, String)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(TokenType, String)]
ts
then [(TokenType, String)] -> [(TokenType, String)]
forall a. HasCallStack => [a] -> [a]
tail ([(TokenType, String)] -> [(TokenType, String)])
-> ([(TokenType, String)] -> [(TokenType, String)])
-> [(TokenType, String)]
-> [(TokenType, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TokenType, String) -> Bool)
-> [(TokenType, String)] -> [(TokenType, String)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((TokenType, String) -> [(TokenType, String)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`[(TokenType
Keyglyph,String
"=>")
,(TokenType
Keyglyph,String
"⇒")]) ([(TokenType, String)] -> [(TokenType, String)])
-> [(TokenType, String)] -> [(TokenType, String)]
forall a b. (a -> b) -> a -> b
$ [(TokenType, String)]
ts
else [(TokenType, String)]
ts
terminator :: (TokenType, String) -> Bool
terminator (TokenType
Keyword, String
_) = Bool
True
terminator (TokenType
Comment, String
_) = Bool
True
terminator (TokenType
Cpp, String
_) = Bool
True
terminator (TokenType
Keyglyph,String
"|") = Bool
True
terminator (TokenType
Layout, String
";") = Bool
True
terminator (TokenType
Layout, String
"{") = Bool
True
terminator (TokenType
Layout, String
"}") = Bool
True
terminator (TokenType, String)
_ = Bool
False
type ST = [String]
emptyST :: ST
emptyST :: ST
emptyST = []
insertST :: String -> ST -> ST
insertST :: String -> ST -> ST
insertST String
k ST
st = String -> ST -> ST
forall a. Ord a => a -> [a] -> [a]
insert String
k ST
st
inST :: String -> ST -> Bool
inST :: String -> ST -> Bool
inST String
k ST
st = String
k String -> ST -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ST
st