{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}

module Ide.Plugin.SemanticTokens.Tokenize (computeRangeHsSemanticTokenTypeList) where

import           Control.Lens                     (Identity (runIdentity))
import           Control.Monad                    (foldM, guard)
import           Control.Monad.State.Strict       (MonadState (get),
                                                   MonadTrans (lift),
                                                   evalStateT, modify, put)
import           Control.Monad.Trans.State.Strict (StateT, runStateT)
import           Data.Char                        (isAlphaNum)
import           Data.DList                       (DList)
import qualified Data.DList                       as DL
import qualified Data.Map.Strict                  as M
import qualified Data.Map.Strict                  as Map
import           Data.Text                        (Text)
import qualified Data.Text                        as T
import qualified Data.Text.Rope                   as Char
import qualified Data.Text.Utf16.Rope             as Utf16
import           Data.Text.Utf16.Rope.Mixed       (Rope)
import qualified Data.Text.Utf16.Rope.Mixed       as Rope
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.Error        (realSrcSpanToCodePointRange)
import           Ide.Plugin.SemanticTokens.Types  (HsSemanticTokenType (TModule),
                                                   RangeHsSemanticTokenTypes (..))
import           Language.LSP.Protocol.Types      (Position (Position),
                                                   Range (Range), UInt, mkRange)
import           Language.LSP.VFS                 hiding (line)
import           Prelude                          hiding (length, span)

type Tokenizer m a = StateT PTokenState m a
type HsSemanticLookup = Identifier -> Maybe HsSemanticTokenType


data PTokenState = PTokenState
  {
    PTokenState -> Rope
rope             :: !Rope -- the remains of rope we are working on
    , PTokenState -> Position
cursor         :: !Char.Position -- the cursor position of the current rope to the start of the original file in code point position
    , PTokenState -> UInt
columnsInUtf16 :: !UInt -- the column of the start of the current rope in utf16
  }

data SplitResult
  = NoSplit (Text, Range) -- does not need to split, token text, token range
  | Split (Text, Range, Range) -- token text, prefix range(module range), token range
  deriving (Int -> SplitResult -> ShowS
[SplitResult] -> ShowS
SplitResult -> String
(Int -> SplitResult -> ShowS)
-> (SplitResult -> String)
-> ([SplitResult] -> ShowS)
-> Show SplitResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SplitResult -> ShowS
showsPrec :: Int -> SplitResult -> ShowS
$cshow :: SplitResult -> String
show :: SplitResult -> String
$cshowList :: [SplitResult] -> ShowS
showList :: [SplitResult] -> ShowS
Show)

getSplitTokenText :: SplitResult -> Text
getSplitTokenText :: SplitResult -> Text
getSplitTokenText (NoSplit (Text
t, Range
_))  = Text
t
getSplitTokenText (Split (Text
t, Range
_, Range
_)) = Text
t


mkPTokenState :: VirtualFile -> PTokenState
mkPTokenState :: VirtualFile -> PTokenState
mkPTokenState VirtualFile
vf =
  PTokenState
    {
      rope :: Rope
rope = VirtualFile
vf._file_text,
      cursor :: Position
cursor = Word -> Word -> Position
Char.Position Word
0 Word
0,
      columnsInUtf16 :: UInt
columnsInUtf16 = UInt
0
    }

-- lift a Tokenizer Maybe a to Tokenizer m a,
-- if the Maybe is Nothing, do nothing, recover the state, and return the mempty value
-- if the Maybe is Just x, do the action, and keep the state, and return x
liftMaybeM :: (Monad m, Monoid a) => Tokenizer Maybe a -> Tokenizer m a
liftMaybeM :: forall (m :: * -> *) a.
(Monad m, Monoid a) =>
Tokenizer Maybe a -> Tokenizer m a
liftMaybeM Tokenizer Maybe a
p = do
  PTokenState
st <- StateT PTokenState m PTokenState
forall s (m :: * -> *). MonadState s m => m s
get
  Tokenizer m a
