{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor  #-}
{-# OPTIONS_HADDOCK show-extensions #-}

-- |
-- Module      :  Yi.Syntax.Paren
-- License     :  GPL-2
-- Maintainer  :  yi-devel@googlegroups.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Parser for Haskell that only cares about parenthesis and layout.

module Yi.Syntax.Paren where

import Prelude hiding (elem)

import           Control.Applicative (Alternative ((<|>), many))
import           Data.Foldable       (elem, toList)
import           Data.Maybe          (listToMaybe)
import           Data.Monoid         (Endo (Endo, appEndo), (<>))
import           Yi.IncrementalParse (P, Parser, eof, lookNext, recoverWith, symbol)
import           Yi.Lexer.Alex       hiding (tokenToStyle)
import           Yi.Lexer.Haskell
import           Yi.Style            (StyleName, errorStyle, hintStyle)
import           Yi.Syntax           (Point, Scanner, Span)
import           Yi.Syntax.Layout    (State, layoutHandler)
import           Yi.Syntax.Tree

indentScanner :: Scanner (AlexState lexState) TT
              -> Scanner (Yi.Syntax.Layout.State Token lexState) TT
indentScanner :: Scanner (AlexState lexState) TT
-> Scanner (State Token lexState) TT
indentScanner = (Token -> Bool)
-> [(Token, Token)]
-> (TT -> Bool)
-> (Token, Token, Token)
-> (TT -> Bool)
-> Scanner (AlexState lexState) TT
-> Scanner (State Token lexState) TT
forall t lexState.
(Show t, Eq t) =>
(t -> Bool)
-> [(t, t)]
-> (Tok t -> Bool)
-> (t, t, t)
-> (Tok t -> Bool)
-> Scanner (AlexState lexState) (Tok t)
-> Scanner (State t lexState) (Tok t)
layoutHandler Token -> Bool
startsLayout [(Char -> Token
Special '(', Char -> Token
Special ')'),
                                            (Char -> Token
Special '[', Char -> Token
Special ']'),
                                            (Char -> Token
Special '{', Char -> Token
Special '}')] TT -> Bool
ignoredToken
                         (Char -> Token
Special '<', Char -> Token
Special '>', Char -> Token
Special '.') TT -> Bool
isBrace

-- HACK: We insert the Special '<', '>', '.', that don't occur in normal haskell
-- parsing.

isBrace :: TT -> Bool
isBrace :: TT -> Bool
isBrace (Tok b :: Token
b _ _) = Char -> Token
Special '{' Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
b

ignoredToken :: TT -> Bool
ignoredToken :: TT -> Bool
ignoredToken (Tok t :: Token
t _ _) = Token -> Bool
isComment Token
t Bool -> Bool -> Bool
|| Token
t Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
CppDirective

isNoise :: Token -> Bool
isNoise :: Token -> Bool
isNoise (Special c :: Char
c) = Char
c Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (";,`" :: String)
isNoise _ = Bool
True

type Expr t = [Tree t]

data Tree t
    = Paren t (Expr t) t -- A parenthesized expression (maybe with [ ] ...)
    | Block ([Tree t])      -- A list of things separated by layout (as in do; etc.)
    | Atom t
    | Error t
    | Expr [Tree t]
      deriving (Int -> Tree t -> ShowS
[Tree t] -> ShowS
Tree t -> [Char]
(Int -> Tree t -> ShowS)
-> (Tree t -> [Char]) -> ([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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Tree t] -> ShowS
$cshowList :: forall t. Show t => [Tree t] -> ShowS
show :: Tree t -> [Char]
$cshow :: forall t. Show t => Tree t -> [Char]
showsPrec :: Int -> Tree t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> Tree t -> ShowS
Show, 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, 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)

instance IsTree Tree where
    emptyNode :: Tree t
emptyNode = [Tree t] -> Tree t
forall t. [Tree t] -> Tree t
Expr []
    uniplate :: Tree t -> ([Tree t], [Tree t] -> Tree t)
uniplate (Paren l :: t
l g :: [Tree t]
g r :: t
r) = ([Tree t]
g,\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 g :: [Tree t]
g) = ([Tree t]
g,[Tree t] -> Tree t
forall t. [Tree t] -> Tree t
Expr)
    uniplate (Block s :: [Tree t]
s) = ([Tree t]
s,[Tree t] -> Tree t
forall t. [Tree t] -> Tree t
Block)
    uniplate t :: Tree t
t = ([],Tree t -> [Tree t] -> Tree t
forall a b. a -> b -> a
const Tree t
t)

-- | Search the given list, and return the 1st tree after the given
-- point on the given line.  This is the tree that will be moved if
-- something is inserted at the point.  Precondition: point is in the
-- given line.

-- TODO: this should be optimized by just giving the point of the end
-- of the line
getIndentingSubtree :: Tree TT -> Point -> Int -> Maybe (Tree TT)
getIndentingSubtree :: Tree TT -> Point -> Int -> Maybe (Tree TT)
getIndentingSubtree root :: Tree TT
root offset :: Point
offset line :: Int
line =
    [Tree TT] -> Maybe (Tree TT)
forall a. [a] -> Maybe a
listToMaybe [Tree TT
t | (t :: Tree TT
t,posn :: Posn
posn) <- ((Tree TT, Posn) -> Bool) -> [(Tree TT, Posn)] -> [(Tree TT, Posn)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
line) (Int -> Bool)
-> ((Tree TT, Posn) -> Int) -> (Tree TT, Posn) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Posn -> Int
posnLine (Posn -> Int)
-> ((Tree TT, Posn) -> Posn) -> (Tree TT, Posn) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree TT, Posn) -> Posn
forall a b. (a, b) -> b
snd) [(Tree TT, Posn)]
allSubTreesPosn,
                -- it's very important that we do a linear search
                -- here (takeWhile), so that the tree is evaluated
                -- lazily and therefore parsing it can be lazy.
                Posn -> Point
posnOfs Posn
posn Point -> Point -> Bool
forall a. Ord a => a -> a -> Bool
> Point
offset, Posn -> Int
posnLine Posn
posn Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
line]
    where allSubTreesPosn :: [(Tree TT, Posn)]
allSubTreesPosn = [(Tree TT
t',Posn
posn) | t' :: Tree TT
t'@(Block _) <-(Tree TT -> Bool) -> [Tree TT] -> [Tree TT]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Tree TT -> Bool) -> Tree TT -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TT] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TT] -> Bool) -> (Tree TT -> [TT]) -> Tree TT -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree TT -> [TT]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) (Tree TT -> [Tree TT]
forall (tree :: * -> *) t. IsTree tree => tree t -> [tree t]
getAllSubTrees Tree TT
root),
                             let (tok :: TT
tok:_) = Tree TT -> [TT]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Tree TT
t',
                             let posn :: Posn
posn = TT -> Posn
forall t. Tok t -> Posn
tokPosn TT
tok]

