{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor  #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- uniplate patterns
{-# OPTIONS_HADDOCK show-extensions #-}

-- |
-- Module      :  Yi.Syntax.Latex
-- License     :  GPL-2
-- Maintainer  :  yi-devel@googlegroups.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Parser used by the LaTeX modes.

module Yi.Syntax.Latex where

import           Control.Applicative (Alternative ((<|>), empty, many))
import           Data.Monoid         (Endo (..), (<>))
import           Yi.IncrementalParse (P, eof, recoverWith, symbol)
import           Yi.Lexer.Alex       hiding (tokenToStyle)
import           Yi.Lexer.Latex      (Token (..), tokenToText)
import           Yi.Style
import           Yi.Syntax           (Point, Span)
import           Yi.Syntax.Tree      (IsTree (emptyNode, uniplate))

isNoise :: Token -> Bool
isNoise :: Token -> Bool
isNoise Token
Text = Bool
True
isNoise Token
Comment = Bool
True
isNoise (Command String
_) = Bool
True
isNoise Token
NewCommand = Bool
True
isNoise (Special Char
' ') = Bool
True
isNoise (Special Char
_) = Bool
False
isNoise (Begin String
_) = Bool
False
isNoise (End String
_) = Bool
False

type TT = Tok Token

type Expr t = [Tree t]

data Tree t
    = Paren t (Tree t) t -- A parenthesized expression (maybe with [ ] ...)
    | Atom t
    | Error t
    | Expr (Expr t)
      deriving (Int -> Tree t -> ShowS
[Tree t] -> ShowS
Tree t -> String
(Int -> Tree t -> ShowS)
-> (Tree t -> String) -> ([Tree t] -> ShowS) -> Show (Tree t)
forall t. Show t => Int -> Tree t -> ShowS
forall t. Show t => [Tree t] -> ShowS
forall t. Show t => Tree t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tree t] -> ShowS
$cshowList :: forall t. Show t => [Tree t] -> ShowS
show :: Tree t -> String
$cshow :: forall t. Show t => Tree t -> String
showsPrec :: Int -> Tree t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> Tree t -> ShowS
Show, a -> Tree b -> Tree a
(a -> b) -> Tree a -> Tree b
(forall a b. (a -> b) -> Tree a -> Tree b)
-> (forall a b. a -> Tree b -> Tree a) -> Functor Tree
forall a b. a -> Tree b -> Tree a
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Tree b -> Tree a
$c<$ :: forall a b. a -> Tree b -> Tree a
fmap :: (a -> b) -> Tree a -> Tree b
$cfmap :: forall a b. (a -> b) -> Tree a -> Tree b
Functor, Tree a -> Bool
(a -> m) -> Tree a -> m
(a -> b -> b) -> b -> Tree a -> b
(forall m. Monoid m => Tree m -> m)
-> (forall m a. Monoid m => (a -> m) -> Tree a -> m)
-> (forall m a. Monoid m => (a -> m) -> Tree a -> m)
-> (forall a b. (a -> b -> b) -> b -> Tree a -> b)
-> (forall a b. (a -> b -> b) -> b -> Tree a -> b)
-> (forall b a. (b -> a -> b) -> b -> Tree a -> b)
-> (forall b a. (b -> a -> b) -> b -> Tree a -> b)
-> (forall a. (a -> a -> a) -> Tree a -> a)
-> (forall a. (a -> a -> a) -> Tree a -> a)
-> (forall a. Tree a -> [a])
-> (forall a. Tree a -> Bool)
-> (forall a. Tree a -> Int)
-> (forall a. Eq a => a -> Tree a -> Bool)
-> (forall a. Ord a => Tree a -> a)
-> (forall a. Ord a => Tree a -> a)
-> (forall a. Num a => Tree a -> a)
-> (forall a. Num a => Tree a -> a)
-> Foldable Tree
forall a. Eq a => a -> Tree a -> Bool
forall a. Num a => Tree a -> a
forall a. Ord a => Tree a -> a
forall m. Monoid m => Tree m -> m
forall a. Tree a -> Bool
forall a. Tree a -> Int
forall a. Tree a -> [a]
forall a. (a -> a -> a) -> Tree a -> a
forall m a. Monoid m => (a -> m) -> Tree a -> m
forall b a. (b -> a -> b) -> b -> Tree a -> b
forall a b. (a -> b -> b) -> b -> Tree a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: Tree a -> a
$cproduct :: forall a. Num a => Tree a -> a
sum :: Tree a -> a
$csum :: forall a. Num a => Tree a -> a
minimum :: Tree a -> a
$cminimum :: forall a. Ord a => Tree a -> a
maximum :: Tree a -> a
$cmaximum :: forall a. Ord a => Tree a -> a
elem :: a -> Tree a -> Bool
$celem :: forall a. Eq a => a -> Tree a -> Bool
length :: Tree a -> Int
$clength :: forall a. Tree a -> Int
null :: Tree a -> Bool
$cnull :: forall a. Tree a -> Bool
toList :: Tree a -> [a]
$ctoList :: forall a. Tree a -> [a]
foldl1 :: (a -> a -> a) -> Tree a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Tree a -> a
foldr1 :: (a -> a -> a) -> Tree a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Tree a -> a
foldl' :: (b -> a -> b) -> b -> Tree a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Tree a -> b
foldl :: (b -> a -> b) -> b -> Tree a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Tree a -> b
foldr' :: (a -> b -> b) -> b -> Tree a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Tree a -> b
foldr :: (a -> b -> b) -> b -> Tree a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Tree a -> b
foldMap' :: (a -> m) -> Tree a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Tree a -> m
foldMap :: (a -> m) -> Tree a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Tree a -> m
fold :: Tree m -> m
$cfold :: forall m. Monoid m => Tree m -> m
Foldable)


instance IsTree Tree where
    uniplate :: Tree t -> ([Tree t], [Tree t] -> Tree t)
uniplate (Paren t
l Tree t
g t
r) = ([Tree t
g], \[Tree t
g'] -> t -> Tree t -> t -> Tree t
forall t. t -> Tree t -> t -> Tree t
Paren t
l Tree t
g' t
r)
    uniplate (Expr [Tree t]
g) = ([Tree t]
g, [Tree t] -> Tree t
forall t. Expr t -> Tree t
Expr)
    uniplate Tree t
t = ([],Tree t -> [Tree t] -> Tree t
forall a b. a -> b -> a
const Tree t
t)
    emptyNode :: Tree t
emptyNode = Expr t -> Tree t
forall t. Expr t -> Tree t
Expr []

parse :: P TT (Tree TT)
parse :: P TT (Tree TT)
parse = Bool -> P TT (Tree TT)
pExpr Bool
True P TT (Tree TT) -> Parser TT () -> P TT (Tree TT)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser TT ()
forall s. Parser s ()
eof
    where
      -- Create a special character symbol
      newT :: Char -> TT
newT Char
c = Token -> TT
forall t. t -> Tok t
tokFromT (Char -> Token
Special Char
c)
      -- errT = (\next -> case next of
      --     Nothing -> newT '!'
      --     Just (Tok {tokPosn = posn}) -> Tok { tokT = Special '!', tokPosn = posn-1, tokSize = 1 -- FIXME: size should be 1 char, not one byte!
      --                      }) <$> lookNext
      errT :: Parser TT TT
errT = TT -> Parser TT TT
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> TT
newT Char
'!')
      -- parse a special symbol
      sym' :: (b -> Bool) -> Parser (Tok b) (Tok b)
sym' b -> Bool
p = (Tok b -> Bool) -> Parser (Tok b) (Tok b)
forall s. (s -> Bool) -> Parser s s
symbol (b -> Bool
p (b -> Bool) -> (Tok b -> b) -> Tok b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tok b -> b
forall t. Tok t -> t
tokT)
      sym :: a -> Parser (Tok a) (Tok a)
sym a
t = (a -> Bool) -> Parser (Tok a) (Tok a)
forall b. (b -> Bool) -> Parser (Tok b) (Tok b)
sym' (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
t)

      pleaseSym :: Token -> Parser TT TT
