From 03f94155978b9274ff85c163293eee927eaacd2e Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 23 Jun 2021 14:56:08 +0100 Subject: [PATCH 1/6] intern NormalizedFilePath --- lsp-types/lsp-types.cabal | 1 + lsp-types/src/Language/LSP/Types/Uri.hs | 8 ++++++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/lsp-types/lsp-types.cabal b/lsp-types/lsp-types.cabal index 36a383c3e..e1a6d192c 100644 --- a/lsp-types/lsp-types.cabal +++ b/lsp-types/lsp-types.cabal @@ -82,6 +82,7 @@ library , hslogger , lens >= 4.15.2 , network-uri + , MemoTrie , rope-utf16-splay >= 0.3.1.0 , scientific , some diff --git a/lsp-types/src/Language/LSP/Types/Uri.hs b/lsp-types/src/Language/LSP/Types/Uri.hs index 8970d3765..abd52f10b 100644 --- a/lsp-types/src/Language/LSP/Types/Uri.hs +++ b/lsp-types/src/Language/LSP/Types/Uri.hs @@ -33,6 +33,7 @@ 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 Data.MemoTrie (memo) newtype Uri = Uri { getUri :: Text } deriving (Eq,Ord,Read,Show,Generic,A.FromJSON,A.ToJSON,Hashable,A.ToJSONKey,A.FromJSONKey) @@ -190,9 +191,12 @@ instance IsString NormalizedFilePath where toNormalizedFilePath :: FilePath -> NormalizedFilePath toNormalizedFilePath fp = NormalizedFilePath nuri nfp where - nfp = FP.normalise fp + nfp = internFilePath $ FP.normalise fp nuri = internalNormalizedFilePathToUri nfp +internFilePath :: FilePath -> FilePath +internFilePath = memo FP.joinPath . FP.splitPath + fromNormalizedFilePath :: NormalizedFilePath -> FilePath fromNormalizedFilePath (NormalizedFilePath _ fp) = fp @@ -200,5 +204,5 @@ normalizedFilePathToUri :: NormalizedFilePath -> NormalizedUri normalizedFilePathToUri (NormalizedFilePath uri _) = uri uriToNormalizedFilePath :: NormalizedUri -> Maybe NormalizedFilePath -uriToNormalizedFilePath nuri = fmap (NormalizedFilePath nuri) mbFilePath +uriToNormalizedFilePath nuri = fmap (NormalizedFilePath nuri . internFilePath) mbFilePath where mbFilePath = platformAwareUriToFilePath System.Info.os (fromNormalizedUri nuri) From 16a0b73af1aa5f6d07ce566916c827a28043fdfa Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 23 Jun 2021 15:30:10 +0100 Subject: [PATCH 2/6] force intern --- lsp-types/src/Language/LSP/Types/Uri.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lsp-types/src/Language/LSP/Types/Uri.hs b/lsp-types/src/Language/LSP/Types/Uri.hs index abd52f10b..3e872b4de 100644 --- a/lsp-types/src/Language/LSP/Types/Uri.hs +++ b/lsp-types/src/Language/LSP/Types/Uri.hs @@ -195,7 +195,7 @@ toNormalizedFilePath fp = NormalizedFilePath nuri nfp nuri = internalNormalizedFilePathToUri nfp internFilePath :: FilePath -> FilePath -internFilePath = memo FP.joinPath . FP.splitPath +internFilePath = force . memo FP.joinPath . FP.splitPath fromNormalizedFilePath :: NormalizedFilePath -> FilePath fromNormalizedFilePath (NormalizedFilePath _ fp) = fp From dae2aaefa4e262414664dcbb0777c9e11e28b11d Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 23 Jun 2021 16:35:34 +0100 Subject: [PATCH 3/6] format import --- lsp-types/src/Language/LSP/Types/Uri.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lsp-types/src/Language/LSP/Types/Uri.hs b/lsp-types/src/Language/LSP/Types/Uri.hs index 3e872b4de..46298aebe 100644 --- a/lsp-types/src/Language/LSP/Types/Uri.hs +++ b/lsp-types/src/Language/LSP/Types/Uri.hs @@ -24,6 +24,7 @@ import qualified Data.Aeson as A import Data.Binary (Binary, Get, put, get) import Data.Hashable import Data.List (stripPrefix) +import Data.MemoTrie (memo) import Data.String (IsString, fromString) import Data.Text (Text) import qualified Data.Text as T @@ -33,7 +34,6 @@ 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 Data.MemoTrie (memo) newtype Uri = Uri { getUri :: Text } deriving (Eq,Ord,Read,Show,Generic,A.FromJSON,A.ToJSON,Hashable,A.ToJSONKey,A.FromJSONKey) From b0aa396c9039060771e6f61819d570eb09f1e28e Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 23 Jun 2021 23:59:59 +0100 Subject: [PATCH 4/6] roll our own --- lsp-types/lsp-types.cabal | 1 - lsp-types/src/Language/LSP/Types/Uri.hs | 32 ++++++++++++++++++------- 2 files changed, 24 insertions(+), 9 deletions(-) diff --git a/lsp-types/lsp-types.cabal b/lsp-types/lsp-types.cabal index e1a6d192c..36a383c3e 100644 --- a/lsp-types/lsp-types.cabal +++ b/lsp-types/lsp-types.cabal @@ -82,7 +82,6 @@ library , hslogger , lens >= 4.15.2 , network-uri - , MemoTrie , rope-utf16-splay >= 0.3.1.0 , scientific , some diff --git a/lsp-types/src/Language/LSP/Types/Uri.hs b/lsp-types/src/Language/LSP/Types/Uri.hs index 46298aebe..ec8fb9168 100644 --- a/lsp-types/src/Language/LSP/Types/Uri.hs +++ b/lsp-types/src/Language/LSP/Types/Uri.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} @@ -23,17 +24,20 @@ import Control.DeepSeq import qualified Data.Aeson as A import Data.Binary (Binary, Get, put, get) import Data.Hashable +import qualified Data.HashMap.Strict as HM +import Data.IORef (atomicModifyIORef', newIORef) import Data.List (stripPrefix) -import Data.MemoTrie (memo) import Data.String (IsString, fromString) import Data.Text (Text) import qualified Data.Text as T +import Data.Tuple (swap) 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 qualified System.Info +import System.IO.Unsafe (unsafePerformIO) newtype Uri = Uri { getUri :: Text } deriving (Eq,Ord,Read,Show,Generic,A.FromJSON,A.ToJSON,Hashable,A.ToJSONKey,A.FromJSONKey) @@ -166,7 +170,7 @@ instance Binary NormalizedFilePath where get = do v <- Data.Binary.get :: Get FilePath let nuri = internalNormalizedFilePathToUri v - return (NormalizedFilePath nuri v) + return (intern $ NormalizedFilePath nuri v) -- | Internal helper that takes a file path that is assumed to -- already be normalized to a URI. It is up to the caller @@ -189,14 +193,11 @@ instance IsString NormalizedFilePath where fromString = toNormalizedFilePath toNormalizedFilePath :: FilePath -> NormalizedFilePath -toNormalizedFilePath fp = NormalizedFilePath nuri nfp +toNormalizedFilePath fp = intern $ NormalizedFilePath nuri nfp where - nfp = internFilePath $ FP.normalise fp + nfp = FP.normalise fp nuri = internalNormalizedFilePathToUri nfp -internFilePath :: FilePath -> FilePath -internFilePath = force . memo FP.joinPath . FP.splitPath - fromNormalizedFilePath :: NormalizedFilePath -> FilePath fromNormalizedFilePath (NormalizedFilePath _ fp) = fp @@ -204,5 +205,20 @@ normalizedFilePathToUri :: NormalizedFilePath -> NormalizedUri normalizedFilePathToUri (NormalizedFilePath uri _) = uri uriToNormalizedFilePath :: NormalizedUri -> Maybe NormalizedFilePath -uriToNormalizedFilePath nuri = fmap (NormalizedFilePath nuri . internFilePath) mbFilePath +uriToNormalizedFilePath nuri = fmap (intern . NormalizedFilePath nuri) mbFilePath where mbFilePath = platformAwareUriToFilePath System.Info.os (fromNormalizedUri nuri) + +--------------------------------------------------------------------------- +-- Unsafe hashcons of NFP +internIO :: (Eq a, Hashable a) => IO (a -> IO a) +internIO = do + tableRef <- newIORef mempty + let f x = atomicModifyIORef' tableRef $ swap . flip HM.alterF x (\case + Just res -> (res, Just res) + Nothing -> (x, Just x) + ) + return f + +{-# NOINLINE intern #-} +intern :: NormalizedFilePath -> NormalizedFilePath +intern = let f = unsafePerformIO internIO in \x -> unsafePerformIO (f x) From 7a8a6aca58cf6b72c305d361b6f5bda6ab239c99 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 24 Jun 2021 08:21:08 +0100 Subject: [PATCH 5/6] make the constructor abstract --- lsp-types/src/Language/LSP/Types/Uri.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lsp-types/src/Language/LSP/Types/Uri.hs b/lsp-types/src/Language/LSP/Types/Uri.hs index ec8fb9168..6e7c3651d 100644 --- a/lsp-types/src/Language/LSP/Types/Uri.hs +++ b/lsp-types/src/Language/LSP/Types/Uri.hs @@ -9,7 +9,7 @@ module Language.LSP.Types.Uri , NormalizedUri(..) , toNormalizedUri , fromNormalizedUri - , NormalizedFilePath(..) + , NormalizedFilePath , toNormalizedFilePath , fromNormalizedFilePath , normalizedFilePathToUri From 79f08e71225e75f587f1c29fa53a46d3f601d2e5 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 24 Jun 2021 08:32:01 +0100 Subject: [PATCH 6/6] add smart constructor --- lsp-types/src/Language/LSP/Types/Uri.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/lsp-types/src/Language/LSP/Types/Uri.hs b/lsp-types/src/Language/LSP/Types/Uri.hs index 6e7c3651d..88dcca27e 100644 --- a/lsp-types/src/Language/LSP/Types/Uri.hs +++ b/lsp-types/src/Language/LSP/Types/Uri.hs @@ -170,7 +170,11 @@ instance Binary NormalizedFilePath where get = do v <- Data.Binary.get :: Get FilePath let nuri = internalNormalizedFilePathToUri v - return (intern $ NormalizedFilePath nuri v) + return (normalizedFilePath nuri v) + +-- | A smart constructor that performs UTF-8 encoding and hash consing +normalizedFilePath :: NormalizedUri -> FilePath -> NormalizedFilePath +normalizedFilePath nuri nfp = intern $ NormalizedFilePath nuri nfp -- | Internal helper that takes a file path that is assumed to -- already be normalized to a URI. It is up to the caller @@ -193,7 +197,7 @@ instance IsString NormalizedFilePath where fromString = toNormalizedFilePath toNormalizedFilePath :: FilePath -> NormalizedFilePath -toNormalizedFilePath fp = intern $ NormalizedFilePath nuri nfp +toNormalizedFilePath fp = normalizedFilePath nuri nfp where nfp = FP.normalise fp nuri = internalNormalizedFilePathToUri nfp @@ -205,7 +209,7 @@ normalizedFilePathToUri :: NormalizedFilePath -> NormalizedUri normalizedFilePathToUri (NormalizedFilePath uri _) = uri uriToNormalizedFilePath :: NormalizedUri -> Maybe NormalizedFilePath -uriToNormalizedFilePath nuri = fmap (intern . NormalizedFilePath nuri) mbFilePath +uriToNormalizedFilePath nuri = fmap (normalizedFilePath nuri) mbFilePath where mbFilePath = platformAwareUriToFilePath System.Info.os (fromNormalizedUri nuri) ---------------------------------------------------------------------------