-> ((a, PTokenState) -> Tokenizer m a)
-> Maybe (a, PTokenState)
-> Tokenizer m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> Tokenizer m a
forall a. a -> StateT PTokenState m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. Monoid a => a
mempty) (\(a
ans, PTokenState
st') -> PTokenState -> StateT PTokenState m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put PTokenState
st' StateT PTokenState m () -> Tokenizer m a -> Tokenizer m a
forall a b.
StateT PTokenState m a
-> StateT PTokenState m b -> StateT PTokenState m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Tokenizer m a
forall a. a -> StateT PTokenState m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
ans) (Maybe (a, PTokenState) -> Tokenizer m a)
-> Maybe (a, PTokenState) -> Tokenizer m a
forall a b. (a -> b) -> a -> b
$ Tokenizer Maybe a -> PTokenState -> Maybe (a, PTokenState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Tokenizer Maybe a
p PTokenState
st

foldMapM :: (Monad m, Monoid b, Foldable t) => (a -> m b) -> t a -> m b
foldMapM :: forall (m :: * -> *) b (t :: * -> *) a.
(Monad m, Monoid b, Foldable t) =>
(a -> m b) -> t a -> m b
foldMapM a -> m b
f t a
ta = (b -> a -> m b) -> b -> t a -> m b
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\b
b a
a -> b -> b -> b
forall a. Monoid a => a -> a -> a
mappend b
b (b -> b) -> m b -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m b
f a
a) b
forall a. Monoid a => a
mempty t a
ta

computeRangeHsSemanticTokenTypeList :: HsSemanticLookup -> VirtualFile -> HieAST a -> RangeHsSemanticTokenTypes
computeRangeHsSemanticTokenTypeList :: forall a.
HsSemanticLookup
-> VirtualFile -> HieAST a -> RangeHsSemanticTokenTypes
computeRangeHsSemanticTokenTypeList HsSemanticLookup
lookupHsTokenType VirtualFile
vf HieAST a
ast =
    RangeSemanticTokenTypeList -> RangeHsSemanticTokenTypes
RangeHsSemanticTokenTypes (RangeSemanticTokenTypeList -> RangeHsSemanticTokenTypes)
-> RangeSemanticTokenTypeList -> RangeHsSemanticTokenTypes
forall a b. (a -> b) -> a -> b
$ DList (Range, HsSemanticTokenType) -> RangeSemanticTokenTypeList
forall a. DList a -> [a]
DL.toList (DList (Range, HsSemanticTokenType) -> RangeSemanticTokenTypeList)
-> DList (Range, HsSemanticTokenType) -> RangeSemanticTokenTypeList
forall a b. (a -> b) -> a -> b
$ Identity (DList (Range, HsSemanticTokenType))
-> DList (Range, HsSemanticTokenType)
forall a. Identity a -> a
runIdentity (Identity (DList (Range, HsSemanticTokenType))
 -> DList (Range, HsSemanticTokenType))
-> Identity (DList (Range, HsSemanticTokenType))
-> DList (Range, HsSemanticTokenType)
forall a b. (a -> b) -> a -> b
$ StateT PTokenState Identity (DList (Range, HsSemanticTokenType))
-> PTokenState -> Identity (DList (Range, HsSemanticTokenType))
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (HsSemanticLookup
-> HieAST a
-> StateT PTokenState Identity (DList (Range, HsSemanticTokenType))
forall (m :: * -> *) t.
Monad m =>
HsSemanticLookup
-> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType))
foldAst HsSemanticLookup
lookupHsTokenType HieAST a
ast) (VirtualFile -> PTokenState
mkPTokenState VirtualFile
vf)
-- | foldAst
-- visit every leaf node in the ast in depth first order
foldAst :: (Monad m) => HsSemanticLookup -> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType))
foldAst :: forall (m :: * -> *) t.
Monad m =>
HsSemanticLookup
-> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType))
foldAst HsSemanticLookup
lookupHsTokenType HieAST t
ast = if [HieAST t] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (HieAST t -> [HieAST t]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST t
ast)
  then Tokenizer Maybe (DList (Range, HsSemanticTokenType))