pleaseSym Token
c = Parser TT TT -> Parser TT TT
forall s a. Parser s a -> Parser s a
recoverWith Parser TT TT
errT Parser TT TT -> Parser TT TT -> Parser TT TT
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token -> Parser TT TT
forall a. Eq a => a -> Parser (Tok a) (Tok a)
sym Token
c
      -- pleaseSym' c = recoverWith errT <|> sym' c

      -- pExpr :: P TT [Expr TT]
      pExpr :: Bool -> P TT (Tree TT)
pExpr Bool
outsideMath = Expr TT -> Tree TT
forall t. Expr t -> Tree t
Expr (Expr TT -> Tree TT) -> Parser TT (Expr TT) -> P TT (Tree TT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P TT (Tree TT) -> Parser TT (Expr TT)
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Bool -> P TT (Tree TT)
pTree Bool
outsideMath)

      parens :: [(Token, Token)]
parens = [(Char -> Token
Special Char
x, Char -> Token
Special Char
y) | (Char
x,Char
y) <- String -> String -> [(Char, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip String
"({[" String
")}]"]
      openParens :: [Token]
openParens = ((Token, Token) -> Token) -> [(Token, Token)] -> [Token]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Token, Token) -> Token
forall a b. (a, b) -> a
fst [(Token, Token)]
parens

      pBlock :: P TT (Tree TT)
pBlock = (Token -> Bool) -> Parser TT TT
forall b. (b -> Bool) -> Parser (Tok b) (Tok b)
sym' Token -> Bool
isBegin Parser TT TT -> (TT -> P TT (Tree TT)) -> P TT (Tree TT)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \beg :: TT
beg@Tok {tokT :: forall t. Tok t -> t
tokT = Begin String
env} -> TT -> Tree TT -> TT -> Tree TT
forall t. t -> Tree t -> t -> Tree t
Paren (TT -> Tree TT -> TT -> Tree TT)
-> Parser TT TT -> Parser TT (Tree TT -> TT -> Tree TT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TT -> Parser TT TT
forall (f :: * -> *) a. Applicative f => a -> f a
pure TT
beg Parser TT (Tree TT -> TT -> Tree TT)
-> P TT (Tree TT) -> Parser TT (TT -> Tree TT)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> P TT (Tree TT)
pExpr Bool
True Parser TT (TT -> Tree TT) -> Parser TT TT -> P TT (Tree TT)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Token -> Parser TT TT
pleaseSym (String -> Token
End String
env)

      pTree :: Bool -> P TT (Tree TT)
      pTree :: Bool -> P TT (Tree TT)
pTree Bool
outsideMath =
          (if Bool
outsideMath then P TT (Tree TT)
pBlock P TT (Tree TT) -> P TT (Tree TT) -> P TT (Tree TT)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (TT -> Tree TT -> TT -> Tree TT
forall t. t -> Tree t -> t -> Tree t
Paren (TT -> Tree TT -> TT -> Tree TT)
-> Parser TT TT -> Parser TT (Tree TT -> TT -> Tree TT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token -> Parser TT TT
forall a. Eq a => a -> Parser (Tok a) (Tok a)
sym (Char -> Token
Special Char
'$') Parser TT (Tree TT -> TT -> Tree TT)
-> P TT (Tree TT) -> Parser TT (TT -> Tree TT)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> P TT (Tree TT)
pExpr Bool
False Parser TT (TT -> Tree TT) -> Parser TT TT -> P TT (Tree TT)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Token -> Parser TT TT
pleaseSym (Char -> Token
Special Char
'$'))
                           else P TT (Tree TT)
forall (f :: * -> *) a. Alternative f => f a
empty)
          P TT (Tree TT) -> P TT (Tree TT) -> P TT (Tree TT)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (P TT (Tree TT) -> P TT (Tree TT) -> P TT (Tree TT))
-> [P TT (Tree TT)] -> P TT (Tree TT)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 P TT (Tree TT) -> P TT (Tree TT) -> P TT (Tree TT)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) [TT -> Tree TT -> TT -> Tree TT
forall t. t -> Tree t -> t -> Tree t
Paren (TT -> Tree TT -> TT -> Tree TT)
-> Parser TT TT -> Parser TT (Tree TT -> TT -> Tree TT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token -> Parser TT TT
forall a. Eq a => a -> Parser (Tok a) (Tok a)
sym Token
l Parser TT (Tree TT -> TT -> Tree TT)
-> P TT (Tree TT) -> Parser TT (TT -> Tree TT)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> P TT (Tree TT)
pExpr Bool
outsideMath Parser TT (TT -> Tree TT) -> Parser TT TT -> P TT (Tree TT)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Token -> Parser TT TT
pleaseSym Token
r | (Token
l,Token
r) <- [(Token, Token)]
parens]
          P TT (Tree TT) -> P TT (Tree TT) -> P TT (Tree TT)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (TT -> Tree TT
forall t. t -> Tree t
Atom (TT -> Tree TT) -> Parser TT TT -> P TT (Tree TT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token -> Bool) -> Parser TT TT
forall b. (b -> Bool) -> Parser (Tok b) (Tok b)
sym' Token -> Bool
isNoise)
          P TT (Tree TT) -> P TT (Tree TT) -> P TT (Tree TT)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (TT -> Tree TT
forall t. t -> Tree t
Error (TT -> Tree TT) -> Parser TT TT -> P TT (Tree TT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TT TT -> Parser TT TT
forall s a. Parser s a -> Parser s a
recoverWith ((Token -> Bool) -> Parser TT TT
forall b. (b -> Bool) -> Parser (Tok b) (Tok b)
sym' (Bool -> Bool
not (Bool -> Bool) -> (Token -> Bool) -> Token -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool) -> (Token -> Bool) -> Token -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token -> Bool
isNoise (Token -> Bool -> Bool) -> (Token -> Bool) -> Token -> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Token -> [Token] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Token]
openParens)))))