-- | Given a tree, return (first offset, number of lines).
getSubtreeSpan :: Tree TT -> (Point, Int)
getSubtreeSpan :: Tree TT -> (Point, Int)
getSubtreeSpan tree :: Tree TT
tree = (Posn -> Point
posnOfs Posn
first, Int
lastLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
firstLine)
    where bounds :: [Posn]
bounds@[first :: Posn
first, _last :: Posn
_last] = (Maybe TT -> Posn) -> [Maybe TT] -> [Posn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TT -> Posn
forall t. Tok t -> Posn
tokPosn (TT -> Posn) -> (Maybe TT -> TT) -> Maybe TT -> Posn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe TT -> TT
forall p. Maybe p -> p
assertJust) [Tree TT -> Maybe TT
forall (t :: * -> *) a. Foldable t => t a -> Maybe a
getFirstElement Tree TT
tree, Tree TT -> Maybe TT
forall (t :: * -> *) a. Foldable t => t a -> Maybe a
getLastElement Tree TT
tree]
          [firstLine :: Int
firstLine, lastLine :: Int
lastLine] = (Posn -> Int) -> [Posn] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Posn -> Int
posnLine [Posn]
bounds
          assertJust :: Maybe p -> p
assertJust (Just x :: p
x) = p
x
          assertJust _ = [Char] -> p
forall a. HasCallStack => [Char] -> a
error "assertJust: Just expected"

-- dropWhile' f = foldMap (\x -> if f x then mempty else Endo (x :))
--
-- isBefore l (Atom t) = isBefore' l t
-- isBefore l (Error t) = isBefore l t
-- isBefore l (Paren l g r) = isBefore l r
-- isBefore l (Block s) = False
--
-- isBefore' l (Tok {tokPosn = Posn {posnLn = l'}}) =


parse :: P TT (Tree TT)
parse :: P TT (Tree TT)
parse = [Tree TT] -> Tree TT
forall t. [Tree t] -> Tree t
Expr ([Tree TT] -> Tree TT) -> Parser TT [Tree TT] -> P TT (Tree TT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TT -> Token) -> (Token -> TT) -> Parser TT [Tree TT]
parse' TT -> Token
forall t. Tok t -> t
tokT Token -> TT
forall t. t -> Tok t
tokFromT

