use OsPath in NormalizedFilePath

cabal.project

@@ -10,3 +10,8 @@ tests: True
 benchmarks: True
 test-show-details: direct
 haddock-quickjump: True
+
+source-repository-package
+  type: git
+  location: https://github.com/kokobd/filepath-compat
+  tag: 1.4.100.0

lsp-types/lsp-types.cabal

@@ -16,6 +16,11 @@ category:            Development
 build-type:          Simple
 extra-source-files:  ChangeLog.md, README.md
 
+flag filepath-compat
+  description: use "filepath-compat" library
+  manual: False
+  default: False
+
 library
   exposed-modules:     Language.LSP.Types
                      , Language.LSP.Types.Capabilities
@@ -78,7 +83,6 @@ library
                      , deepseq
                      , Diff >= 0.2
                      , dlist
-                     , filepath
                      , hashable
                      , lens >= 4.15.2
                      , mtl < 2.4
@@ -89,6 +93,13 @@ library
                      , text
                      , template-haskell
                      , unordered-containers
+                     , exceptions
+                     , safe
+                     , bytestring
+  if flag(filepath-compat)
+    build-depends: filepath-compat
+  else
+    build-depends: filepath ^>= 1.4.100.0
   hs-source-dirs:      src
   default-language:    Haskell2010
   default-extensions: StrictData
@@ -106,6 +117,7 @@ test-suite lsp-types-test
                        TypesSpec
                        URIFilePathSpec
                        WorkspaceEditSpec
+                       LocationSpec
   build-depends:       base
                      , QuickCheck
                      -- for instance Arbitrary Value

lsp-types/src/Language/LSP/Types/Uri.hs

@@ -1,7 +1,10 @@
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE InstanceSigs               #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+
 module Language.LSP.Types.Uri
   ( Uri(..)
   , uriToFilePath
@@ -10,31 +13,44 @@ module Language.LSP.Types.Uri
   , toNormalizedUri
   , fromNormalizedUri
   , NormalizedFilePath
-  , normalizedFilePath
   , toNormalizedFilePath
   , fromNormalizedFilePath
   , normalizedFilePathToUri
   , uriToNormalizedFilePath
+  , osPathToNormalizedFilePath
+  , osPathFromNormalizedFilePath
   -- Private functions
   , platformAwareUriToFilePath
   , platformAwareFilePathToUri
   )
   where
 
 import           Control.DeepSeq
-import qualified Data.Aeson                                 as A
-import           Data.Binary                                (Binary, Get, put, get)
+import           Control.Monad.Catch            (MonadThrow)
+import qualified Data.Aeson                     as A
+import           Data.Binary                    (Binary, Get, get, put)
+import           Data.ByteString.Short          (ShortByteString)
 import           Data.Hashable
-import           Data.List                                  (stripPrefix)
-import           Data.String                                (IsString, fromString)
-import           Data.Text                                  (Text)
-import qualified Data.Text                                  as T
+import           Data.List                      (stripPrefix)
+import           Data.Maybe                     (fromJust)
+import           Data.Text                      (Text)
+import qualified Data.Text                      as T
 import           GHC.Generics
-import           Network.URI hiding (authority)
-import qualified System.FilePath                            as FP
-import qualified System.FilePath.Posix                      as FPP
-import qualified System.FilePath.Windows                    as FPW
+import           Network.URI                    hiding (authority)
+import           Safe                           (tailMay)
+import qualified System.FilePath                as FP
+import qualified System.FilePath.Posix          as FPP
+import qualified System.FilePath.Windows        as FPW
 import qualified System.Info
+import qualified System.OsPath                  as OsPath
+import           System.OsPath                  (OsPath)
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+import           System.OsString.Internal.Types (OsString (..),
+                                                 WindowsString (..))
+#else
+import           System.OsString.Internal.Types (OsString (..),
+                                                 PosixString (..))
+#endif
 
 newtype Uri = Uri { getUri :: Text }
   deriving (Eq,Ord,Read,Show,Generic,A.FromJSON,A.ToJSON,Hashable,A.ToJSONKey,A.FromJSONKey)