-> Tokenizer m (DList (Range, HsSemanticTokenType))
forall (m :: * -> *) a.
(Monad m, Monoid a) =>
Tokenizer Maybe a -> Tokenizer m a
liftMaybeM (HsSemanticLookup
-> HieAST t -> Tokenizer Maybe (DList (Range, HsSemanticTokenType))
forall t.
HsSemanticLookup
-> HieAST t -> Tokenizer Maybe (DList (Range, HsSemanticTokenType))
visitLeafIds HsSemanticLookup
lookupHsTokenType HieAST t
ast)
  else (HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType)))
-> [HieAST t] -> Tokenizer m (DList (Range, HsSemanticTokenType))
forall (m :: * -> *) b (t :: * -> *) a.
(Monad m, Monoid b, Foldable t) =>
(a -> m b) -> t a -> m b
foldMapM (HsSemanticLookup
-> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType))
forall (m :: * -> *) t.
Monad m =>
HsSemanticLookup
-> HieAST t -> Tokenizer m (DList (Range, HsSemanticTokenType))
foldAst HsSemanticLookup
lookupHsTokenType) ([HieAST t] -> Tokenizer m (DList (Range, HsSemanticTokenType)))
-> [HieAST t] -> Tokenizer m (DList (Range, HsSemanticTokenType))
forall a b. (a -> b) -> a -> b
$ HieAST t -> [HieAST t]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST t
ast

visitLeafIds :: HsSemanticLookup -> HieAST t -> Tokenizer Maybe (DList (Range, HsSemanticTokenType))
visitLeafIds :: forall t.
HsSemanticLookup
-> HieAST t -> Tokenizer Maybe (DList (Range, HsSemanticTokenType))
visitLeafIds HsSemanticLookup
lookupHsTokenType HieAST t
leaf = Tokenizer Maybe (DList (Range, HsSemanticTokenType))
-> Tokenizer Maybe (DList (Range, HsSemanticTokenType))
forall (m :: * -> *) a.
(Monad m, Monoid a) =>
Tokenizer Maybe a -> Tokenizer m a
liftMaybeM (Tokenizer Maybe (DList (Range, HsSemanticTokenType))
 -> Tokenizer Maybe (DList (Range, HsSemanticTokenType)))
-> Tokenizer Maybe (DList (Range, HsSemanticTokenType))
-> Tokenizer Maybe (DList (Range, HsSemanticTokenType))
forall a b. (a -> b) -> a -> b
$ do
  let span :: Span
span = HieAST t -> Span
forall a. HieAST a -> Span
nodeSpan HieAST t
leaf
  (Range
ran, Text
token) <- HieAST t -> Tokenizer Maybe (Range, Text)
forall a. HieAST a -> Tokenizer Maybe (Range, Text)
focusTokenAt HieAST t
leaf
  -- if `focusTokenAt` succeed, we can safely assume we have shift the cursor correctly
  -- we do not need to recover the cursor state, even if the following computation failed
  Tokenizer Maybe (DList (Range, HsSemanticTokenType))
-> Tokenizer Maybe (DList (Range, HsSemanticTokenType))
forall (m :: * -> *) a.
(Monad m, Monoid a) =>
Tokenizer Maybe a -> Tokenizer m a
liftMaybeM (Tokenizer Maybe (DList (Range, HsSemanticTokenType))
 -> Tokenizer Maybe (DList (Range, HsSemanticTokenType)))
-> Tokenizer Maybe (DList (Range, HsSemanticTokenType))
-> Tokenizer Maybe (DList (Range, HsSemanticTokenType))
forall a b. (a -> b) -> a -> b
$ do
    -- only handle the leaf node with single column token
    Bool -> StateT PTokenState Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> StateT PTokenState Maybe ())
-> Bool -> StateT PTokenState Maybe ()
forall a b. (a -> b) -> a -> b
$ Span -> Int
srcSpanStartLine Span
span Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Span -> Int
srcSpanEndLine Span
span
    SplitResult
splitResult <- Maybe SplitResult -> StateT PTokenState Maybe SplitResult
forall (m :: * -> *) a. Monad m => m a -> StateT PTokenState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe SplitResult -> StateT PTokenState Maybe SplitResult)
-> Maybe SplitResult -> StateT PTokenState Maybe SplitResult
forall a b. (a -> b) -> a -> b
$ Text -> Range -> Maybe SplitResult
splitRangeByText Text
token Range
ran
    (NodeInfo t
 -> Tokenizer Maybe (DList (Range, HsSemanticTokenType)))
