module Yi.Lexer.Alex ( module Yi.Lexer.Alex
, (+~), (~-), Size(..), Stroke ) where
import Lens.Micro.Platform (_1, view, makeLenses)
import qualified Data.Bits
import Data.Char (ord)
import Data.Function (on)
import Data.Ix
import Data.List (foldl')
import Data.Ord (comparing)
import Data.Word (Word8)
import Yi.Style (StyleName)
import Yi.Syntax hiding (mkHighlighter)
import Yi.Utils
utf8Encode :: Char -> [Word8]
utf8Encode = map fromIntegral . go . ord
where
go oc
| oc <= 0x7f = [oc]
| oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6)
, 0x80 + oc Data.Bits..&. 0x3f
]
| oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12)
, 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)
, 0x80 + oc Data.Bits..&. 0x3f
]
| otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18)
, 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)
, 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)
, 0x80 + oc Data.Bits..&. 0x3f
]
type Byte = Word8
type IndexedStr = [(Point, Char)]
type AlexInput = (Char, [Byte], IndexedStr)
type Action hlState token = IndexedStr -> hlState -> (hlState, token)
data AlexState lexerState = AlexState {
stLexer :: lexerState,
lookedOffset :: !Point,
stPosn :: !Posn
} deriving Show
data Tok t = Tok { tokT :: t
, tokLen :: Size
, tokPosn :: Posn
} deriving Functor
instance Eq (Tok a) where
(==) = (==) `on` tokPosn
tokToSpan :: Tok t -> Span t
tokToSpan (Tok t len posn) = Span (posnOfs posn) t (posnOfs posn +~ len)
tokFromT :: t -> Tok t
tokFromT t = Tok t 0 startPosn
tokBegin :: Tok t -> Point
tokBegin = posnOfs . tokPosn
tokEnd :: Tok t -> Point
tokEnd t = tokBegin t +~ tokLen t
instance Show t => Show (Tok t) where
show tok = show (tokPosn tok) ++ ": " ++ show (tokT tok)
data Posn = Posn {
posnOfs :: !Point
, posnLine :: !Int
, posnCol :: !Int
} deriving (Eq, Ix)
instance Ord Posn where
compare = comparing posnOfs
instance Show Posn where
show (Posn o l c) = "L" ++ show l ++ " " ++ "C" ++ show c ++ "@" ++ show o
startPosn :: Posn
startPosn = Posn 0 1 0
moveStr :: Posn -> IndexedStr -> Posn
moveStr posn str = foldl' moveCh posn (fmap snd str)
moveCh :: Posn -> Char -> Posn
moveCh (Posn o l c) '\t' = Posn (o+1) l (((c+8) `div` 8)*8)
moveCh (Posn o l _) '\n' = Posn (o+1) (l+1) 0
moveCh (Posn o l c) _ = Posn (o+1) l (c+1)
alexGetChar :: AlexInput -> Maybe (Char, AlexInput)
alexGetChar (_,_,[]) = Nothing
alexGetChar (_,b,(_,c):rest) = Just (c, (c,b,rest))
alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
alexGetByte (c, b:bs, s) = Just (b,(c,bs,s))
alexGetByte (_, [], []) = Nothing
alexGetByte (_, [], c:s) = case utf8Encode (snd c) of
(b:bs) -> Just (b, ((snd c), bs, s))
[] -> Nothing
alexCollectChar :: AlexInput -> [Char]
alexCollectChar (_, _, []) = []
alexCollectChar (_, b, (_, c):rest) = c : alexCollectChar (c, b, rest)
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar = view _1
actionConst :: token -> Action lexState token
actionConst token = \_str state -> (state, token)
actionAndModify :: (lexState -> lexState) -> token -> Action lexState token
actionAndModify modifierFct token = \_str state -> (modifierFct state, token)
actionStringAndModify :: (s -> s) -> (String -> token) -> Action s token
actionStringAndModify modF f = \istr s -> (modF s, f $ fmap snd istr)
actionStringConst :: (String -> token) -> Action lexState token
actionStringConst f = \indexedStr state -> (state, f $ fmap snd indexedStr)
type ASI s = (AlexState s, AlexInput)
type TokenLexer l s t i = (l s, i) -> Maybe (t, (l s, i))
type CharScanner = Scanner Point Char
data Lexer l s t i = Lexer
{ _step :: TokenLexer l s t i
, _starting :: s -> Point -> Posn -> l s
, _withChars :: Char -> [(Point, Char)] -> i
, _looked :: l s -> Point
, _statePosn :: l s -> Posn
, _lexEmpty :: t
, _startingState :: s
}
data StyleLexer l s t i = StyleLexer
{ _tokenToStyle :: t -> StyleName
, _styleLexer :: Lexer l s (Tok t) i
}
type StyleLexerASI s t = StyleLexer AlexState s t AlexInput
commonLexer :: (ASI s -> Maybe (Tok t, ASI s))
-> s
-> Lexer AlexState s (Tok t) AlexInput
commonLexer l st0 = Lexer
{ _step = l
, _starting = AlexState
, _withChars = \c p -> (c, [], p)
, _looked = lookedOffset
, _statePosn = stPosn
, _lexEmpty = error "Yi.Lexer.Alex.commonLexer: lexEmpty"
, _startingState = st0
}
lexScanner :: Lexer l s t i -> CharScanner -> Scanner (l s) t
lexScanner Lexer {..} src = Scanner
{ scanLooked = _looked
, scanInit = _starting _startingState 0 startPosn
, scanRun = \st -> case posnOfs $ _statePosn st of
0 -> unfoldLexer _step (st, _withChars '\n' $ scanRun src 0)
ofs -> case scanRun src (ofs 1) of
[] -> []
(_, ch) : rest -> unfoldLexer _step (st, _withChars ch rest)
, scanEmpty = _lexEmpty
}
unfoldLexer :: ((state, input) -> Maybe (token, (state, input)))
-> (state, input) -> [(state, token)]
unfoldLexer f b = fst b `seq` case f b of
Nothing -> []
Just (t, b') -> (fst b, t) : unfoldLexer f b'
makeLensesWithSuffix "A" ''Posn
makeLensesWithSuffix "A" ''Tok
makeLenses ''Lexer
makeLenses ''StyleLexer