module Yi.Syntax.Paren where
import Yi.IncrementalParse
import Yi.Lexer.Alex
import Yi.Lexer.Haskell
import Yi.Style (hintStyle, errorStyle, StyleName)
import Yi.Syntax.Layout
import Yi.Syntax.Tree
import Yi.Syntax
import Yi.Prelude
import Prelude ()
import Data.Monoid (Endo(..), appEndo, mappend)
import Data.DeriveTH
import Data.Maybe
import Data.List (filter, takeWhile)
import qualified Data.Foldable
indentScanner :: Scanner (AlexState lexState) (TT)
-> Scanner (Yi.Syntax.Layout.State Token lexState) (TT)
indentScanner = layoutHandler startsLayout [(Special '(', Special ')'),
(Special '[', Special ']'),
(Special '{', Special '}')] ignoredToken
(Special '<', Special '>', Special '.') isBrace
isBrace :: TT -> Bool
isBrace (Tok b _ _) = (Special '{') == b
ignoredToken :: TT -> Bool
ignoredToken (Tok t _ _) = isComment t || t == CppDirective
isNoise :: Token -> Bool
isNoise (Special c) = c `elem` ";,`"
isNoise _ = True
type Expr t = [Tree t]
data Tree t
= Paren t (Expr t) t
| Block ([Tree t])
| Atom t
| Error t
| Expr [Tree t]
deriving Show
$(derive makeFoldable ''Tree)
instance IsTree Tree where
emptyNode = Expr []
uniplate (Paren l g r) = (g,\g' -> Paren l g' r)
uniplate (Expr g) = (g,\g' -> Expr g')
uniplate (Block s) = (s,\s' -> Block s')
uniplate t = ([],\_ -> t)
getIndentingSubtree :: Tree TT -> Point -> Int -> Maybe (Tree TT)
getIndentingSubtree root offset line =
listToMaybe $ [t | (t,posn) <- takeWhile ((<= line) . posnLine . snd) $ allSubTreesPosn,
posnOfs posn > offset, posnLine posn == line]
where allSubTreesPosn = [(t',posn) | t'@(Block _) <-filter (not . null . toList) (getAllSubTrees root),
let (tok:_) = toList t',
let posn = tokPosn tok]
getSubtreeSpan :: Tree TT -> (Point, Int)
getSubtreeSpan tree = (posnOfs $ first, lastLine firstLine)
where bounds@[first, _last] = fmap (tokPosn . assertJust) [getFirstElement tree, getLastElement tree]
[firstLine, lastLine] = fmap posnLine bounds
assertJust (Just x) = x
assertJust _ = error "assertJust: Just expected"
parse :: P TT (Tree TT)
parse = Expr <$> parse' tokT tokFromT
parse' :: (TT -> Token) -> (Token -> TT) -> P TT [Tree TT]
parse' toTok _ = pExpr <* eof
where
sym c = symbol (isSpecial [c] . toTok)
pleaseSym c = (recoverWith errTok) <|> sym c
pExpr :: P TT (Expr TT)
pExpr = Yi.Prelude.many pTree
pBlocks = (Expr <$> pExpr) `sepBy1` sym '.'
pTree :: P TT (Tree TT)
pTree = (Paren <$> sym '(' <*> pExpr <*> pleaseSym ')')
<|> (Paren <$> sym '[' <*> pExpr <*> pleaseSym ']')
<|> (Paren <$> sym '{' <*> pExpr <*> pleaseSym '}')
<|> (Block <$> (sym '<' *> pBlocks <* sym '>'))
<|> (Atom <$> symbol (isNoise . toTok))
<|> (Error <$> recoverWith (symbol (isSpecial "})]" . toTok)))
getStrokes :: Point -> Point -> Point -> Tree TT -> [Stroke]
getStrokes point _begin _end t0 =
result
where getStrokes' (Atom t) = one (ts t)
getStrokes' (Error t) = one (modStroke errorStyle (ts t))
getStrokes' (Block s) = getStrokesL s
getStrokes' (Expr g) = getStrokesL g
getStrokes' (Paren l g r)
| isErrorTok $ tokT r = one (modStroke errorStyle (ts l)) <> getStrokesL g
| (posnOfs $ tokPosn $ l) == point || (posnOfs $ tokPosn $ r) == point 1
= one (modStroke hintStyle (ts l)) <> getStrokesL g <> one (modStroke hintStyle (ts r))
| otherwise = one (ts l) <> getStrokesL g <> one (ts r)
getStrokesL = foldMap getStrokes'
ts = tokenToStroke
result = appEndo (getStrokes' t0) []
one x = Endo (x :)
tokenToStroke :: TT -> Stroke
tokenToStroke = fmap tokenToStyle . tokToSpan
modStroke :: StyleName -> Stroke -> Stroke
modStroke f = fmap (f `mappend`)
tokenToAnnot :: TT -> Maybe (Span String)
tokenToAnnot = sequenceA . tokToSpan . fmap tokenToText
errTok :: Parser (Tok t) (Tok Token)
errTok = mkTok <$> curPos
where curPos = tB <$> lookNext
tB Nothing = maxBound
tB (Just x) = tokBegin x
mkTok p = Tok (Special '!') 0 (startPosn {posnOfs = p})