parse' :: (TT -> Token) -> (Token -> TT) -> P TT [Tree TT]
parse' :: (TT -> Token) -> (Token -> TT) -> Parser TT [Tree TT]
parse' toTok :: TT -> Token
toTok _ = Parser TT [Tree TT]
pExpr Parser TT [Tree TT] -> Parser TT () -> Parser TT [Tree TT]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser TT ()
forall s. Parser s ()
eof
    where
      -- parse a special symbol
      sym :: Char -> Parser TT TT
sym c :: Char
c = (TT -> Bool) -> Parser TT TT
forall s. (s -> Bool) -> Parser s s
symbol ([Char] -> Token -> Bool
isSpecial [Char
c] (Token -> Bool) -> (TT -> Token) -> TT -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TT -> Token
toTok)

      pleaseSym :: Char -> Parser TT TT
pleaseSym c :: Char
c = Parser TT TT -> Parser TT TT
forall s a. Parser s a -> Parser s a
recoverWith Parser TT TT
forall t. Parser (Tok t) TT
errTok Parser TT TT -> Parser TT TT -> Parser TT TT
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser TT TT
sym Char
c

      pExpr :: P TT (Expr TT)
      pExpr :: Parser TT [Tree TT]
pExpr = P TT (Tree TT) -> Parser TT [Tree TT]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many P TT (Tree TT)
pTree

      pBlocks :: Parser TT [Tree TT]
pBlocks = ([Tree TT] -> Tree TT
forall t. [Tree t] -> Tree t
Expr ([Tree TT] -> Tree TT) -> Parser TT [Tree TT] -> P TT (Tree TT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser TT [Tree TT]
pExpr) P TT (Tree TT) -> Parser TT TT -> Parser TT [Tree TT]
forall (f :: * -> *) a v. Alternative f => f a -> f v -> f [a]
`sepBy1` Char -> Parser TT TT
sym '.' -- the '.' is generated by the layout, see HACK above
      -- note that we can have empty statements, hence we use sepBy1.

      pTree :: P TT (Tree TT)
      pTree :: P TT (Tree TT)
pTree = (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
<$>  Char -> Parser TT TT
sym '(' Parser TT ([Tree TT] -> TT -> Tree TT)
-> Parser TT [Tree TT] -> Parser TT (TT -> Tree TT)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TT [Tree TT]
pExpr  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
<*> Char -> Parser TT TT
pleaseSym ')')
          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
<$>  Char -> Parser TT TT
sym '[' Parser TT ([Tree TT] -> TT -> Tree TT)
-> Parser TT [Tree TT] -> Parser TT (TT -> Tree TT)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TT [Tree TT]
pExpr  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
<*> Char -> Parser TT TT
pleaseSym ']')
          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
<$>  Char -> Parser TT TT
sym '{' Parser TT ([Tree TT] -> TT -> Tree TT)
-> Parser TT [Tree TT] -> Parser TT (TT -> Tree TT)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TT [Tree TT]
pExpr  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
<*> Char -> Parser TT TT
pleaseSym '}')

          P TT (Tree TT) -> P TT (Tree TT) -> P TT (Tree TT)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([Tree TT] -> Tree TT
forall t. [Tree t] -> Tree t
Block ([Tree TT] -> Tree TT) -> Parser TT [Tree TT] -> P TT (Tree TT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser TT TT
sym '<' Parser TT TT -> Parser TT [Tree TT] -> Parser TT [Tree TT]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser TT [Tree TT]
pBlocks Parser TT [Tree TT] -> Parser TT TT -> Parser TT [Tree TT]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser TT TT
sym '>')) -- see HACK above

          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
<$> (TT -> Bool) -> Parser TT TT
forall s. (s -> Bool) -> Parser s s
symbol (Token -> Bool
isNoise (Token -> Bool) -> (TT -> Token) -> TT -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TT -> Token
toTok))
          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 ((TT -> Bool) -> Parser TT TT
forall s. (s -> Bool) -> Parser s s
symbol ([Char] -> Token -> Bool
isSpecial "})]" (Token -> Bool) -> (TT -> Token) -> TT -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TT -> Token
toTok)))

      -- note that, by construction, '<' and '>' will always be matched, so
      -- we don't try to recover errors with them.

getStrokes :: Point -> Point -> Point -> Tree TT -> [Stroke]
getStrokes :: Point -> Point -> Point -> Tree TT -> [Stroke]
getStrokes point :: Point
point _begin :: Point
_begin _end :: Point
_end t0 :: Tree TT
t0 = -- trace (show t0)
                                  [Stroke]
