module Language.Haskell.HsColour.Anchors
( insertAnchors
) where
import Language.Haskell.HsColour.Classify
import Language.Haskell.HsColour.General
import List
type Anchor = String
insertAnchors :: [(TokenType,String)] -> [Either Anchor (TokenType,String)]
insertAnchors = anchor emptyST
anchor st s = case identifier st s of
Nothing -> emit st s
Just v -> Left v: emit (insertST v st) s
emit st (t@(Space,"\n"):stream) = Right t: anchor st stream
emit st (t:stream) = Right t: emit st stream
emit _ [] = []
identifier st t@((kind,v):stream) | kind`elem`[Varid,Definition] =
case skip stream of
((Varop,v):_) | not (v`inST`st) -> Just (fix v)
notVarop
| v `inST` st -> Nothing
| otherwise -> Just v
identifier st t@((Layout,"("):stream) =
case stream of
((Varop,v):(Layout,")"):_)
| v `inST` st -> Nothing
| otherwise -> Just (fix v)
notVarop -> case skip (munchParens stream) of
((Varop,v):_) | not (v`inST`st) -> Just (fix v)
_ -> Nothing
identifier st t@((Keyword,"foreign"):stream) = Nothing
identifier st t@((Keyword,"data"):stream) = getConid stream
identifier st t@((Keyword,"newtype"):stream) = getConid stream
identifier st t@((Keyword,"type"):stream) = getConid stream
identifier st t@((Keyword,"class"):stream) = getConid stream
identifier st t@((Comment,_):(Space,"\n"):stream) = identifier st stream
identifier st stream = Nothing
typesig :: [(TokenType,String)] -> Bool
typesig ((Keyglyph,"::"):_) = True
typesig ((Varid,_):stream) = typesig stream
typesig ((Layout,"("):(Varop,_):(Layout,")"):stream) = typesig stream
typesig ((Layout,","):stream) = typesig stream
typesig ((Space,_):stream) = typesig stream
typesig ((Comment,_):stream) = typesig stream
typesig _ = False
munchParens = munch (0::Int)
where munch 0 ((Layout,")"):rest) = rest
munch n ((Layout,")"):rest) = munch (n1) rest
munch n ((Layout,"("):rest) = munch (n+1) rest
munch n (_:rest) = munch n rest
munch _ [] = []
fix ('`':v) = dropLast '`' v
fix v = v
skip ((Space,_):stream) = skip stream
skip ((Comment,_):stream) = skip stream
skip stream = stream
getConid stream =
case skip stream of
((Conid,c):rest) -> case context rest of
((Keyglyph,"="):_) -> Just c
((Keyglyph,"=>"):more) ->
case skip more of
((Conid,c'):_) -> Just c'
v -> debug v ("Conid "++c++" =>")
v -> debug v ("Conid "++c++" no = or =>")
((Layout,"("):rest) -> case context rest of
((Keyglyph,"=>"):more) ->
case skip more of
((Conid,c'):_) -> Just c'
v -> debug v ("(...) =>")
v -> debug v ("(...) no =>")
v -> debug v ("no Conid or (...)")
where debug _ _ = Nothing
context stream@((Keyglyph,"="):_) = stream
context stream@((Keyglyph,"=>"):_) = stream
context (_:stream) = context stream
context [] = []
type ST = [String]
emptyST :: ST
emptyST = []
insertST :: String -> ST -> ST
insertST k st = insert k st
inST :: String -> ST -> Bool
inST k st = k `elem` st