{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
{-# OPTIONS_HADDOCK show-extensions #-}

-- |
-- Module      :  Yi.Syntax.Strokes.Haskell
-- License     :  GPL-2
-- Maintainer  :  yi-devel@googlegroups.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Produces 'Stroke's from a tree of tokens, used by some of the
-- Haskell modes.

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)

-- TODO: (optimization) make sure we take in account the begin, so we
-- don't return useless strokes
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) []

-- | Get strokes Module for module
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

-- | Get strokes for Imports
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

-- | Get strokes for expressions and declarations
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
              -- 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
               = 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 -- do not color operator dc
          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) -- by default deal with subtrees
          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

-- Stroke helpers follows

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
--
--         || not $ null $ isError' t

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)