{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
{-# OPTIONS_HADDOCK show-extensions #-}
module Yi.Syntax.Strokes.Haskell (getStrokes, tokenToAnnot) where
import Prelude hiding (any, error, exp)
import Data.Foldable (any)
import Data.Monoid (Endo (..), (<>))
import Yi.Debug (error, trace)
import Yi.Lexer.Alex (Posn (posnOfs), Stroke, Tok (tokPosn, tokT), tokToSpan)
import Yi.Lexer.Haskell
import Yi.String (showT)
import Yi.Style
import Yi.Syntax (Point, Span)
import Yi.Syntax.Haskell
import Yi.Syntax.Tree (subtrees)
getStrokes :: Point -> Point -> Point -> Tree TT -> [Stroke]
getStrokes :: Point -> Point -> Point -> Tree TT -> [Stroke]
getStrokes Point
point Point
begin Point
_end Tree TT
t0 = Text -> [Stroke] -> [Stroke]
forall a. Text -> a -> a
trace (Tree TT -> Text
forall a. Show a => a -> Text
showT Tree TT
t0) [Stroke]
result
where result :: [Stroke]
result = Endo [Stroke] -> [Stroke] -> [Stroke]
forall a. Endo a -> a -> a
appEndo ((TT -> Endo [Stroke])
-> Point -> Point -> Point -> Tree TT -> Endo [Stroke]
getStr TT -> Endo [Stroke]
tkDConst Point
point Point
begin Point
_end Tree TT
t0) []
getStrokeMod :: Point -> Point -> Point -> PModuleDecl TT -> Endo [Stroke]
getStrokeMod :: Point -> Point -> Point -> Tree TT -> Endo [Stroke]
getStrokeMod Point
point Point
begin Point
_end tm :: Tree TT
tm@(PModuleDecl Tree TT
m Tree TT
na Tree TT
e Tree TT
w)
= Tree TT -> Tree TT -> Endo [Stroke]
forall (v :: * -> *).
Foldable v =>
v TT -> Tree TT -> Endo [Stroke]
pKW Tree TT
tm Tree TT
m Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> (TT -> Endo [Stroke])
-> Point -> Point -> Point -> Tree TT -> Endo [Stroke]
getStr TT -> Endo [Stroke]
tkImport Point
point Point
begin Point
_end Tree TT
na
Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Tree TT -> Endo [Stroke]
getStrokes' Tree TT
e Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Tree TT -> Endo [Stroke]
getStrokes' Tree TT
w
where getStrokes' :: Tree TT -> Endo [Stroke]
getStrokes' = (TT -> Endo [Stroke])
-> Point -> Point -> Point -> Tree TT -> Endo [Stroke]
getStr TT -> Endo [Stroke]
tkDConst Point
point Point
begin Point
_end
pKW :: v TT -> Tree TT -> Endo [Stroke]
pKW v TT
b Tree TT
word | v TT -> Bool
forall (v :: * -> *). Foldable v => v TT -> Bool
isErrN v TT
b = StyleName -> Tree TT -> Endo [Stroke]
paintAtom StyleName
errorStyle Tree TT
word
| Bool
otherwise = Tree TT -> Endo [Stroke]
getStrokes' Tree TT
word
getStrokeImp :: Point -> Point -> Point -> PImport TT -> Endo [Stroke]
getStrokeImp :: Point -> Point -> Point -> Tree TT -> Endo [Stroke]
getStrokeImp Point
point Point
begin Point
_end imp :: Tree TT
imp@(PImport Tree TT
m Tree TT
qu Tree TT
na Tree TT
t Tree TT
t')
= Tree TT -> Tree TT -> Endo [Stroke]
forall (v :: * -> *).
Foldable v =>
v TT -> Tree TT -> Endo [Stroke]
pKW Tree TT
imp Tree TT
m Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Tree TT -> Endo [Stroke]
paintQu Tree TT
qu
Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> (TT -> Endo [Stroke])
-> Point -> Point -> Point -> Tree TT -> Endo [Stroke]
getStr TT -> Endo [Stroke]
tkImport Point
point Point
begin Point
_end Tree TT
na Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Tree TT -> Endo [Stroke]
paintAs Tree TT
t Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Tree TT -> Endo [Stroke]
paintHi Tree TT
t'
where getStrokes' :: Tree TT -> Endo [Stroke]
getStrokes' = (TT -> Endo [Stroke])
-> Point -> Point -> Point -> Tree TT -> Endo [Stroke]
getStr TT -> Endo [Stroke]
tkDConst Point
point Point
begin Point
_end
paintAs :: Tree TT -> Endo [Stroke]
paintAs (Opt (Just (Bin (PAtom TT
n [TT]
c) Tree TT
tw)))
= Stroke -> Endo [Stroke]
one (((Token -> StyleName) -> Span Token -> Stroke
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (StyleName -> Token -> StyleName
forall a b. a -> b -> a
const StyleName
keywordStyle) (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) TT
n) Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [TT] -> Endo [Stroke]
com [TT]
c
Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> (TT -> Endo [Stroke])
-> Point -> Point -> Point -> Tree TT -> Endo [Stroke]
getStr TT -> Endo [Stroke]
tkImport Point
point Point
begin Point
_end Tree TT
tw
paintAs Tree TT
a = Tree TT -> Endo [Stroke]
getStrokes' Tree TT
a
paintQu :: Tree TT -> Endo [Stroke]
paintQu (Opt (Just (PAtom TT
n [TT]
c))) = Stroke -> Endo [Stroke]
one (((Token -> StyleName) -> Span Token -> Stroke
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (StyleName -> Token -> StyleName
forall a b. a -> b -> a
const StyleName
keywordStyle) (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) TT
n) Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [TT] -> Endo [Stroke]
com [TT]
c
paintQu Tree TT
a = Tree TT -> Endo [Stroke]
getStrokes' Tree TT
a
paintHi :: Tree TT -> Endo [Stroke]
paintHi (TC (Bin (Bin (PAtom TT
n [TT]
c) Tree TT
tw) Tree TT
r)) = Stroke -> Endo [Stroke]
one (((Token -> StyleName) -> Span Token -> Stroke
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (StyleName -> Token -> StyleName
forall a b. a -> b -> a
const StyleName
keywordStyle) (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) TT
n)
Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [TT] -> Endo [Stroke]
com [TT]
c Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> (TT -> Endo [Stroke])
-> Point -> Point -> Point -> Tree TT -> Endo [Stroke]
getStr TT -> Endo [Stroke]
tkImport Point
point Point
begin Point
_end Tree TT
tw
Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Tree TT -> Endo [Stroke]
getStrokes' Tree TT
r
paintHi Tree TT
a = Tree TT -> Endo [Stroke]
getStrokes' Tree TT
a
pKW :: v TT -> Tree TT -> Endo [Stroke]
pKW v TT
b Tree TT
word | v TT -> Bool
forall (v :: * -> *). Foldable v => v TT -> Bool
isErrN v TT
b = StyleName -> Tree TT -> Endo [Stroke]
paintAtom StyleName
errorStyle Tree TT
word
| Bool
otherwise = Tree TT -> Endo [Stroke]
getStrokes' Tree TT
word
getStr :: (TT -> Endo [Stroke]) -> Point -> Point -> Point -> Exp TT
-> Endo [Stroke]
getStr :: (TT -> Endo [Stroke])
-> Point -> Point -> Point -> Tree TT -> Endo [Stroke]
getStr TT -> Endo [Stroke]
tk Point
point Point
begin Point
_end = Tree TT -> Endo [Stroke]
getStrokes'
where getStrokes' :: Exp TT -> Endo [Stroke]
getStrokes' :: Tree TT -> Endo [Stroke]
getStrokes' t :: Tree TT
t@(PImport {}) = Point -> Point -> Point -> Tree TT -> Endo [Stroke]
getStrokeImp Point
point Point
begin Point
_end Tree TT
t
getStrokes' t :: Tree TT
t@(PModuleDecl {}) = Point -> Point -> Point -> Tree TT -> Endo [Stroke]
getStrokeMod Point
point Point
begin Point
_end Tree TT
t
getStrokes' (PModule [TT]
c Maybe (Tree TT)
m) = [TT] -> Endo [Stroke]
com [TT]
c Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> (Tree TT -> Endo [Stroke]) -> Maybe (Tree TT) -> Endo [Stroke]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Tree TT -> Endo [Stroke]
getStrokes' Maybe (Tree TT)
m
getStrokes' (PAtom TT
t [TT]
c) = TT -> Endo [Stroke]
tk TT
t Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [TT] -> Endo [Stroke]
com [TT]
c
getStrokes' (TS TT
col [Tree TT]
ts') = TT -> Endo [Stroke]
tk TT
col Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> (Tree TT -> Endo [Stroke]) -> [Tree TT] -> Endo [Stroke]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((TT -> Endo [Stroke])
-> Point -> Point -> Point -> Tree TT -> Endo [Stroke]
getStr TT -> Endo [Stroke]
tkTConst Point
point Point
begin Point
_end) [Tree TT]
ts'
getStrokes' (Modid TT
t [TT]
c) = TT -> Endo [Stroke]
tkImport TT
t Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [TT] -> Endo [Stroke]
com [TT]
c
getStrokes' (Paren (PAtom TT
l [TT]
c) [Tree TT]
g (PAtom TT
r [TT]
c'))
| TT -> Bool
isErr TT
r = TT -> Endo [Stroke]
errStyle TT
l Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [Tree TT] -> Endo [Stroke]
getStrokesL [Tree TT]
g
| 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
= StyleName -> TT -> Endo [Stroke]
pStyle StyleName
hintStyle TT
l Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [TT] -> Endo [Stroke]
com [TT]
c 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
<> StyleName -> TT -> Endo [Stroke]
pStyle StyleName
hintStyle TT
r Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [TT] -> Endo [Stroke]
com [TT]
c'
| Bool
otherwise = TT -> Endo [Stroke]
tk TT
l Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [TT] -> Endo [Stroke]
com [TT]
c 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
<> TT -> Endo [Stroke]
tk TT
r Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [TT] -> Endo [Stroke]
com [TT]
c'
getStrokes' (PError TT
t TT
_ [TT]
c) = TT -> Endo [Stroke]
errStyle TT
t Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [TT] -> Endo [Stroke]
com [TT]
c
getStrokes' da :: Tree TT
da@(PData Tree TT
kw Tree TT
na Tree TT
exp Tree TT
eq)
= Tree TT -> Tree TT -> Endo [Stroke]
forall (v :: * -> *).
Foldable v =>
v TT -> Tree TT -> Endo [Stroke]
pKW Tree TT
da Tree TT
kw Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Tree TT -> Endo [Stroke]
getStrokes' Tree TT
na
Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Tree TT -> Endo [Stroke]
getStrokes' Tree TT
exp Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Tree TT -> Endo [Stroke]
getStrokes' Tree TT
eq
getStrokes' (PIn TT
t [Tree TT]
l) = TT -> Endo [Stroke]
tk TT
t Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [Tree TT] -> Endo [Stroke]
getStrokesL [Tree TT]
l
getStrokes' (TC Tree TT
l) = (TT -> Endo [Stroke])
-> Point -> Point -> Point -> Tree TT -> Endo [Stroke]
getStr TT -> Endo [Stroke]
tkTConst Point
point Point
begin Point
_end Tree TT
l
getStrokes' (DC (PAtom TT
l [TT]
c)) = TT -> Endo [Stroke]
tkDConst TT
l Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [TT] -> Endo [Stroke]
com [TT]
c
getStrokes' (DC Tree TT
r) = Tree TT -> Endo [Stroke]
getStrokes' Tree TT
r
getStrokes' g :: Tree TT
g@(PGuard' Tree TT
t Tree TT
e Tree TT
t')
= Tree TT -> Tree TT -> Endo [Stroke]
forall (v :: * -> *).
Foldable v =>
v TT -> Tree TT -> Endo [Stroke]
pKW Tree TT
g Tree TT
t Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Tree TT -> Endo [Stroke]
getStrokes' Tree TT
e Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Tree TT -> Endo [Stroke]
getStrokes' Tree TT
t'
getStrokes' cl :: Tree TT
cl@(PClass Tree TT
e Tree TT
e' Tree TT
exp)
= Tree TT -> Tree TT -> Endo [Stroke]
forall (v :: * -> *).
Foldable v =>
v TT -> Tree TT -> Endo [Stroke]
pKW Tree TT
cl Tree TT
e Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Tree TT -> Endo [Stroke]
getStrokes' Tree TT
e'
Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> Tree TT -> Endo [Stroke]
getStrokes' Tree TT
exp
getStrokes' Tree TT
t = (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' (Tree TT -> [Tree TT]
forall (tree :: * -> *) t. IsTree tree => tree t -> [tree t]
subtrees Tree TT
t)
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'
pKW :: v TT -> Tree TT -> Endo [Stroke]
pKW v TT
b Tree TT
word | v TT -> Bool
forall (v :: * -> *). Foldable v => v TT -> Bool
isErrN v TT
b = StyleName -> Tree TT -> Endo [Stroke]
paintAtom StyleName
errorStyle Tree TT
word
| Bool
otherwise = Tree TT -> Endo [Stroke]
getStrokes' Tree TT
word
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
ts :: TT -> Stroke
ts :: TT -> Stroke
ts = TT -> Stroke
tokenToStroke
pStyle :: StyleName -> TT -> Endo [Stroke]
pStyle :: StyleName -> TT -> Endo [Stroke]
pStyle StyleName
style = Stroke -> Endo [Stroke]
one (Stroke -> Endo [Stroke]) -> (TT -> Stroke) -> TT -> Endo [Stroke]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleName -> Stroke -> Stroke
modStroke StyleName
style (Stroke -> Stroke) -> (TT -> Stroke) -> TT -> Stroke
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TT -> Stroke
ts
one :: Stroke -> Endo [Stroke]
one :: Stroke -> Endo [Stroke]
one Stroke
x = ([Stroke] -> [Stroke]) -> Endo [Stroke]
forall a. (a -> a) -> Endo a
Endo (Stroke
x Stroke -> [Stroke] -> [Stroke]
forall a. a -> [a] -> [a]
:)
paintAtom :: StyleName -> Exp TT -> Endo [Stroke]
paintAtom :: StyleName -> Tree TT -> Endo [Stroke]
paintAtom StyleName
col (PAtom TT
a [TT]
c) = StyleName -> TT -> Endo [Stroke]
pStyle StyleName
col TT
a Endo [Stroke] -> Endo [Stroke] -> Endo [Stroke]
forall a. Semigroup a => a -> a -> a
<> [TT] -> Endo [Stroke]
com [TT]
c
paintAtom StyleName
_ Tree TT
_ = Text -> Endo [Stroke]
forall a. Text -> a
error Text
"wrong usage of paintAtom"
isErr :: TT -> Bool
isErr :: TT -> Bool
isErr = Token -> Bool
isErrorTok (Token -> Bool) -> (TT -> Token) -> TT -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TT -> Token
forall t. Tok t -> t
tokT
isErrN :: (Foldable v) => v TT -> Bool
isErrN :: v TT -> Bool
isErrN = (TT -> Bool) -> v TT -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TT -> Bool
isErr
errStyle :: TT -> Endo [Stroke]
errStyle :: TT -> Endo [Stroke]
errStyle = StyleName -> TT -> Endo [Stroke]
pStyle StyleName
errorStyle
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`)
com :: [TT] -> Endo [Stroke]
com :: [TT] -> Endo [Stroke]
com = (TT -> Endo [Stroke]) -> [TT] -> Endo [Stroke]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TT -> Endo [Stroke]
tkDConst
tk' :: (TT -> Bool) -> (TT -> Endo [Stroke]) -> TT -> Endo [Stroke]
tk' :: (TT -> Bool) -> (TT -> Endo [Stroke]) -> TT -> Endo [Stroke]
tk' TT -> Bool
f TT -> Endo [Stroke]
s TT
t | TT -> Bool
isErr TT
t = TT -> Endo [Stroke]
errStyle TT
t
| TT -> Token
forall t. Tok t -> t
tokT TT
t Token -> [Token] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (ReservedType -> Token) -> [ReservedType] -> [Token]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ReservedType -> Token
Reserved [ReservedType
As, ReservedType
Qualified, ReservedType
Hiding]
= Stroke -> Endo [Stroke]
one (Stroke -> Endo [Stroke]) -> Stroke -> Endo [Stroke]
forall a b. (a -> b) -> a -> b
$ ((Token -> StyleName) -> Span Token -> Stroke
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (StyleName -> Token -> StyleName
forall a b. a -> b -> a
const StyleName
variableStyle) (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) TT
t
| TT -> Bool
f TT
t = TT -> Endo [Stroke]
s TT
t
| Bool
otherwise = Stroke -> Endo [Stroke]
one (TT -> Stroke
ts TT
t)
tkTConst :: TT -> Endo [Stroke]
tkTConst :: TT -> Endo [Stroke]
tkTConst = (TT -> Bool) -> (TT -> Endo [Stroke]) -> TT -> Endo [Stroke]
tk' (Bool -> TT -> Bool
forall a b. a -> b -> a
const Bool
False) (Endo [Stroke] -> TT -> Endo [Stroke]
forall a b. a -> b -> a
const (([Stroke] -> [Stroke]) -> Endo [Stroke]
forall a. (a -> a) -> Endo a
Endo [Stroke] -> [Stroke]
forall a. a -> a
id))
tkDConst :: TT -> Endo [Stroke]
tkDConst :: TT -> Endo [Stroke]
tkDConst = (TT -> Bool) -> (TT -> Endo [Stroke]) -> TT -> Endo [Stroke]
tk' ((Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
ConsIdent) (Token -> Bool) -> (TT -> Token) -> TT -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TT -> Token
forall t. Tok t -> t
tokT) (StyleName -> TT -> Endo [Stroke]
pStyle StyleName
dataConstructorStyle)
tkImport :: TT -> Endo [Stroke]
tkImport :: TT -> Endo [Stroke]
tkImport = (TT -> Bool) -> (TT -> Endo [Stroke]) -> TT -> Endo [Stroke]
tk' ((Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
== Token
ConsIdent) (Token -> Bool) -> (TT -> Token) -> TT -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TT -> Token
forall t. Tok t -> t
tokT) (StyleName -> TT -> Endo [Stroke]
pStyle StyleName
importStyle)