getStrokes :: Point -> Point -> Point -> Tree TT -> [Stroke]
getStrokes :: Point -> Point -> Point -> Tree TT -> [Stroke]
getStrokes Point
point Point
_begin Point
_end Tree TT
t0 = Endo [Stroke] -> [Stroke] -> [Stroke]
forall a. Endo a -> a -> a
appEndo Endo [Stroke]
result []
    where getStrokes' :: Tree TT -> Endo [Stroke]
          getStrokes' :: Tree TT -> Endo [Stroke]
getStrokes' (Expr Expr TT
g) = Expr TT -> Endo [Stroke]
getStrokesL Expr TT
g
          getStrokes' (Atom TT
t) = (Stroke -> Stroke) -> TT -> Endo [Stroke]
forall a. (Stroke -> a) -> TT -> Endo [a]
ts Stroke -> Stroke
forall a. a -> a
id TT
t
          getStrokes' (Error TT
t) = (Stroke -> Stroke) -> TT -> Endo [Stroke]
forall a. (Stroke -> a) -> TT -> Endo [a]
ts (StyleName -> Stroke -> Stroke
modStroke StyleName
errorStyle) TT
t -- paint in red
          getStrokes' (Paren TT
l Tree TT
g TT
r)
              -- we have special treatment for (Begin, End) because these blocks are typically very large.
              -- we don't force the "end" part to prevent parsing the whole file.
              | Token -> Bool
