module Yi.Syntax.Latex where
import Yi.IncrementalParse
import Yi.Lexer.Alex
import Yi.Lexer.Latex
import Yi.Style
import Yi.Syntax.Tree
import Yi.Syntax
import Yi.Prelude
import Prelude ()
import Data.Monoid (Endo(..), mappend, mempty)
import Data.List (zip)
isNoise :: Token -> Bool
isNoise Text = True
isNoise Comment = True
isNoise (Command _) = True
isNoise NewCommand = True
isNoise (Special ' ') = True
isNoise (Special _) = False
isNoise (Begin _) = False
isNoise (End _) = False
type TT = Tok Token
type Expr t = [Tree t]
data Tree t
= Paren t (Tree t) t
| Atom t
| Error t
| Expr (Expr t)
deriving Show
instance Foldable Tree where
foldMap f (Atom t) = f t
foldMap f (Error t ) = f t
foldMap f (Paren l g r) = f l <> foldMap f g <> f r
foldMap f (Expr g) = foldMap (foldMap f) g
instance IsTree Tree where
uniplate (Paren l g r) = ([g], \[g'] -> Paren l g' r)
uniplate (Expr g) = (g, Expr)
uniplate t = ([],\_ -> t)
emptyNode = Expr []
parse :: P TT (Tree TT)
parse = pExpr True <* eof
where
newT c = tokFromT (Special c)
errT = pure (newT '!')
sym' p = symbol (p . tokT)
sym t = sym' (== t)
pleaseSym c = recoverWith errT <|> sym c
pExpr outsideMath = Expr <$> many (pTree outsideMath)
parens = [(Special x, Special y) | (x,y) <- zip "({[" ")}]"]
openParens = fmap fst parens
pBlock = sym' isBegin >>= \beg@Tok {tokT = Begin env} -> Paren <$> pure beg <*> pExpr True <*> pleaseSym (End env)
pTree :: Bool -> P TT (Tree TT)
pTree outsideMath =
(if outsideMath then pBlock <|> (Paren <$> sym (Special '$') <*> pExpr False <*> pleaseSym (Special '$'))
else empty)
<|> foldr1 (<|>) [(Paren <$> sym l <*> pExpr outsideMath <*> pleaseSym r) | (l,r) <- parens]
<|> (Atom <$> sym' isNoise)
<|> (Error <$> recoverWith (sym' (not . ((||) <$> isNoise <*> (`elem` openParens)))))
getStrokes :: Point -> Point -> Point -> Tree TT -> [Stroke]
getStrokes point _begin _end t0 = appEndo result []
where getStrokes' :: Tree TT -> Endo [Stroke]
getStrokes' (Expr g) = getStrokesL g
getStrokes' (Atom t) = ts id t
getStrokes' (Error t) = ts (modStroke errorStyle) t
getStrokes' (Paren l g r)
| isBegin (tokT l) = if (posnOfs $ tokPosn $ l) /= point
then normalPaint
else case (tokT l, tokT r) of
(Begin b, End e) | b == e -> hintPaint
_ -> errPaint
| isErrorTok (tokT r) = errPaint
| (posnOfs $ tokPosn $ l) == point || (posnOfs $ tokPosn $ r) == point 1
= hintPaint
| otherwise = normalPaint
where normalPaint = ts id l <> getStrokes' g <> tsEnd id l r
hintPaint = ts (modStroke hintStyle) l <> getStrokes' g <> tsEnd (modStroke hintStyle) l r
errPaint = ts (modStroke errorStyle) l <> getStrokes' g
tsEnd _ (Tok{tokT = Begin b}) t@(Tok{tokT = End e})
| b /= e = ts (modStroke errorStyle) t
tsEnd f _ t = ts f t
getStrokesL :: Expr TT -> Endo [Stroke]
getStrokesL = foldMap getStrokes'
ts f t
| isErrorTok (tokT t) = mempty
| otherwise = Endo (f (tokenToStroke t) :)
result = getStrokes' t0
modStroke :: StyleName -> Stroke -> Stroke
modStroke f = fmap (f `mappend`)
tokenToStroke :: TT -> Stroke
tokenToStroke = fmap tokenToStyle . tokToSpan
tokenToAnnot :: TT -> Maybe (Span String)
tokenToAnnot = sequenceA . tokToSpan . fmap tokenToText
tokenToStyle :: Token -> StyleName
tokenToStyle t =
case t of
Comment -> commentStyle
Text -> defaultStyle
Special _ -> defaultStyle
Command _ -> typeStyle
Begin _ -> keywordStyle
End _ -> keywordStyle
NewCommand -> keywordStyle
isSpecial :: [Char] -> Token -> Bool
isSpecial cs (Special c) = c `elem` cs
isSpecial _ _ = False
isBegin, isEnd :: Token -> Bool
isBegin (Begin _) = True
isBegin _ = False
isEnd (End _) = True
isEnd _ = False
isErrorTok :: Token -> Bool
isErrorTok = isSpecial "!"