-> Map NodeOrigin (NodeInfo t)
-> Tokenizer Maybe (DList (Range, HsSemanticTokenType))
forall (m :: * -> *) b (t :: * -> *) a.
(Monad m, Monoid b, Foldable t) =>
(a -> m b) -> t a -> m b
foldMapM (HsSemanticLookup
-> Range
-> SplitResult
-> NodeInfo t
-> Tokenizer Maybe (DList (Range, HsSemanticTokenType))
forall (m :: * -> *) a.
Monad m =>
HsSemanticLookup
-> Range
-> SplitResult
-> NodeInfo a
-> Tokenizer m (DList (Range, HsSemanticTokenType))
combineNodeIds HsSemanticLookup
lookupHsTokenType Range
ran SplitResult
splitResult) (Map NodeOrigin (NodeInfo t)
 -> Tokenizer Maybe (DList (Range, HsSemanticTokenType)))
-> Map NodeOrigin (NodeInfo t)
-> Tokenizer Maybe (DList (Range, HsSemanticTokenType))
forall a b. (a -> b) -> a -> b
$ (NodeOrigin -> NodeInfo t -> Bool)
-> Map NodeOrigin (NodeInfo t) -> Map NodeOrigin (NodeInfo t)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\NodeOrigin
k NodeInfo t
_ -> NodeOrigin
k NodeOrigin -> NodeOrigin -> Bool
forall a. Eq a => a -> a -> Bool
== NodeOrigin
SourceInfo) (Map NodeOrigin (NodeInfo t) -> Map NodeOrigin (NodeInfo t))
-> Map NodeOrigin (NodeInfo t) -> Map NodeOrigin (NodeInfo t)
forall a b. (a -> b) -> a -> b
$ SourcedNodeInfo t -> Map NodeOrigin (NodeInfo t)
forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo (SourcedNodeInfo t -> Map NodeOrigin (NodeInfo t))
-> SourcedNodeInfo t -> Map NodeOrigin (NodeInfo t)
forall a b. (a -> b) -> a -> b
$ HieAST t -> SourcedNodeInfo t
forall a. HieAST a -> SourcedNodeInfo a
sourcedNodeInfo HieAST t
leaf
  where
    combineNodeIds :: (Monad m) => HsSemanticLookup -> Range -> SplitResult -> NodeInfo a -> Tokenizer m (DList (Range, HsSemanticTokenType))
    combineNodeIds :: forall (m :: * -> *) a.
Monad m =>
HsSemanticLookup
-> Range
-> SplitResult
-> NodeInfo a
-> Tokenizer m (DList (Range, HsSemanticTokenType))
combineNodeIds HsSemanticLookup
lookupHsTokenType Range
ran SplitResult
ranSplit (NodeInfo Set NodeAnnotation
_ [a]
_ NodeIdentifiers a
bd) =
        case (Maybe HsSemanticTokenType
maybeTokenType, SplitResult
ranSplit) of
            (Maybe HsSemanticTokenType
Nothing, SplitResult
_) -> DList (Range, HsSemanticTokenType)
-> Tokenizer m (DList (Range, HsSemanticTokenType))
forall a. a -> StateT PTokenState m a
forall (m :: * -> *) a. Monad m => a -> m a
return DList (Range, HsSemanticTokenType)
forall a. Monoid a => a
mempty
            (Just HsSemanticTokenType
TModule, SplitResult
_) -> DList (Range, HsSemanticTokenType)
-> Tokenizer m (DList (Range, HsSemanticTokenType))
forall a. a -> StateT PTokenState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DList (Range, HsSemanticTokenType)
 -> Tokenizer m (DList (Range, HsSemanticTokenType)))