isBegin (TT -> Token
forall t. Tok t -> t
tokT TT
l) = if Posn -> Point
posnOfs (TT -> Posn
forall t. Tok t -> Posn
tokPosn TT
l) Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
/= Point
point
                  then Endo [Stroke]
normalPaint
                  else case (TT -> Token
forall t. Tok t -> t
tokT TT
l, TT -> Token
forall t. Tok t -> t
tokT TT
r) of
                         (Begin String
b, End String
e) | String
b String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
e -> Endo [Stroke]
hintPaint
                         (Token, Token)
_ -> Endo [Stroke]
errPaint
              | Token -> Bool
isErrorTok (TT -> Token
forall t. Tok t -> t
tokT TT
r) = Endo [Stroke]
errPaint
              -- left paren wasn't matched: paint it in red.
              -- note that testing this on the "Paren" node actually forces the parsing of the
              -- right paren, undermining online behaviour.
              | Posn -> Point
posnOfs (TT -> Posn
forall t. Tok t -> Posn
tokPosn TT
l) Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
== Point
point Bool -> Bool -> Bool
|| Posn -> Point
posnOfs (TT -> Posn
forall t. Tok t -> Posn
tokPosn TT
r) Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
== Point
point Point -> Point -> Point
forall a. Num a => a -> a -> a
- Point
1 = Endo [Stroke]
hintPaint
              | Bool
otherwise = Endo [Stroke]
normalPaint
              where normalPaint :: Endo [Stroke]
normalPaint = (Stroke -> Stroke) -> TT -> Endo [Stroke]
forall a. (Stroke -> a) -> TT -> Endo [a]
ts Stroke -> Stroke
forall a. a -> a
id TT
l Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Tree TT -> Endo [Stroke]
getStrokes' Tree TT
g Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> (Stroke -> Stroke) -> TT -> TT -> Endo [Stroke]
tsEnd Stroke -> Stroke
forall a. a -> a
id TT
l TT
r
                    hintPaint :: Endo [Stroke]
hintPaint = (Stroke -> Stroke) -> TT -> Endo [Stroke]
forall a. (Stroke -> a) -> TT -> Endo [a]
ts (StyleName -> Stroke -> Stroke
modStroke StyleName
hintStyle) TT
l Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Tree TT -> Endo [Stroke]
getStrokes' Tree TT
g Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> (Stroke -> Stroke) -> TT -> TT -> Endo [Stroke]
tsEnd (StyleName -> Stroke -> Stroke
modStroke StyleName
hintStyle) TT
l TT
r
                    errPaint :: Endo [Stroke]