@@ -67,7 +83,7 @@ isUnescapedInUriPath systemOS c
 normalizeUriEscaping :: String -> String
 normalizeUriEscaping uri =
   case stripPrefix (fileScheme ++ "//") uri of
-    Just p -> fileScheme ++ "//" ++ (escapeURIPath $ unEscapeString p)
+    Just p  -> fileScheme ++ "//" ++ escapeURIPath (unEscapeString p)
     Nothing -> escapeURIString isUnescapedInURI $ unEscapeString uri
   where escapeURIPath = escapeURIString (isUnescapedInUriPath System.Info.os)
 
@@ -107,17 +123,19 @@ platformAdjustFromUriPath :: SystemOS
                           -> String -- ^ path
                           -> FilePath
 platformAdjustFromUriPath systemOS authority srcPath =
-  (maybe id (++) authority) $
-  if systemOS /= windowsOS || null srcPath then srcPath
-    else let
-      firstSegment:rest = (FPP.splitDirectories . tail) srcPath  -- Drop leading '/' for absolute Windows paths
-      drive = if FPW.isDrive firstSegment
-              then FPW.addTrailingPathSeparator firstSegment
-              else firstSegment
-      in FPW.joinDrive drive $ FPW.joinPath rest
+  maybe id (++) authority $
+  if systemOS /= windowsOS
+  then srcPath
+  else case FPP.splitDirectories <$> tailMay srcPath of
+      Just (firstSegment:rest) -> -- Drop leading '/' for absolute Windows paths
+        let drive = if FPW.isDrive firstSegment
+                    then FPW.addTrailingPathSeparator firstSegment
+                    else firstSegment
+         in FPW.joinDrive drive $ FPW.joinPath rest
+      _ -> srcPath
 
 filePathToUri :: FilePath -> Uri