-> DList (Range, HsSemanticTokenType)
-> Tokenizer m (DList (Range, HsSemanticTokenType))
forall a b. (a -> b) -> a -> b
$ (Range, HsSemanticTokenType) -> DList (Range, HsSemanticTokenType)
forall a. a -> DList a
DL.singleton (Range
ran, HsSemanticTokenType
TModule)
            (Just HsSemanticTokenType
tokenType, NoSplit (Text
_, Range
tokenRan)) -> DList (Range, HsSemanticTokenType)
-> Tokenizer m (DList (Range, HsSemanticTokenType))
forall a. a -> StateT PTokenState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DList (Range, HsSemanticTokenType)
 -> Tokenizer m (DList (Range, HsSemanticTokenType)))
-> DList (Range, HsSemanticTokenType)
-> Tokenizer m (DList (Range, HsSemanticTokenType))
forall a b. (a -> b) -> a -> b
$ (Range, HsSemanticTokenType) -> DList (Range, HsSemanticTokenType)
forall a. a -> DList a
DL.singleton (Range
tokenRan, HsSemanticTokenType
tokenType)
            (Just HsSemanticTokenType
tokenType, Split (Text
_, Range
ranPrefix, Range
tokenRan)) -> DList (Range, HsSemanticTokenType)
-> Tokenizer m (DList (Range, HsSemanticTokenType))
forall a. a -> StateT PTokenState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DList (Range, HsSemanticTokenType)
 -> Tokenizer m (DList (Range, HsSemanticTokenType)))
-> DList (Range, HsSemanticTokenType)
-> Tokenizer m (DList (Range, HsSemanticTokenType))
forall a b. (a -> b) -> a -> b
$ RangeSemanticTokenTypeList -> DList (Range, HsSemanticTokenType)
forall a. [a] -> DList a
DL.fromList [(Range
ranPrefix, HsSemanticTokenType
TModule),(Range
tokenRan, HsSemanticTokenType
tokenType)]
        where maybeTokenType :: Maybe HsSemanticTokenType
maybeTokenType = HsSemanticLookup -> [Identifier] -> Maybe HsSemanticTokenType
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (HsSemanticLookup -> SplitResult -> HsSemanticLookup
getIdentifier HsSemanticLookup
lookupHsTokenType SplitResult
ranSplit) (NodeIdentifiers a -> [Identifier]
forall k a. Map k a -> [k]
M.keys NodeIdentifiers a
bd)

    getIdentifier :: HsSemanticLookup -> SplitResult -> Identifier -> Maybe HsSemanticTokenType
    getIdentifier :: HsSemanticLookup -> SplitResult -> HsSemanticLookup
getIdentifier HsSemanticLookup
lookupHsTokenType SplitResult
ranSplit Identifier
idt = do
      case Identifier
idt of
        Left ModuleName
_moduleName -> HsSemanticTokenType -> Maybe HsSemanticTokenType
forall a. a -> Maybe a
Just HsSemanticTokenType
TModule
        Right Name
name -> do
          Text
occStr <- String -> Text
T.pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case (OccName -> String
occNameString (OccName -> String) -> (Name -> OccName) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName) Name
name of
            -- the generated selector name with {-# LANGUAGE DuplicateRecordFields #-}
            Char
'$' : Char
's' : Char
'e' : Char
'l' : Char
':' : String
xs -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') String
xs
            -- other generated names that should not be visible
            Char
'$' : Char
c : String
_ | Char -> Bool
isAlphaNum Char
c       -> Maybe String
forall a. Maybe a
Nothing
            Char
c : Char
':' : String
_ | Char -> Bool
isAlphaNum Char
c       -> Maybe String
forall a. Maybe a
Nothing
            String
ns                               -> String -> Maybe String
forall a. a -> Maybe a
Just String
ns
          Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ SplitResult -> Text
getSplitTokenText SplitResult
ranSplit Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
occStr
          HsSemanticLookup
lookupHsTokenType Identifier
idt


focusTokenAt ::
  -- | leaf node we want to focus on
  HieAST a ->
  -- | (token, remains)
  Tokenizer Maybe (Range, Text)
focusTokenAt :: forall a. HieAST a -> Tokenizer Maybe (Range, Text)
focusTokenAt HieAST a
leaf = do
  PTokenState{Position
cursor :: PTokenState -> Position
cursor :: Position
cursor, Rope
rope :: PTokenState -> Rope
rope :: Rope
rope, UInt
columnsInUtf16 :: PTokenState -> UInt
columnsInUtf16 :: UInt
columnsInUtf16} <- StateT PTokenState Maybe PTokenState
forall s (m :: * -> *). MonadState s m => m s
get
  let span :: Span
span = HieAST a -> Span
forall a. HieAST a -> Span
nodeSpan HieAST a
leaf
  let (Position
tokenStartPos, Position
tokenEndPos) = Span -> (Position, Position)
srcSpanCharPositions Span
span
  -- tokenStartOff: the offset position of the token start position to the cursor position
  Position
tokenStartOff <- Maybe Position -> StateT PTokenState Maybe Position
forall (m :: * -> *) a. Monad m => m a -> StateT PTokenState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe Position -> StateT PTokenState Maybe Position)
-> Maybe Position -> StateT PTokenState Maybe Position
forall a b. (a -> b) -> a -> b
$ Position
tokenStartPos Position -> Position -> Maybe Position
`sub` Position
cursor
  -- tokenOff: the offset position of the token end position to the token start position
  Position