errPaint = (Stroke -> Stroke) -> TT -> Endo [Stroke]
forall a. (Stroke -> a) -> TT -> Endo [a]
ts (StyleName -> Stroke -> Stroke
modStroke StyleName
errorStyle) TT
l Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Tree TT -> Endo [Stroke]
getStrokes' Tree TT
g

          tsEnd :: (Stroke -> Stroke) -> TT -> TT -> Endo [Stroke]
tsEnd Stroke -> Stroke
_ (Tok{tokT :: forall t. Tok t -> t
tokT = Begin String
b}) t :: TT
t@(Tok{tokT :: forall t. Tok t -> t
tokT = End String
e})
              | String
b String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
e = (Stroke -> Stroke) -> TT -> Endo [Stroke]
forall a. (Stroke -> a) -> TT -> Endo [a]
ts (StyleName -> Stroke -> Stroke
modStroke StyleName
errorStyle) TT
t
          tsEnd Stroke -> Stroke
f TT
_ TT
t = (Stroke -> Stroke) -> TT -> Endo [Stroke]
forall a. (Stroke -> a) -> TT -> Endo [a]
ts Stroke -> Stroke
f TT
t
          getStrokesL :: Expr TT -> Endo [Stroke]
          getStrokesL :: Expr TT -> Endo [Stroke]
getStrokesL = (Tree TT -> Endo [Stroke]) -> Expr TT -> Endo [Stroke]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Tree TT -> Endo [Stroke]
getStrokes'
          ts :: (Stroke -> a) -> TT -> Endo [a]
ts Stroke -> a
f TT
t
              | Token -> Bool
isErrorTok (TT -> Token
forall t. Tok t -> t
tokT TT
t) = Endo [a]
forall a. Monoid a => a
mempty
              | Bool
otherwise = ([a] -> [a]) -> Endo [a]
forall a. (a -> a) -> Endo a
Endo (Stroke -> a
f (TT -> Stroke
tokenToStroke TT
t) a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)
          result :: Endo [Stroke]
result = Tree TT -> Endo [Stroke]
getStrokes' Tree TT
t0

modStroke :: StyleName -> Stroke -> Stroke
modStroke :: StyleName -> Stroke -> Stroke
modStroke StyleName
f = (StyleName -> StyleName) -> Stroke -> Stroke
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (StyleName
f StyleName -> StyleName -> StyleName
forall a. Monoid a => a -> a -> a
`mappend`)

tokenToStroke :: TT -> Stroke
tokenToStroke :: TT -> Stroke
tokenToStroke = (Token -> StyleName) -> Span Token -> Stroke
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Token -> StyleName
tokenToStyle (Span Token -> Stroke) -> (TT -> Span Token) -> TT -> Stroke
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TT -> Span Token
forall t. Tok t -> Span t
tokToSpan

tokenToAnnot :: TT -> Maybe (Span String)
tokenToAnnot :: TT -> Maybe (Span String)
tokenToAnnot = Span (Maybe String) -> Maybe (Span String)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (Span (Maybe String) -> Maybe (Span String))
-> (TT -> Span (Maybe String)) -> TT -> Maybe (Span String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tok (Maybe String) -> Span (Maybe String)
forall t. Tok t -> Span t
tokToSpan (Tok (Maybe String) -> Span (Maybe String))
-> (TT -> Tok (Maybe String)) -> TT -> Span (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token -> Maybe String) -> TT -> Tok (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Token -> Maybe String
tokenToText

tokenToStyle :: Token -> StyleName
tokenToStyle :: Token -> StyleName
tokenToStyle Token
t =
  case Token
t of
    Token
Comment -> StyleName
commentStyle
    Token
Text -> StyleName
defaultStyle
    Special Char
_ -> StyleName
defaultStyle
    Command String
_ -> StyleName
typeStyle
    Begin String
_ -> StyleName
keywordStyle
    End String
_ -> StyleName
keywordStyle
    Token
NewCommand -> StyleName
keywordStyle

isSpecial :: String -> Token -> Bool
isSpecial :: String -> Token -> Bool
isSpecial String
cs (Special Char
c) = Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
cs
isSpecial String
_  Token
_ = Bool
False

isBegin, isEnd :: Token -> Bool
isBegin :: Token -> Bool
isBegin (Begin String
_) = Bool
True
isBegin Token
_ = Bool
False
isEnd :: Token -> Bool
isEnd (End String
_) = Bool
True
isEnd Token
_ = Bool
False

isErrorTok :: Token -> Bool
isErrorTok :: Token -> Bool
isErrorTok = String -> Token -> Bool
isSpecial String
"!"