{-# 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
'(', Char -> Token
Special Char
')'),
                                            (Char -> Token
Special Char
'[', Char -> Token
Special Char
']'),
                                            (Char -> Token
Special Char
'{', Char -> Token
Special Char
'}')] TT -> Bool
ignoredToken
                         (Char -> Token
Special Char
'<', Char -> Token
Special Char
'>', Char -> Token
Special Char
'.') TT -> Bool
isBrace

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

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

ignoredToken :: TT -> Bool
ignoredToken :: TT -> Bool
ignoredToken (Tok Token
t Size
_ Posn
_) = 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 Char
c) = Char
c Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
";,`" :: String)
isNoise Token
_ = 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 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. [Tree t] -> Tree t
Expr)
    uniplate (Block [Tree t]
s) = ([Tree t]
s,[Tree t] -> Tree t
forall t. [Tree t] -> Tree t
Block)
    uniplate 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 Tree TT
root Point
offset Int
line =
    [Tree TT] -> Maybe (Tree TT)
forall a. [a] -> Maybe a
listToMaybe [Tree TT
t | (Tree TT
t,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]
_) <-(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 (TT
tok:[TT]
_) = 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 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@[Posn
first, 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]
          [Int
firstLine, 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 p
x) = p
x
          assertJust Maybe p
_ = [Char] -> p
forall a. HasCallStack => [Char] -> a
error [Char]
"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' TT -> Token
toTok Token -> TT
_ = 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 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 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 Char
'.' -- 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 Char
'(' 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 Char
')')
          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 Char
'[' 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 Char
']')
          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 Char
'{' 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 Char
'}')

          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 Char
'<' 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 Char
'>')) -- 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 [Char]
"})]" (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
_end Tree TT
t0 = -- trace (show t0)
                                  [Stroke]
result
    where getStrokes' :: Tree TT -> Endo [Stroke]
getStrokes' (Atom TT
t) = Stroke -> Endo [Stroke]
forall a. a -> Endo [a]
one (TT -> Stroke
ts TT
t)
          getStrokes' (Error 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 [Tree TT]
s) = [Tree TT] -> Endo [Stroke]
getStrokesL [Tree TT]
s
          getStrokes' (Expr [Tree TT]
g) = [Tree TT] -> Endo [Stroke]
getStrokesL [Tree TT]
g
          getStrokes' (Paren TT
l [Tree TT]
g 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
- Point
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 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 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 Maybe (Tok t)
Nothing = Point
forall a. Bounded a => a
maxBound
         tB (Just Tok t
x) = Tok t -> Point
forall t. Tok t -> Point
tokBegin Tok t
x
         mkTok :: Point -> TT
mkTok Point
p = Token -> Size -> Posn -> TT
forall t. t -> Size -> Posn -> Tok t
Tok (Char -> Token
Special Char
'!') Size
0 (Posn
startPosn {posnOfs :: Point
posnOfs = Point
p})