1- {-# LANGUAGE LambdaCase #-}
1+ {-# LANGUAGE DeriveGeneric #-}
22{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3- {-# LANGUAGE DeriveGeneric #-}
4- {-# LANGUAGE RecordWildCards #-}
3+ {-# LANGUAGE InstanceSigs #-}
4+ {-# LANGUAGE OverloadedStrings #-}
5+ {-# LANGUAGE RankNTypes #-}
6+ {-# LANGUAGE RecordWildCards #-}
7+ {-# LANGUAGE TypeSynonymInstances #-}
8+
59module Language.LSP.Types.Uri
610 ( Uri (.. )
711 , uriToFilePath
@@ -10,32 +14,39 @@ module Language.LSP.Types.Uri
1014 , toNormalizedUri
1115 , fromNormalizedUri
1216 , NormalizedFilePath
13- , normalizedFilePath
1417 , toNormalizedFilePath
1518 , fromNormalizedFilePath
1619 , normalizedFilePathToUri
1720 , uriToNormalizedFilePath
21+ , emptyNormalizedFilePath
1822 -- Private functions
1923 , platformAwareUriToFilePath
2024 , platformAwareFilePathToUri
2125 )
2226 where
2327
2428import Control.DeepSeq
25- import qualified Data.Aeson as A
26- import Data.Binary (Binary , Get , put , get )
29+ import qualified Data.Aeson as A
30+ import Data.Binary (Binary , Get , get , put )
31+ import Data.ByteString.Short (ShortByteString )
32+ import qualified Data.ByteString.Short as BS
2733import Data.Hashable
28- import Data.List (stripPrefix )
29- import Data.String (IsString , fromString )
30- import Data.Text (Text )
31- import qualified Data.Text as T
34+ import Data.List (stripPrefix )
35+ import Data.String (IsString (fromString ))
36+ import Data.Text (Text )
37+ import qualified Data.Text as T
38+ import qualified Data.Text.Encoding as T
39+ import Data.Text.Encoding.Error (UnicodeException )
3240import GHC.Generics
33- import Network.URI hiding (authority )
34- import qualified System.FilePath as FP
35- import qualified System.FilePath.Posix as FPP
36- import qualified System.FilePath.Windows as FPW
41+ import GHC.Stack (HasCallStack )
42+ import Network.URI hiding (authority )
43+ import Safe (tailMay )
44+ import qualified System.FilePath as FP
45+ import qualified System.FilePath.Posix as FPP
46+ import qualified System.FilePath.Windows as FPW
3747import qualified System.Info
3848
49+
3950newtype Uri = Uri { getUri :: Text }
4051 deriving (Eq ,Ord ,Read ,Show ,Generic ,A.FromJSON ,A.ToJSON ,Hashable ,A.ToJSONKey ,A.FromJSONKey )
4152
@@ -67,7 +78,7 @@ isUnescapedInUriPath systemOS c
6778normalizeUriEscaping :: String -> String
6879normalizeUriEscaping uri =
6980 case stripPrefix (fileScheme ++ " //" of
70- Just p -> fileScheme ++ " //" ++ ( escapeURIPath $ unEscapeString p)
81+ Just p -> fileScheme ++ " //" ++ escapeURIPath ( unEscapeString p)
7182 Nothing -> escapeURIString isUnescapedInURI $ unEscapeString uri
7283 where escapeURIPath = escapeURIString (isUnescapedInUriPath System.Info. os)
7384
@@ -107,17 +118,19 @@ platformAdjustFromUriPath :: SystemOS
107118 -> String -- ^ path
108119 -> FilePath
109120platformAdjustFromUriPath systemOS authority srcPath =
110- (maybe id (++) authority) $
111- if systemOS /= windowsOS || null srcPath then srcPath
112- else let
113- firstSegment: rest = (FPP. splitDirectories . tail ) srcPath -- Drop leading '/' for absolute Windows paths
114- drive = if FPW. isDrive firstSegment
115- then FPW. addTrailingPathSeparator firstSegment
116- else firstSegment
117- in FPW. joinDrive drive $ FPW. joinPath rest
121+ maybe id (++) authority $
122+ if systemOS /= windowsOS
123+ then srcPath
124+ else case FPP. splitDirectories <$> tailMay srcPath of
125+ Just (firstSegment: rest) -> -- Drop leading '/' for absolute Windows paths
126+ let drive = if FPW. isDrive firstSegment
127+ then FPW. addTrailingPathSeparator firstSegment
128+ else firstSegment
129+ in FPW. joinDrive drive $ FPW. joinPath rest
130+ _ -> srcPath
118131
119132filePathToUri :: FilePath -> Uri
120- filePathToUri = ( platformAwareFilePathToUri System.Info. os) . FP. normalise
133+ filePathToUri = platformAwareFilePathToUri System.Info. os . FP. normalise
121134
122135{-# WARNING platformAwareFilePathToUri "This function is considered private. Use normalizedUriToFilePath instead." #-}
123136platformAwareFilePathToUri :: SystemOS -> FilePath -> Uri
@@ -151,27 +164,32 @@ platformAdjustToUriPath systemOS srcPath
151164 FPP. addTrailingPathSeparator (init drv)
152165 | otherwise = drv
153166
154- -- | Newtype wrapper around FilePath that always has normalized slashes.
155- -- The NormalizedUri and hash of the FilePath are cached to avoided
167+ -- | A file path that is already normalized. It is stored as an UTF-8 encoded 'ShortByteString'
168+ --
169+ -- The 'NormalizedUri' is cached to avoided
156170-- repeated normalisation when we need to compute them (which is a lot).
157171--
158172-- This is one of the most performance critical parts of ghcide, do not
159173-- modify it without profiling.
160- data NormalizedFilePath = NormalizedFilePath NormalizedUri ! FilePath
174+ data NormalizedFilePath = NormalizedFilePath ! NormalizedUri {- # UNPACK # -} ! ShortByteString
161175 deriving (Generic , Eq , Ord )
162176
163177instance NFData NormalizedFilePath
164178
165179instance Binary NormalizedFilePath where
166180 put (NormalizedFilePath _ fp) = put fp
167181 get = do
168- v <- Data.Binary. get :: Get FilePath
169- let nuri = internalNormalizedFilePathToUri v
170- return (normalizedFilePath nuri v)
182+ v <- Data.Binary. get :: Get ShortByteString
183+ case decodeFilePath v of
184+ Left -> fail (show e)
185+ Right ->
186+ return (NormalizedFilePath (internalNormalizedFilePathToUri v') v)
187+
188+ encodeFilePath :: String -> ShortByteString
189+ encodeFilePath = BS. toShort . T. encodeUtf8 . T. pack
171190
172- -- | A smart constructor that performs UTF-8 encoding and hash consing
173- normalizedFilePath :: NormalizedUri -> FilePath -> NormalizedFilePath
174- normalizedFilePath nuri nfp = NormalizedFilePath nuri nfp
191+ decodeFilePath :: ShortByteString -> Either UnicodeException String
192+ decodeFilePath = fmap T. unpack . T. decodeUtf8' . BS. fromShort
175193
176194-- | Internal helper that takes a file path that is assumed to
177195-- already be normalized to a URI. It is up to the caller
@@ -191,20 +209,36 @@ instance Hashable NormalizedFilePath where
191209 hashWithSalt salt (NormalizedFilePath uri _) = hashWithSalt salt uri
192210
193211instance IsString NormalizedFilePath where
212+ fromString :: String -> NormalizedFilePath
194213 fromString = toNormalizedFilePath
195214
196215toNormalizedFilePath :: FilePath -> NormalizedFilePath
197- toNormalizedFilePath fp = normalizedFilePath nuri nfp
216+ toNormalizedFilePath fp = NormalizedFilePath nuri . encodeFilePath $ nfp
198217 where
199- nfp = FP. normalise fp
200- nuri = internalNormalizedFilePathToUri nfp
218+ nfp = FP. normalise fp
219+ nuri = internalNormalizedFilePathToUri nfp
201220
202- fromNormalizedFilePath :: NormalizedFilePath -> FilePath
203- fromNormalizedFilePath (NormalizedFilePath _ fp) = fp
221+ -- | Extracts 'FilePath' from 'NormalizedFilePath'.
222+ -- The function is total. The 'HasCallStack' constraint is added for debugging purpose only.
223+ fromNormalizedFilePath :: HasCallStack => NormalizedFilePath -> FilePath
224+ fromNormalizedFilePath (NormalizedFilePath _ fp) =
225+ case decodeFilePath fp of
226+ Left -> error $ show e
227+ Right -> x
204228
205229normalizedFilePathToUri :: NormalizedFilePath -> NormalizedUri
206230normalizedFilePathToUri (NormalizedFilePath uri _) = uri
207231
208232uriToNormalizedFilePath :: NormalizedUri -> Maybe NormalizedFilePath
209- uriToNormalizedFilePath nuri = fmap (normalizedFilePath nuri) mbFilePath
233+ uriToNormalizedFilePath nuri = fmap (NormalizedFilePath nuri . encodeFilePath ) mbFilePath
210234 where mbFilePath = platformAwareUriToFilePath System.Info. os (fromNormalizedUri nuri)
235+
236+ emptyNormalizedUri :: NormalizedUri
237+ emptyNormalizedUri =
238+ let s = " file://"
239+ in NormalizedUri (hash s) s
240+
241+ -- | 'NormalizedFilePath' that contains an empty file path
242+ emptyNormalizedFilePath :: NormalizedFilePath
243+ emptyNormalizedFilePath = NormalizedFilePath emptyNormalizedUri " "
244+
0 commit comments