-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE CPP #-}

-- | Types and functions for working with source code locations.
module Development.IDE.Types.Location
    ( Location(..)
    , noFilePath
    , noRange
    , Position(..)
    , showPosition
    , Range(..)
    , LSP.Uri(..)
    , LSP.NormalizedUri
    , LSP.toNormalizedUri
    , LSP.fromNormalizedUri
    , LSP.NormalizedFilePath
    , fromUri
    , emptyFilePath
    , emptyPathUri
    , toNormalizedFilePath'
    , LSP.fromNormalizedFilePath
    , filePathToUri'
    , uriToFilePath'
    , readSrcSpan
    ) where

import           Control.Applicative
import           Control.Monad
import           Data.Hashable                (Hashable (hash))
import           Data.Maybe                   (fromMaybe)
import           Data.String
import           Language.LSP.Protocol.Types  (Location (..), Position (..),
                                               Range (..))
import qualified Language.LSP.Protocol.Types  as LSP
import           Text.ParserCombinators.ReadP as ReadP

import           GHC.Data.FastString
import           GHC.Types.SrcLoc             as GHC

toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath
-- We want to keep empty paths instead of normalising them to "."
toNormalizedFilePath' :: [Char] -> NormalizedFilePath
toNormalizedFilePath' [Char]
"" = NormalizedFilePath
emptyFilePath
toNormalizedFilePath' [Char]
fp = [Char] -> NormalizedFilePath
LSP.toNormalizedFilePath [Char]
fp

emptyFilePath :: LSP.NormalizedFilePath
emptyFilePath :: NormalizedFilePath
emptyFilePath = NormalizedFilePath
LSP.emptyNormalizedFilePath

-- | We use an empty string as a filepath when we don’t have a file.
-- However, haskell-lsp doesn’t support that in uriToFilePath and given
-- that it is not a valid filepath it does not make sense to upstream a fix.
-- So we have our own wrapper here that supports empty filepaths.
uriToFilePath' :: LSP.Uri -> Maybe FilePath
uriToFilePath' :: Uri -> Maybe [Char]
uriToFilePath' Uri
uri
    | Uri
uri Uri -> Uri -> Bool
forall a. Eq a => a -> a -> Bool
== NormalizedUri -> Uri
LSP.fromNormalizedUri NormalizedUri
emptyPathUri = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
""
    | Bool
otherwise = Uri -> Maybe [Char]
LSP.uriToFilePath Uri
uri

emptyPathUri :: LSP.NormalizedUri
emptyPathUri :: NormalizedUri
emptyPathUri =
    let s :: Text
s = Text
"file://"
    in Int -> Text -> NormalizedUri
LSP.NormalizedUri (Text -> Int
forall a. Hashable a => a -> Int
hash Text
s) Text
s

filePathToUri' :: LSP.NormalizedFilePath -> LSP.NormalizedUri
filePathToUri' :: NormalizedFilePath -> NormalizedUri
filePathToUri' = NormalizedFilePath -> NormalizedUri
LSP.normalizedFilePathToUri

fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath
fromUri :: NormalizedUri -> NormalizedFilePath
fromUri = NormalizedFilePath
-> Maybe NormalizedFilePath -> NormalizedFilePath
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> NormalizedFilePath
toNormalizedFilePath' [Char]
noFilePath) (Maybe NormalizedFilePath -> NormalizedFilePath)
-> (NormalizedUri -> Maybe NormalizedFilePath)
-> NormalizedUri
-> NormalizedFilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedUri -> Maybe NormalizedFilePath
LSP.uriToNormalizedFilePath

noFilePath :: FilePath
noFilePath :: [Char]
noFilePath = [Char]
"<unknown>"

-- A dummy range to use when range is unknown
noRange :: Range
noRange :: Range
noRange =  Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
0 UInt
0) (UInt -> UInt -> Position
Position UInt
1 UInt
0)

showPosition :: Position -> String
showPosition :: Position -> [Char]
showPosition Position{UInt
_line :: UInt
_character :: UInt
$sel:_character:Position :: Position -> UInt
$sel:_line:Position :: Position -> UInt
..} = UInt -> [Char]
forall a. Show a => a -> [Char]
show (UInt
_line UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
1) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ UInt -> [Char]
forall a. Show a => a -> [Char]
show (UInt
_character UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
1)

-- | Parser for the GHC output format
readSrcSpan :: ReadS RealSrcSpan
readSrcSpan :: ReadS RealSrcSpan
readSrcSpan = ReadP RealSrcSpan -> ReadS RealSrcSpan
forall a. ReadP a -> ReadS a
readP_to_S (ReadP RealSrcSpan
singleLineSrcSpanP ReadP RealSrcSpan -> ReadP RealSrcSpan -> ReadP RealSrcSpan
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP RealSrcSpan
multiLineSrcSpanP)
  where
    singleLineSrcSpanP, multiLineSrcSpanP :: ReadP RealSrcSpan
    singleLineSrcSpanP :: ReadP RealSrcSpan
