From 1532d8af54d33a991f70269e32c3a90a707f2436 Mon Sep 17 00:00:00 2001 From: Olle Fredriksson Date: Tue, 23 Jan 2024 20:48:01 +0100 Subject: [PATCH] wip --- src/Error/Hydrated.hs | 37 ++++++------- src/LanguageServer.hs | 19 ++++--- src/LanguageServer/CodeLens.hs | 3 +- src/LanguageServer/Completion.hs | 21 ++++---- src/LanguageServer/CursorAction.hs | 21 ++++---- src/LanguageServer/DocumentHighlights.hs | 21 ++++---- src/LanguageServer/GoToDefinition.hs | 11 ++-- src/LanguageServer/Hover.hs | 5 +- src/LanguageServer/LineColumns.hs | 14 ++--- src/LanguageServer/References.hs | 21 ++++---- src/Lexer.hs | 2 +- src/Occurrences/Intervals.hs | 18 +++---- src/Position.hs | 31 ----------- src/Span.hs | 26 --------- src/UTF16.hs | 67 ++++++++++++++++++++++++ stack.yaml | 1 + 16 files changed, 165 insertions(+), 153 deletions(-) create mode 100644 src/UTF16.hs diff --git a/src/Error/Hydrated.hs b/src/Error/Hydrated.hs index b0ef89e..cc2311b 100644 --- a/src/Error/Hydrated.hs +++ b/src/Error/Hydrated.hs @@ -27,10 +27,11 @@ import qualified Query import Rock import qualified Span import qualified System.Directory as Directory +import qualified UTF16 data Hydrated = Hydrated { filePath :: FilePath - , lineColumn :: !Span.LineColumn + , lineColumn :: !UTF16.LineColumns , lineText :: !Text , error :: !Error } @@ -53,10 +54,10 @@ headingAndBody error = (filePath, maybeOldSpan) <- fetch $ Query.DefinitionPosition definitionKind name text <- fetch $ Query.FileText filePath let (lineColumn, _) = - Position.lineColumn (fromMaybe 0 maybeOldSpan) text + UTF16.lineColumn (fromMaybe 0 maybeOldSpan) text pure ( "Duplicate name:" <+> Doc.pretty name - , Doc.pretty name <+> "has already been defined at" <+> Doc.pretty (Span.LineColumns lineColumn lineColumn) <> "." + , Doc.pretty name <+> "has already been defined at" <+> Doc.pretty (UTF16.LineColumns lineColumn lineColumn) <> "." ) Error.ImportNotFound _ import_ -> let prettyModule = Doc.pretty import_.module_ @@ -111,7 +112,7 @@ headingAndBody error = (filePath, maybeDefSpan) <- fetch $ Query.DefinitionPosition definitionKind definitionName text <- fetch $ Query.FileText filePath let (previousLineColumn, _) = - Span.lineColumn (Span.absoluteFrom (fromMaybe 0 maybeDefSpan) previousSpan) text + UTF16.lineColumns (Span.absoluteFrom (fromMaybe 0 maybeDefSpan) previousSpan) text pure ( "Duplicate name in let block:" <+> Doc.pretty name , Doc.pretty name <+> "has already been defined at" <+> Doc.pretty previousLineColumn <> "." @@ -244,17 +245,17 @@ pretty h = do <> Doc.pretty h.lineColumn <> ":" <+> heading - <> line - <> line - <> body - <> line - <> line - <> spannedLine + <> line + <> line + <> body + <> line + <> line + <> spannedLine where spannedLine = - let Span.LineColumns - (Position.LineColumn startLineNumber startColumnNumber) - (Position.LineColumn endLineNumber endColumnNumber) = h.lineColumn + let UTF16.LineColumns + (UTF16.LineColumn startLineNumber startColumnNumber) + (UTF16.LineColumn endLineNumber endColumnNumber) = h.lineColumn lineNumberText = show (startLineNumber + 1) @@ -266,7 +267,7 @@ pretty h = do | startLineNumber == endLineNumber = (endColumnNumber - startColumnNumber, mempty) | otherwise = - (Text.lengthWord8 h.lineText - startColumnNumber, "...") + (UTF16.length h.lineText - startColumnNumber, "...") in Doc.pretty (Text.replicate (lineNumberTextLength + 1) " ") <> "| " <> line @@ -276,7 +277,7 @@ pretty h = do <> line <> Doc.pretty (Text.replicate (lineNumberTextLength + 1) " ") <> "| " - <> Doc.pretty (Text.replicate startColumnNumber " " <> "^" <> Text.replicate (spanLength - 1) "~" <> spanEnding) + <> Doc.pretty (Text.replicate (UTF16.toInt startColumnNumber) " " <> "^" <> Text.replicate (UTF16.toInt spanLength - 1) "~" <> spanEnding) fromError :: Error -> Task Query Hydrated fromError err = do @@ -306,9 +307,9 @@ fromError err = do Left Error.Parsing.EOF -> do let eofPos = Position.Absolute $ Text.lengthWord8 text - Span.lineColumn (Span.Absolute eofPos eofPos) text + UTF16.lineColumns (Span.Absolute eofPos eofPos) text Right span -> - Span.lineColumn span text + UTF16.lineColumns span text pure Hydrated { filePath = filePath @@ -322,7 +323,7 @@ fromError err = do lineNumber :: Hydrated -> Int lineNumber err = l where - Span.LineColumns (Position.LineColumn l _) _ = err.lineColumn + UTF16.LineColumns (UTF16.LineColumn l _) _ = err.lineColumn prettyPrettyableTerm :: (MonadFetch Query m) => Int -> Error.PrettyableTerm -> m (Doc ann) prettyPrettyableTerm prec (Error.PrettyableTerm moduleName_ names term) = do diff --git a/src/LanguageServer.hs b/src/LanguageServer.hs index 5d494f4..0dc4cb1 100644 --- a/src/LanguageServer.hs +++ b/src/LanguageServer.hs @@ -36,16 +36,15 @@ import qualified LanguageServer.GoToDefinition as GoToDefinition import qualified LanguageServer.Hover as Hover import qualified LanguageServer.References as References import qualified Occurrences.Intervals -import qualified Position import Prettyprinter (Doc) import qualified Prettyprinter as Doc import qualified Project import Protolude hiding (State, state) import Query (Query) import Rock (Task) -import qualified Span import qualified System.Directory as Directory import qualified System.FSNotify as FSNotify +import qualified UTF16 run :: IO () run = do @@ -469,30 +468,30 @@ errorToDiagnostic err doc = , _data_ = Nothing } -spanToLocation :: FilePath -> Span.LineColumn -> LSP.Location +spanToLocation :: FilePath -> UTF16.LineColumns -> LSP.Location spanToLocation filePath span = LSP.Location { _uri = LSP.filePathToUri filePath , _range = spanToRange span } -spanToRange :: Span.LineColumn -> LSP.Range -spanToRange (Span.LineColumns start end) = +spanToRange :: UTF16.LineColumns -> LSP.Range +spanToRange (UTF16.LineColumns start end) = LSP.Range { _start = positionToPosition start , _end = positionToPosition end } -positionToPosition :: Position.LineColumn -> LSP.Position -positionToPosition (Position.LineColumn line column) = +positionToPosition :: UTF16.LineColumn -> LSP.Position +positionToPosition (UTF16.LineColumn line column) = LSP.Position { _line = fromIntegral line - , _character = fromIntegral column + , _character = fromIntegral $ UTF16.toInt column } -positionFromPosition :: LSP.Position -> Position.LineColumn +positionFromPosition :: LSP.Position -> UTF16.LineColumn positionFromPosition (LSP.Position line column) = - Position.LineColumn (fromIntegral line) (fromIntegral column) + UTF16.LineColumn (fromIntegral line) (UTF16.CodeUnits $ fromIntegral column) uriToFilePath :: LSP.Uri -> FilePath uriToFilePath = diff --git a/src/LanguageServer/CodeLens.hs b/src/LanguageServer/CodeLens.hs index a805720..eb9a867 100644 --- a/src/LanguageServer/CodeLens.hs +++ b/src/LanguageServer/CodeLens.hs @@ -19,8 +19,9 @@ import Rock import qualified Scope import qualified Span import qualified Surface.Syntax as Surface +import qualified UTF16 -codeLens :: FilePath -> Task Query [(Span.LineColumn, Doc ann)] +codeLens :: FilePath -> Task Query [(UTF16.LineColumns, Doc ann)] codeLens filePath = runM $ do (moduleName, _, defs) <- fetch $ Query.ParsedFile filePath diff --git a/src/LanguageServer/Completion.hs b/src/LanguageServer/Completion.hs index 959510e..c18d08d 100644 --- a/src/LanguageServer/Completion.hs +++ b/src/LanguageServer/Completion.hs @@ -26,7 +26,6 @@ import Monad import Name (Name (Name)) import qualified Name import Plicity -import qualified Position import Prettyprinter ((<+>)) import Protolude hiding (catch, evaluate, moduleName) import Query (Query) @@ -34,11 +33,13 @@ import qualified Query import qualified Query.Mapped as Mapped import Rock import qualified Scope +import qualified UTF16 import Var (Var) -complete :: FilePath -> Position.LineColumn -> Task Query (Maybe [LSP.CompletionItem]) -complete filePath (Position.LineColumn line column) = - CursorAction.cursorAction filePath (Position.LineColumn line $ max 0 $ column - 1) \item _ -> +complete :: FilePath -> UTF16.LineColumn -> Task Query (Maybe [LSP.CompletionItem]) +complete filePath (UTF16.LineColumn line column) = + -- TODO needs to work on code points, not code units + CursorAction.cursorAction filePath (UTF16.LineColumn line $ max 0 $ column - 1) \item _ -> case item of CursorAction.Import _ -> empty @@ -72,9 +73,10 @@ complete filePath (Position.LineColumn line column) = , _data_ = Nothing } -questionMark :: FilePath -> Position.LineColumn -> Task Query (Maybe [LSP.CompletionItem]) -questionMark filePath (Position.LineColumn line column) = - CursorAction.cursorAction filePath (Position.LineColumn line $ max 0 $ column - 1) \item _ -> +questionMark :: FilePath -> UTF16.LineColumn -> Task Query (Maybe [LSP.CompletionItem]) +questionMark filePath (UTF16.LineColumn line column) = + -- TODO needs to work on code points, not code units + CursorAction.cursorAction filePath (UTF16.LineColumn line $ max 0 $ column - 1) \item _ -> case item of CursorAction.Import _ -> empty @@ -140,12 +142,13 @@ questionMark filePath (Position.LineColumn line column) = { _start = LSP.Position { _line = fromIntegral line - , _character = fromIntegral $ column - 1 + , -- TODO needs to work with code points + _character = fromIntegral $ UTF16.toInt $ column - 1 } , _end = LSP.Position { _line = fromIntegral line - , _character = fromIntegral column + , _character = fromIntegral $ UTF16.toInt column } } , _newText = diff --git a/src/LanguageServer/CursorAction.hs b/src/LanguageServer/CursorAction.hs index fc9d428..6f706b2 100644 --- a/src/LanguageServer/CursorAction.hs +++ b/src/LanguageServer/CursorAction.hs @@ -46,9 +46,10 @@ import qualified Scope import qualified Span import Telescope (Telescope) import qualified Telescope +import qualified UTF16 import Var (Var) -type Callback a = ItemUnderCursor -> Span.LineColumn -> MaybeT M a +type Callback a = ItemUnderCursor -> UTF16.LineColumns -> MaybeT M a data ItemUnderCursor where Term @@ -70,22 +71,20 @@ data ItemContext cursorAction :: forall a . FilePath - -> Position.LineColumn + -> UTF16.LineColumn -> Callback a -> Task Query (Maybe a) -cursorAction filePath (Position.LineColumn line column) k = +cursorAction filePath (UTF16.LineColumn line column) k = runM $ runMaybeT $ do (moduleName, moduleHeader, _) <- fetch $ Query.ParsedFile filePath spans <- fetch $ Query.ModuleSpanMap moduleName - contents <- fetch $ Query.FileText filePath - let - -- TODO use the rope that we get from the LSP library instead - pos = - Position.Absolute $ - case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral column)) $ Rope.fromText contents of - Nothing -> 0 - Just (rope, _) -> fromIntegral $ Rope.length rope + contents <- fetch $ Query.FileRope filePath + let pos = + Position.Absolute $ + case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral $ UTF16.toInt column)) contents of + Nothing -> 0 + Just (rope, _) -> fromIntegral $ Rope.utf8Length rope toLineColumns <- LineColumns.fromAbsolute moduleName asum $ diff --git a/src/LanguageServer/DocumentHighlights.hs b/src/LanguageServer/DocumentHighlights.hs index aa201a5..b529485 100644 --- a/src/LanguageServer/DocumentHighlights.hs +++ b/src/LanguageServer/DocumentHighlights.hs @@ -14,22 +14,21 @@ import Query (Query) import qualified Query import Rock import qualified Span +import qualified UTF16 highlights :: FilePath - -> Position.LineColumn - -> Task Query [Span.LineColumn] -highlights filePath (Position.LineColumn line column) = do + -> UTF16.LineColumn + -> Task Query [UTF16.LineColumns] +highlights filePath (UTF16.LineColumn line column) = do (moduleName, _, _) <- fetch $ Query.ParsedFile filePath spans <- fetch $ Query.ModuleSpanMap moduleName - contents <- fetch $ Query.FileText filePath - let - -- TODO use the rope that we get from the LSP library instead - pos = - Position.Absolute $ - case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral column)) $ Rope.fromText contents of - Nothing -> 0 - Just (rope, _) -> fromIntegral $ Rope.length rope + contents <- fetch $ Query.FileRope filePath + let pos = + Position.Absolute $ + case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral $ UTF16.toInt column)) contents of + Nothing -> 0 + Just (rope, _) -> fromIntegral $ Rope.utf8Length rope toLineColumns <- LineColumns.fromAbsolute moduleName diff --git a/src/LanguageServer/GoToDefinition.hs b/src/LanguageServer/GoToDefinition.hs index ec0fc91..db77772 100644 --- a/src/LanguageServer/GoToDefinition.hs +++ b/src/LanguageServer/GoToDefinition.hs @@ -20,17 +20,18 @@ import qualified Query import Rock import qualified Scope import qualified Span +import qualified UTF16 -goToDefinition :: FilePath -> Position.LineColumn -> Task Query (Maybe (FilePath, Span.LineColumn)) -goToDefinition filePath (Position.LineColumn line column) = do +goToDefinition :: FilePath -> UTF16.LineColumn -> Task Query (Maybe (FilePath, UTF16.LineColumns)) +goToDefinition filePath (UTF16.LineColumn line column) = do (moduleName, moduleHeader, _) <- fetch $ Query.ParsedFile filePath spans <- fetch $ Query.ModuleSpanMap moduleName rope <- fetch $ Query.FileRope filePath let pos = Position.Absolute $ - case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral column)) rope of + case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral $ UTF16.toInt column)) rope of Nothing -> 0 - Just (rope', _) -> fromIntegral $ Rope.length rope' + Just (rope', _) -> fromIntegral $ Rope.utf8Length rope' runMaybeT $ asum $ @@ -44,7 +45,7 @@ goToDefinition filePath (Position.LineColumn line column) = do Nothing -> empty Just definingFile -> - pure (definingFile, Span.LineColumns (Position.LineColumn 0 0) (Position.LineColumn 0 0)) + pure (definingFile, UTF16.LineColumns (UTF16.LineColumn 0 0) (UTF16.LineColumn 0 0)) ) <> foreach (HashMap.toList spans) diff --git a/src/LanguageServer/Hover.hs b/src/LanguageServer/Hover.hs index fd4d6f6..39da1db 100644 --- a/src/LanguageServer/Hover.hs +++ b/src/LanguageServer/Hover.hs @@ -9,14 +9,13 @@ import qualified Elaboration import qualified Elaboration.Context as Context import qualified Error.Hydrated as Error import qualified LanguageServer.CursorAction as CursorAction -import qualified Position import Prettyprinter (Doc, (<+>)) import Protolude hiding (evaluate, moduleName) import Query (Query) import Rock -import qualified Span +import qualified UTF16 -hover :: FilePath -> Position.LineColumn -> Task Query (Maybe (Span.LineColumn, Doc ann)) +hover :: FilePath -> UTF16.LineColumn -> Task Query (Maybe (UTF16.LineColumns, Doc ann)) hover filePath pos = CursorAction.cursorAction filePath pos \item lineColumn -> case item of diff --git a/src/LanguageServer/LineColumns.hs b/src/LanguageServer/LineColumns.hs index 9fb7eee..52ef8c4 100644 --- a/src/LanguageServer/LineColumns.hs +++ b/src/LanguageServer/LineColumns.hs @@ -10,31 +10,31 @@ import Query (Query) import qualified Query import Rock import qualified Scope -import Span (LineColumn (LineColumns)) import qualified Span +import UTF16 -fromDefinitionName :: (MonadFetch Query m) => Scope.DefinitionKind -> Name.Qualified -> m (Maybe (Span.Relative -> Span.LineColumn)) +fromDefinitionName :: (MonadFetch Query m) => Scope.DefinitionKind -> Name.Qualified -> m (Maybe (Span.Relative -> UTF16.LineColumns)) fromDefinitionName definitionKind name@(Name.Qualified moduleName _) = do (_, maybeAbsolutePosition) <- fetch $ Query.DefinitionPosition definitionKind name toLineColumns <- fromAbsolute moduleName pure $ fmap ((toLineColumns .) . Span.absoluteFrom) maybeAbsolutePosition -fromAbsolute :: (MonadFetch Query m) => Name.Module -> m (Span.Absolute -> Span.LineColumn) +fromAbsolute :: (MonadFetch Query m) => Name.Module -> m (Span.Absolute -> UTF16.LineColumns) fromAbsolute moduleName = do maybeFilePath <- fetch $ Query.ModuleFile moduleName case maybeFilePath of Nothing -> - pure $ const $ Span.LineColumns (Position.LineColumn 0 0) (Position.LineColumn 0 0) + pure $ const $ UTF16.LineColumns (UTF16.LineColumn 0 0) (UTF16.LineColumn 0 0) Just filePath -> do rope <- fetch $ Query.FileRope filePath let toLineColumn (Position.Absolute i) = case Rope.splitAt (fromIntegral i) rope of - Nothing -> Position.LineColumn 0 0 + Nothing -> UTF16.LineColumn 0 0 Just (rope', _) -> let Rope.Position row column = Rope.lengthAsPosition rope' - in Position.LineColumn (fromIntegral row) (fromIntegral column) + in UTF16.LineColumn (fromIntegral row) (fromIntegral column) toLineColumns (Span.Absolute start end) = - Span.LineColumns (toLineColumn start) (toLineColumn end) + UTF16.LineColumns (toLineColumn start) (toLineColumn end) return toLineColumns diff --git a/src/LanguageServer/References.hs b/src/LanguageServer/References.hs index a9dec05..b3be53d 100644 --- a/src/LanguageServer/References.hs +++ b/src/LanguageServer/References.hs @@ -18,12 +18,13 @@ import Query (Query) import qualified Query import Rock import qualified Span +import qualified UTF16 references :: FilePath - -> Position.LineColumn - -> Task Query [(Intervals.Item, [(FilePath, Span.LineColumn)])] -references filePath (Position.LineColumn line column) = do + -> UTF16.LineColumn + -> Task Query [(Intervals.Item, [(FilePath, UTF16.LineColumns)])] +references filePath (UTF16.LineColumn line column) = do (originalModuleName, _, _) <- fetch $ Query.ParsedFile filePath let itemSpans definingModule item = do let mightUseDefiningModule moduleName header = @@ -46,14 +47,12 @@ references filePath (Position.LineColumn line column) = do pure $ (,) inputFile . toLineColumns . Span.absoluteFrom defPos <$> Intervals.itemSpans item occurrenceIntervals else pure mempty - contents <- fetch $ Query.FileText filePath - let - -- TODO use the rope that we get from the LSP library instead - pos = - Position.Absolute $ - case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral column)) $ Rope.fromText contents of - Nothing -> 0 - Just (rope, _) -> fromIntegral $ Rope.length rope + contents <- fetch $ Query.FileRope filePath + let pos = + Position.Absolute $ + case Rope.splitAtPosition (Rope.Position (fromIntegral line) (fromIntegral $ UTF16.toInt column)) contents of + Nothing -> 0 + Just (rope, _) -> fromIntegral $ Rope.utf8Length rope toLineColumns <- LineColumns.fromAbsolute originalModuleName spans <- fetch $ Query.ModuleSpanMap originalModuleName fmap concat $ diff --git a/src/Lexer.hs b/src/Lexer.hs index 1bae966..4834d85 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -185,7 +185,7 @@ lex state@State {..} identifier position lineColumn state' _ | Just state' <- satisfy isASCIIOperator (\c -> Char.isSymbol c || Char.isPunctuation c) state -> - identifier position lineColumn state' + operator position lineColumn state' ------------------------------------------------------------------------- -- Error _ -> diff --git a/src/Occurrences/Intervals.hs b/src/Occurrences/Intervals.hs index ffc5911..dff303b 100644 --- a/src/Occurrences/Intervals.hs +++ b/src/Occurrences/Intervals.hs @@ -19,13 +19,13 @@ import qualified Data.HashSet as HashSet import Data.IntervalMap.FingerTree (IntervalMap) import qualified Data.IntervalMap.FingerTree as IntervalMap import qualified Data.List as List -import qualified Data.Text.Unsafe as Text import Literal (Literal) import qualified Name import Orphans () import qualified Position import Protolude import qualified Span +import qualified UTF16 import Var (Var) data Item @@ -136,19 +136,19 @@ varSpans var position intervals = do spanStart :: Span.Relative -> Position.Relative spanStart (Span.Relative s _) = s -nameSpan :: Item -> Span.LineColumn -> Span.LineColumn +nameSpan :: Item -> UTF16.LineColumns -> UTF16.LineColumns nameSpan item - span@(Span.LineColumns _ (Position.LineColumn endLine endColumn)) = + span@(UTF16.LineColumns _ (UTF16.LineColumn endLine endColumn)) = case item of Global (Name.Qualified _ (Name.Name name)) -> - Span.LineColumns - (Position.LineColumn endLine (endColumn - Text.lengthWord8 name)) - (Position.LineColumn endLine endColumn) + UTF16.LineColumns + (UTF16.LineColumn endLine (endColumn - UTF16.length name)) + (UTF16.LineColumn endLine endColumn) Con (Name.QualifiedConstructor _ (Name.Constructor name)) -> - Span.LineColumns - (Position.LineColumn endLine (endColumn - Text.lengthWord8 name)) - (Position.LineColumn endLine endColumn) + UTF16.LineColumns + (UTF16.LineColumn endLine (endColumn - UTF16.length name)) + (UTF16.LineColumn endLine endColumn) Lit _ -> span Var _ -> diff --git a/src/Position.hs b/src/Position.hs index 2ee6780..c28dd00 100644 --- a/src/Position.hs +++ b/src/Position.hs @@ -6,8 +6,6 @@ module Position where -import qualified Data.Text as Text -import qualified Data.Text.Unsafe as Text import Protolude newtype Absolute = Absolute Int @@ -35,32 +33,3 @@ addLine (LineColumn line _) = addColumns :: LineColumn -> Int -> LineColumn addColumns (LineColumn line column) delta = LineColumn line $ column + delta - -lineColumn :: Absolute -> Text -> (LineColumn, Text) -lineColumn (Absolute index) text = - let prefix = - Text.takeWord8 index text - - suffix = - Text.dropWord8 index text - - linePrefixLength = - Text.lengthWord8 $ Text.takeWhileEnd (/= '\n') prefix - - lineSuffixLength = - Text.lengthWord8 $ Text.takeWhile (/= '\n') suffix - - lineStart = - index - linePrefixLength - - lineLength = - linePrefixLength + lineSuffixLength - - line = - Text.takeWord8 lineLength $ - Text.dropWord8 lineStart text - in ( LineColumn - (Text.count "\n" prefix) - linePrefixLength - , line - ) diff --git a/src/Span.hs b/src/Span.hs index 0993fd3..88206b7 100644 --- a/src/Span.hs +++ b/src/Span.hs @@ -1,12 +1,10 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} module Span where import qualified Position -import Prettyprinter import Protolude data Absolute = Absolute !Position.Absolute !Position.Absolute @@ -37,27 +35,3 @@ relativeContains (Relative start end) pos = data LineColumn = LineColumns !Position.LineColumn !Position.LineColumn deriving (Show, Generic) - -lineColumn :: Absolute -> Text -> (LineColumn, Text) -lineColumn (Absolute start end) text = - let (startLineColumn, lineText) = - Position.lineColumn start text - in ( LineColumns - startLineColumn - (fst $ Position.lineColumn end text) - , lineText - ) - --- | Gives a summary (fileName:row:column) of the location -instance Pretty LineColumn where - pretty - ( LineColumns - start@(Position.LineColumn ((+ 1) -> startLine) ((+ 1) -> startColumn)) - end@(Position.LineColumn ((+ 1) -> endLine) ((+ 1) -> endColumn)) - ) - | start == end = - pretty startLine <> ":" <> pretty startColumn - | startLine == endLine = - pretty startLine <> ":" <> pretty startColumn <> "-" <> pretty endColumn - | otherwise = - pretty startLine <> ":" <> pretty startColumn <> "-" <> pretty endLine <> ":" <> pretty endColumn diff --git a/src/UTF16.hs b/src/UTF16.hs new file mode 100644 index 0000000..29e516d --- /dev/null +++ b/src/UTF16.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module UTF16 where + +import qualified Data.Text as Text +import qualified Data.Text.Unsafe as Text +import qualified Data.Text.Utf16.Lines as Utf16.Lines +import qualified Position +import Prettyprinter (Pretty (pretty)) +import Protolude hiding (length) +import qualified Span + +newtype CodeUnits = CodeUnits {toInt :: Int} + deriving (Eq, Ord, Show, Generic, NFData, Num) + +length :: Text -> CodeUnits +length = CodeUnits . fromIntegral . Utf16.Lines.length . Utf16.Lines.fromText + +data LineColumn = LineColumn !Int !CodeUnits + deriving (Eq, Ord, Show, Generic) + +data LineColumns = LineColumns !LineColumn !LineColumn + deriving (Show, Generic) + +lineColumn :: Position.Absolute -> Text -> (LineColumn, Text) +lineColumn (Position.Absolute index) text = + let prefix = Text.takeWord8 index text + suffix = Text.dropWord8 index text + linePrefix = Text.takeWhileEnd (/= '\n') prefix + linePrefixLength = Text.lengthWord8 linePrefix + linePrefixLength16 = length linePrefix + lineSuffixLength = Text.lengthWord8 $ Text.takeWhile (/= '\n') suffix + lineStart = index - linePrefixLength + lineLength = linePrefixLength + lineSuffixLength + line = Text.takeWord8 lineLength $ Text.dropWord8 lineStart text + in ( LineColumn + (Text.count "\n" prefix) + linePrefixLength16 + , line + ) + +lineColumns :: Span.Absolute -> Text -> (LineColumns, Text) +lineColumns (Span.Absolute start end) text = + let (startLineColumn, lineText) = + lineColumn start text + in ( LineColumns + startLineColumn + (fst $ lineColumn end text) + , lineText + ) + +-- | Gives a summary (fileName:row:column) of the location +instance Pretty LineColumns where + pretty + ( LineColumns + start@(LineColumn ((+ 1) -> startLine) (CodeUnits ((+ 1) -> startColumn))) + end@(LineColumn ((+ 1) -> endLine) (CodeUnits ((+ 1) -> endColumn))) + ) + | start == end = + pretty startLine <> ":" <> pretty startColumn + | startLine == endLine = + pretty startLine <> ":" <> pretty startColumn <> "-" <> pretty endColumn + | otherwise = + pretty startLine <> ":" <> pretty startColumn <> "-" <> pretty endLine <> ":" <> pretty endColumn diff --git a/stack.yaml b/stack.yaml index f804e5c..f53e8c3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,3 +7,4 @@ extra-deps: - git: https://github.com/fpco/ghc-prof-flamegraph.git commit: 8edd3b4806adeb25a4d55bed51c3afcc8e7a8e14 - enummapset-0.7.2.0 +- ../text-rope