tokenOff <- Maybe Position -> StateT PTokenState Maybe Position
forall (m :: * -> *) a. Monad m => m a -> StateT PTokenState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe Position -> StateT PTokenState Maybe Position)
-> Maybe Position -> StateT PTokenState Maybe Position
forall a b. (a -> b) -> a -> b
$ Position
tokenEndPos Position -> Position -> Maybe Position
`sub` Position
tokenStartPos
  (Text
gap, Rope
tokenStartRope) <- Maybe (Text, Rope) -> StateT PTokenState Maybe (Text, Rope)
forall (m :: * -> *) a. Monad m => m a -> StateT PTokenState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe (Text, Rope) -> StateT PTokenState Maybe (Text, Rope))
-> Maybe (Text, Rope) -> StateT PTokenState Maybe (Text, Rope)
forall a b. (a -> b) -> a -> b
$ Position -> Rope -> Maybe (Text, Rope)
charSplitAtPositionMaybe Position
tokenStartOff Rope
rope
  (Text
token, Rope
remains) <- Maybe (Text, Rope) -> StateT PTokenState Maybe (Text, Rope)
forall (m :: * -> *) a. Monad m => m a -> StateT PTokenState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe (Text, Rope) -> StateT PTokenState Maybe (Text, Rope))
-> Maybe (Text, Rope) -> StateT PTokenState Maybe (Text, Rope)
forall a b. (a -> b) -> a -> b
$ Position -> Rope -> Maybe (Text, Rope)
charSplitAtPositionMaybe Position
tokenOff Rope
tokenStartRope
  -- ncs: token start column in utf16
  let ncs :: UInt
ncs = UInt -> Text -> UInt
newColumn UInt
columnsInUtf16 Text
gap
  -- nce: token end column in utf16
  let nce :: UInt
nce = UInt -> Text -> UInt
newColumn UInt
ncs Text
token
  -- compute the new range for utf16, tuning the columns is enough
  let ran :: Range
ran = UInt -> UInt -> CodePointRange -> Range
codePointRangeToRangeWith UInt
ncs UInt
nce (CodePointRange -> Range) -> CodePointRange -> Range
forall a b. (a -> b) -> a -> b
$ Span -> CodePointRange
realSrcSpanToCodePointRange Span
span
  (PTokenState -> PTokenState) -> StateT PTokenState Maybe ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((PTokenState -> PTokenState) -> StateT PTokenState Maybe ())
-> (PTokenState -> PTokenState) -> StateT PTokenState Maybe ()
forall a b. (a -> b) -> a -> b
$ \PTokenState
s -> PTokenState
s {columnsInUtf16 = nce, rope = remains, cursor = tokenEndPos}
  (Range, Text) -> Tokenizer Maybe (Range, Text)
forall a. a -> StateT PTokenState Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Range
ran, Text
token)
  where
    srcSpanCharPositions :: RealSrcSpan -> (Char.Position, Char.Position)
    srcSpanCharPositions :: Span -> (Position, Position)