singleLineSrcSpanP = do
      FastString
fp <- ReadP FastString
filePathP
      Int
l  <- ReadS Int -> ReadP Int
forall a. ReadS a -> ReadP a
readS_to_P ReadS Int
forall a. Read a => ReadS a
reads ReadP Int -> ReadP Char -> ReadP Int
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ReadP Char
char Char
':'
      Int
c0 <- ReadS Int -> ReadP Int
forall a. ReadS a -> ReadP a
readS_to_P ReadS Int
forall a. Read a => ReadS a
reads
      Int
c1 <- (Char -> ReadP Char
char Char
'-' ReadP Char -> ReadP Int -> ReadP Int
forall a b. ReadP a -> ReadP b -> ReadP b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ReadS Int -> ReadP Int
forall a. ReadS a -> ReadP a
readS_to_P ReadS Int
forall a. Read a => ReadS a
reads) ReadP Int -> ReadP Int -> ReadP Int
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> ReadP Int
forall a. a -> ReadP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
c0
      let from :: RealSrcLoc
from = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
fp Int
l Int
c0
          to :: RealSrcLoc
to   = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
fp Int
l Int
c1
      RealSrcSpan -> ReadP RealSrcSpan
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcSpan -> ReadP RealSrcSpan)
-> RealSrcSpan -> ReadP RealSrcSpan
forall a b. (a -> b) -> a -> b
$ RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan RealSrcLoc
from RealSrcLoc
to

    multiLineSrcSpanP :: ReadP RealSrcSpan
multiLineSrcSpanP = do
      FastString
fp <- ReadP FastString
filePathP
      RealSrcLoc
s <- ReadP RealSrcLoc -> ReadP RealSrcLoc
forall a. ReadP a -> ReadP a
parensP (FastString -> ReadP RealSrcLoc
srcLocP FastString
fp)
      ReadP Char -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP Char -> ReadP ()) -> ReadP Char -> ReadP ()
forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
char Char
'-'
      RealSrcLoc
e <- ReadP RealSrcLoc -> ReadP RealSrcLoc
forall a. ReadP a -> ReadP a
parensP (FastString -> ReadP RealSrcLoc
srcLocP FastString
fp)
      RealSrcSpan -> ReadP RealSrcSpan
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcSpan -> ReadP RealSrcSpan)
-> RealSrcSpan -> ReadP RealSrcSpan
forall a b. (a -> b) -> a -> b
$ RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan RealSrcLoc
s RealSrcLoc
e

    parensP :: ReadP a -> ReadP a
    parensP :: forall a. ReadP a -> ReadP a
parensP = ReadP Char -> ReadP Char -> ReadP a -> ReadP a
forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between (Char -> ReadP Char
char Char
'(') (Char -> ReadP Char
char Char
')')

    filePathP :: ReadP FastString
    filePathP :: ReadP FastString
filePathP = [Char] -> FastString
forall a. IsString a => [Char] -> a
fromString ([Char] -> FastString) -> ReadP [Char] -> ReadP FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReadP [Char]
readFilePath ReadP [Char] -> ReadP Char -> ReadP [Char]
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ReadP Char
char Char
':') ReadP FastString -> ReadP FastString -> ReadP FastString
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FastString -> ReadP FastString
forall a. a -> ReadP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FastString
""

    srcLocP :: FastString -> ReadP RealSrcLoc
    srcLocP :: FastString -> ReadP RealSrcLoc
srcLocP FastString
fp = do
      Int
l <- ReadS Int -> ReadP Int
forall a. ReadS a -> ReadP a
readS_to_P ReadS Int
forall a. Read a => ReadS a
reads
      ReadP Char -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP Char -> ReadP ()) -> ReadP Char -> ReadP ()
forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
char Char
','
      Int
c <- ReadS Int -> ReadP Int
forall a. ReadS a -> ReadP a
readS_to_P ReadS Int
forall a. Read a => ReadS a
reads
      RealSrcLoc -> ReadP RealSrcLoc
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcLoc -> ReadP RealSrcLoc) -> RealSrcLoc -> ReadP RealSrcLoc
forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
fp Int
l Int
c

    readFilePath :: ReadP FilePath
    readFilePath :: ReadP [Char]
readFilePath = ReadP Char -> ReadP [Char]
forall a. ReadP a -> ReadP [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ReadP Char
ReadP.get