result
    where getStrokes' :: Tree TT -> Endo [Stroke]
getStrokes' (Atom t :: TT
t) = Stroke -> Endo [Stroke]
forall a. a -> Endo [a]
one (TT -> Stroke
ts TT
t)
          getStrokes' (Error t :: TT
t) = Stroke -> Endo [Stroke]
forall a. a -> Endo [a]
one (StyleName -> Stroke -> Stroke
modStroke StyleName
errorStyle (TT -> Stroke
ts TT
t)) -- paint in red
          getStrokes' (Block s :: [Tree TT]
s) = [Tree TT] -> Endo [Stroke]
getStrokesL [Tree TT]
s
          getStrokes' (Expr g :: [Tree TT]
g) = [Tree TT] -> Endo [Stroke]
getStrokesL [Tree TT]
g
          getStrokes' (Paren l :: TT
l g :: [Tree TT]
g r :: TT
r)
              | Token -> Bool
isErrorTok (Token -> Bool) -> Token -> Bool
forall a b. (a -> b) -> a -> b
$ TT -> Token
forall t. Tok t -> t
tokT TT
r = Stroke -> Endo [Stroke]
forall a. a -> Endo [a]
one (StyleName -> Stroke -> Stroke
modStroke StyleName
errorStyle (TT -> Stroke
ts TT
l)) Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [Tree TT] -> Endo [Stroke]
getStrokesL [Tree TT]
g
              -- 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
- 1
               = Stroke -> Endo [Stroke]
forall a. a -> Endo [a]
one (StyleName -> Stroke -> Stroke
modStroke StyleName
hintStyle (TT -> Stroke
ts TT
l)) Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [Tree TT] -> Endo [Stroke]
getStrokesL [Tree TT]
g Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Stroke -> Endo [Stroke]
forall a. a -> Endo [a]
one (StyleName -> Stroke -> Stroke
modStroke StyleName
hintStyle (TT -> Stroke
ts TT
r))
              | Bool
otherwise  = Stroke -> Endo [Stroke]
forall a. a -> Endo [a]
one (TT -> Stroke
ts TT
l) Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [Tree TT] -> Endo [Stroke]
getStrokesL [Tree TT]
g Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Stroke -> Endo [Stroke]
forall a. a -> Endo [a]
one (TT -> Stroke
ts TT
r)
          getStrokesL :: [Tree TT] -> Endo [Stroke]
getStrokesL = (Tree TT -> Endo [Stroke]) -> [Tree TT] -> Endo [Stroke]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Tree TT -> Endo [Stroke]
getStrokes'
          ts :: TT -> Stroke
ts = TT -> Stroke
tokenToStroke
          result :: [Stroke]
result = Endo [Stroke] -> [Stroke] -> [Stroke]
forall a. Endo a -> a -> a
appEndo (Tree TT -> Endo [Stroke]
getStrokes' Tree TT
t0) []
          one :: a -> Endo [a]
one x :: a
x = ([a] -> [a]) -> Endo [a]
forall a. (a -> a) -> Endo a
Endo (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)


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

modStroke :: StyleName -> Stroke -> Stroke
modStroke :: StyleName -> Stroke -> Stroke
modStroke f :: 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`)

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


-- | Create a special error token. (e.g. fill in where there is no correct token to parse)
-- Note that the position of the token has to be correct for correct computation of
-- node spans.
errTok :: Parser (Tok t) (Tok Token)
errTok :: Parser (Tok t) TT
errTok = Point -> TT
mkTok (Point -> TT) -> Parser (Tok t) Point -> Parser (Tok t) TT
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Tok t) Point
forall t. Parser (Tok t) Point
curPos
   where curPos :: Parser (Tok t) Point
curPos = Maybe (Tok t) -> Point
forall t. Maybe (Tok t) -> Point
tB (Maybe (Tok t) -> Point)
-> Parser (Tok t) (Maybe (Tok t)) -> Parser (Tok t) Point
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Tok t) (Maybe (Tok t))
forall s. Parser s (Maybe s)
lookNext
         tB :: Maybe (Tok t) -> Point
tB Nothing = Point
forall a. Bounded a => a
maxBound
         tB (Just x :: Tok t
x) = Tok t -> Point
forall t. Tok t -> Point
tokBegin Tok t
x
         mkTok :: Point -> TT
mkTok p :: Point
p = Token -> Size -> Posn -> TT
forall t. t -> Size -> Posn -> Tok t
Tok (Char -> Token
Special '!') 0 (Posn
startPosn {posnOfs :: Point
posnOfs = Point
p})