srcSpanCharPositions Span
real =
        ( RealSrcLoc -> Position
realSrcLocRopePosition (RealSrcLoc -> Position) -> RealSrcLoc -> Position
forall a b. (a -> b) -> a -> b
$ Span -> RealSrcLoc
realSrcSpanStart Span
real,
          RealSrcLoc -> Position
realSrcLocRopePosition (RealSrcLoc -> Position) -> RealSrcLoc -> Position
forall a b. (a -> b) -> a -> b
$ Span -> RealSrcLoc
realSrcSpanEnd Span
real
        )
    charSplitAtPositionMaybe :: Char.Position -> Rope -> Maybe (Text, Rope)
    charSplitAtPositionMaybe :: Position -> Rope -> Maybe (Text, Rope)
charSplitAtPositionMaybe Position
tokenOff Rope
rpe = do
      let (Rope
prefix, Rope
suffix) = Position -> Rope -> (Rope, Rope)
Rope.charSplitAtPosition Position
tokenOff Rope
rpe
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Rope -> Position
Rope.charLengthAsPosition Rope
prefix Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
tokenOff
      (Text, Rope) -> Maybe (Text, Rope)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Rope -> Text
Rope.toText Rope
prefix, Rope
suffix)
    sub :: Char.Position -> Char.Position -> Maybe Char.Position
    sub :: Position -> Position -> Maybe Position
sub (Char.Position Word
l1 Word
c1) (Char.Position Word
l2 Word
c2)
      | Word
l1 Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
l2 Bool -> Bool -> Bool
&& Word
c1 Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
>= Word
c2 = Position -> Maybe Position
forall a. a -> Maybe a
Just (Position -> Maybe Position) -> Position -> Maybe Position
forall a b. (a -> b) -> a -> b
$ Word -> Word -> Position
Char.Position Word
0 (Word
c1 Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
c2)
      | Word
l1 Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
l2 = Position -> Maybe Position
forall a. a -> Maybe a
Just (Position -> Maybe Position) -> Position -> Maybe Position
forall a b. (a -> b) -> a -> b
$ Word -> Word -> Position
Char.Position (Word
l1 Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
l2) Word
c1
      | Bool
otherwise = Maybe Position
forall a. Maybe a
Nothing
    realSrcLocRopePosition :: RealSrcLoc -> Char.Position
    realSrcLocRopePosition :: RealSrcLoc -> Position
realSrcLocRopePosition RealSrcLoc
real = Word -> Word -> Position
Char.Position (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ RealSrcLoc -> Int
srcLocLine RealSrcLoc
real Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ RealSrcLoc -> Int
srcLocCol RealSrcLoc
real Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    -- | newColumn
    -- rope do not treat single \n in our favor
    -- for example, the row length of "123\n" and "123" are both 1
    -- we are forced to use text to compute new column
    newColumn :: UInt -> Text -> UInt
    newColumn :: UInt -> Text -> UInt
newColumn UInt
n Text
rp = case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
"\n" Text
rp of
      (Text
"", Text
nEnd) -> UInt
n UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ Text -> UInt
forall i. Integral i => Text -> i
utf16Length Text
nEnd
      (Text
_, Text
nEnd)  -> Text -> UInt
forall i. Integral i => Text -> i
utf16Length Text
nEnd
    codePointRangeToRangeWith :: UInt -> UInt -> CodePointRange -> Range
    codePointRangeToRangeWith :: UInt -> UInt -> CodePointRange -> Range
codePointRangeToRangeWith UInt
newStartCol UInt
newEndCol (CodePointRange (CodePointPosition UInt
startLine UInt
_) (CodePointPosition UInt
endLine UInt
_)) =
      Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
startLine UInt
newStartCol) (UInt -> UInt -> Position
Position UInt
endLine UInt
newEndCol)