-filePathToUri = (platformAwareFilePathToUri System.Info.os) . FP.normalise
+filePathToUri = platformAwareFilePathToUri System.Info.os . FP.normalise
 
 {-# WARNING platformAwareFilePathToUri "This function is considered private. Use normalizedUriToFilePath instead." #-}
 platformAwareFilePathToUri :: SystemOS -> FilePath -> Uri
@@ -157,31 +175,45 @@ platformAdjustToUriPath systemOS srcPath
 --
 -- This is one of the most performance critical parts of ghcide, do not
 -- modify it without profiling.
-data NormalizedFilePath = NormalizedFilePath NormalizedUri !FilePath
+data NormalizedFilePath = NormalizedFilePath NormalizedUri !OsPath
     deriving (Generic, Eq, Ord)
 
 instance NFData NormalizedFilePath
 
 instance Binary NormalizedFilePath where
-  put (NormalizedFilePath _ fp) = put fp
+  put (NormalizedFilePath _ fp) = put (unwrapOsPath fp)
   get = do
-    v <- Data.Binary.get :: Get FilePath
-    let nuri = internalNormalizedFilePathToUri v
-    return (normalizedFilePath nuri v)
-
--- | A smart constructor that performs UTF-8 encoding and hash consing
-normalizedFilePath :: NormalizedUri -> FilePath -> NormalizedFilePath
-normalizedFilePath nuri nfp = NormalizedFilePath nuri nfp
+    v <- Data.Binary.get :: Get ShortByteString
+    let v' = makeOsPath v
+        nuri = internalNormalizedFilePathToUri v'
+    return (NormalizedFilePath (fromJust nuri) v')
+
+-- Remove the CPP hack when OsPath gets 'Binary' instance.
+-- See: https://gitlab.haskell.org/haskell/filepath/-/issues/122
+
+unwrapOsPath :: OsPath -> ShortByteString
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+unwrapOsPath = getWindowsString . getOsString
+#else
+unwrapOsPath = getPosixString . getOsString
+#endif
+
+makeOsPath :: ShortByteString -> OsPath
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+makeOsPath = OsString . WindowsString
+#else
+makeOsPath = OsString . PosixString
+#endif
 
 -- | Internal helper that takes a file path that is assumed to
 -- already be normalized to a URI. It is up to the caller
 -- to ensure normalization.
-internalNormalizedFilePathToUri :: FilePath -> NormalizedUri
+internalNormalizedFilePathToUri :: MonadThrow m => OsPath -> m NormalizedUri
 internalNormalizedFilePathToUri fp = nuri
   where
-    uriPath = platformAdjustToUriPath System.Info.os fp
-    nuriStr = T.pack $ fileScheme <> "//" <> uriPath
-    nuri = NormalizedUri (hash nuriStr) nuriStr
+    uriPath = platformAdjustToUriPath System.Info.os <$> OsPath.decodeUtf fp
+    nuriStr = fmap (T.pack . \p -> fileScheme <> "//" <> p) uriPath
+    nuri = fmap (\nuriStr' -> NormalizedUri (hash nuriStr') nuriStr') nuriStr
 
 instance Show NormalizedFilePath where
   show (NormalizedFilePath _ fp) = "NormalizedFilePath " ++ show fp
@@ -190,21 +222,24 @@ instance Hashable NormalizedFilePath where
   hash (NormalizedFilePath uri _) = hash uri
   hashWithSalt salt (NormalizedFilePath uri _) = hashWithSalt salt uri
 
-instance IsString NormalizedFilePath where
-    fromString = toNormalizedFilePath
+toNormalizedFilePath :: MonadThrow m => FilePath -> m NormalizedFilePath
+toNormalizedFilePath fp = OsPath.encodeUtf fp >>= osPathToNormalizedFilePath
+
+fromNormalizedFilePath :: MonadThrow m => NormalizedFilePath -> m FilePath
+fromNormalizedFilePath = OsPath.decodeUtf . osPathFromNormalizedFilePath
 
-toNormalizedFilePath :: FilePath -> NormalizedFilePath
-toNormalizedFilePath fp = normalizedFilePath nuri nfp
+osPathToNormalizedFilePath :: MonadThrow m => OsPath -> m NormalizedFilePath
+osPathToNormalizedFilePath fp = flip NormalizedFilePath nfp <$> nuri
   where
-      nfp = FP.normalise fp
-      nuri = internalNormalizedFilePathToUri nfp
+    nfp = OsPath.normalise fp
+    nuri = internalNormalizedFilePathToUri nfp
 
-fromNormalizedFilePath :: NormalizedFilePath -> FilePath
-fromNormalizedFilePath (NormalizedFilePath _ fp) = fp
+osPathFromNormalizedFilePath :: NormalizedFilePath -> OsPath
+osPathFromNormalizedFilePath (NormalizedFilePath _ osPath) = osPath
 
 normalizedFilePathToUri :: NormalizedFilePath -> NormalizedUri
 normalizedFilePathToUri (NormalizedFilePath uri _) = uri
 
 uriToNormalizedFilePath :: NormalizedUri -> Maybe NormalizedFilePath
-uriToNormalizedFilePath nuri = fmap (normalizedFilePath nuri) mbFilePath
+uriToNormalizedFilePath nuri = fmap (NormalizedFilePath nuri) (mbFilePath >>= OsPath.encodeUtf)
   where mbFilePath = platformAwareUriToFilePath System.Info.os (fromNormalizedUri nuri)

lsp-types/test/URIFilePathSpec.hs

@@ -1,17 +1,17 @@
 {-# LANGUAGE OverloadedStrings #-}
 module URIFilePathSpec where
 
-import Control.Monad                          (when)
-import Data.List
-import Data.Text                              (Text, pack)
-import Language.LSP.Types
-
-import Network.URI
-import Test.Hspec
-import Test.QuickCheck
+import           Control.Monad           (when)
+import           Data.List
+import           Data.Text               (Text, pack)
+import           Language.LSP.Types
+
+import           Network.URI
+import           System.FilePath         (normalise)
 import qualified System.FilePath.Windows as FPW
-import System.FilePath                        (normalise)
 import qualified System.Info
+import           Test.Hspec
+import           Test.QuickCheck
 -- ---------------------------------------------------------------------
 
 isWindows :: Bool
@@ -224,7 +224,7 @@ uriNormalizeSpec = do
     let nuri = toNormalizedUri (filePathToUri fp)
     case uriToFilePath (fromNormalizedUri nuri) of
       Just nfp -> nfp `shouldBe` (normalise fp)
-      Nothing -> return () -- Some unicode paths creates invalid uris, ignoring for now
+      Nothing  -> return () -- Some unicode paths creates invalid uris, ignoring for now
 
 genFilePath :: Gen FilePath
 genFilePath | isWindows = genWindowsFilePath
@@ -252,27 +252,27 @@ normalizedFilePathSpec :: Spec
 normalizedFilePathSpec = do
   it "makes file path normalized" $ property $ forAll genFilePath $ \fp -> do
     let nfp = toNormalizedFilePath fp
-    fromNormalizedFilePath nfp `shouldBe` (normalise fp)
+    (nfp >>= fromNormalizedFilePath) `shouldBe` Just (normalise fp)
 
   it "converts to a normalized uri and back" $ property $ forAll genFilePath $ \fp -> do
-    let nuri = normalizedFilePathToUri (toNormalizedFilePath fp)
-    case uriToNormalizedFilePath nuri of
-      Just nfp -> fromNormalizedFilePath nfp `shouldBe` (normalise fp)
-      Nothing -> return () -- Some unicode paths creates invalid uris, ignoring for now
+    let nuri = normalizedFilePathToUri <$> toNormalizedFilePath fp
+    case uriToNormalizedFilePath =<< nuri of
+      Just nfp -> fromNormalizedFilePath nfp `shouldBe` Just (normalise fp)
+      Nothing  -> return () -- Some unicode paths creates invalid uris, ignoring for now
 
   it "converts a file path with reserved uri chars to a normalized URI and back" $ do
     let start = if isWindows then "C:\\" else "/"
     let fp = start ++ "path;part#fragmen?param=val"
-    let nuri = normalizedFilePathToUri (toNormalizedFilePath fp)
-    fmap fromNormalizedFilePath (uriToNormalizedFilePath nuri) `shouldBe` Just fp
+    let nuri = normalizedFilePathToUri <$> toNormalizedFilePath fp
+    (fromNormalizedFilePath =<< (uriToNormalizedFilePath =<< nuri)) `shouldBe` Just fp
 
   it "converts a file path with substrings that looks like uri escaped chars and back" $ do
     let start = if isWindows then "C:\\" else "/"
     let fp = start ++ "ca%C3%B1a"
-    let nuri = normalizedFilePathToUri (toNormalizedFilePath fp)
-    fmap fromNormalizedFilePath (uriToNormalizedFilePath nuri) `shouldBe` Just fp
+    let nuri = normalizedFilePathToUri <$> toNormalizedFilePath fp
+    (fromNormalizedFilePath =<< (uriToNormalizedFilePath =<< nuri)) `shouldBe` Just fp
 
   it "creates the same NormalizedUri than the older implementation" $ property $ forAll genFilePath $ \fp -> do
-    let nuri = normalizedFilePathToUri (toNormalizedFilePath fp)
+    let nuri = normalizedFilePathToUri <$> toNormalizedFilePath fp
     let oldNuri = toNormalizedUri (filePathToUri fp)
-    nuri `shouldBe` oldNuri
+    nuri `shouldBe` Just oldNuri