-- | splitRangeByText
-- split a qualified identifier into module name and identifier and/or strip the (), ``
-- for `ModuleA.b`, break it into `ModuleA.` and `b`
-- for `(b)`, strip `()`, and get `b`
-- for `(ModuleA.b)`, strip `()` and break it into `ModuleA.` and `b`
splitRangeByText :: Text -> Range -> Maybe SplitResult
splitRangeByText :: Text -> Range -> Maybe SplitResult
splitRangeByText Text
tk Range
ran = do
  let (Range
ran', Text
tk') = case Text -> Maybe (Char, Text)
T.uncons Text
tk of
        Just (Char
'(', Text
xs) -> (Range -> Range
subOneRange Range
ran, (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')') Text
xs)
        Just (Char
'`', Text
xs) -> (Range -> Range
subOneRange Range
ran, (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'`') Text
xs)
        Maybe (Char, Text)
_              -> (Range
ran, Text
tk)
  let (Text
prefix, Text
tk'') = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
"." Text
tk'
  Text -> Position -> Range -> Maybe SplitResult
splitRange Text
tk'' (Position -> Position
utf16PositionPosition (Position -> Position) -> Position -> Position
forall a b. (a -> b) -> a -> b
$ Rope -> Position
Rope.utf16LengthAsPosition (Rope -> Position) -> Rope -> Position
forall a b. (a -> b) -> a -> b
$ Text -> Rope
Rope.fromText Text
prefix) Range
ran'
  where
    splitRange :: Text -> Position -> Range -> Maybe SplitResult
    splitRange :: Text -> Position -> Range -> Maybe SplitResult
splitRange Text
tx (Position UInt
l UInt
c) r :: Range
r@(Range (Position UInt
l1 UInt
c1) (Position UInt
l2 UInt
c2))
      | UInt
l1 UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
l UInt -> UInt -> Bool
forall a. Ord a => a -> a -> Bool
> UInt
l2 Bool -> Bool -> Bool
|| (UInt
l1 UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
l UInt -> UInt -> Bool
forall a. Eq a => a -> a -> Bool
== UInt
l2 Bool -> Bool -> Bool
&& UInt
c UInt -> UInt -> Bool
forall a. Ord a => a -> a -> Bool
> UInt
c2) = Maybe SplitResult
forall a. Maybe a
Nothing -- out of range
      | UInt
lUInt -> UInt -> Bool
forall a. Eq a => a -> a -> Bool
==UInt
0 Bool -> Bool -> Bool
&& UInt
cUInt -> UInt -> Bool
forall a. Eq a => a -> a -> Bool
==UInt
0 = SplitResult -> Maybe SplitResult
forall a. a -> Maybe a
Just (SplitResult -> Maybe SplitResult)
-> SplitResult -> Maybe SplitResult
forall a b. (a -> b) -> a -> b
$ (Text, Range) -> SplitResult
NoSplit (Text
tx, Range
r)
      | Bool
otherwise = let c' :: UInt
c' = if UInt
l UInt -> UInt -> Bool
forall a. Ord a => a -> a -> Bool
<= UInt
0 then UInt
c1UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+UInt
c else UInt
c
                    in SplitResult -> Maybe SplitResult
forall a. a -> Maybe a
Just (SplitResult -> Maybe SplitResult)
-> SplitResult -> Maybe SplitResult
forall a b. (a -> b) -> a -> b
$ (Text, Range, Range) -> SplitResult
Split (Text
tx, UInt -> UInt -> UInt -> UInt -> Range
mkRange UInt
l1 UInt
c1 (UInt
l1 UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
l) UInt
c', UInt -> UInt -> UInt -> UInt -> Range
mkRange (UInt
l1 UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
l) UInt
c' UInt
l2 UInt
c2)
    subOneRange :: Range -> Range
    subOneRange :: Range -> Range
subOneRange (Range (Position UInt
l1 UInt
c1) (Position UInt
l2 UInt
c2)) = Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
l1 (UInt
c1 UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
1)) (UInt -> UInt -> Position
Position UInt
l2 (UInt
c2 UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
- UInt
1))
    utf16PositionPosition :: Utf16.Position -> Position
    utf16PositionPosition :: Position -> Position
utf16PositionPosition (Utf16.Position Word
l Word
c) = UInt -> UInt -> Position
Position (Word -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
l) (Word -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
c)


utf16Length :: Integral i => Text -> i
utf16Length :: forall i. Integral i => Text -> i
utf16Length = Word -> i
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> i) -> (Text -> Word) -> Text -> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rope -> Word
Utf16.length (Rope -> Word) -> (Text -> Rope) -> Text -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Rope
Utf16.fromText