Merge pull request #547 from zhujinxuan/joinpaths

Refactor joinPaths to use pathtype

Author: Patrick Thomson

src/Data/Abstract/Path.hs

@@ -2,38 +2,43 @@ module Data.Abstract.Path
   ( dropRelativePrefix
   , joinPaths
   , stripQuotes
-  , joinUntypedPaths
   ) where
 
 import           Data.Text (Text)
 import qualified Data.Text as T
-import           System.FilePath.Posix
 import qualified System.Path as Path
-import System.Path.PartClass (FileDir)
+import System.Path.PartClass (FileDir(..))
 
 -- | Join two paths a and b. Handles walking up relative directories in b. e.g.
 --
 --     joinPaths "a/b" "../c" == "a/c"
 --     joinPaths "a/b" "./c" == "a/b/c"
 --
 -- Walking beyond the beginning of a just stops when you get to the root of a.
-joinUntypedPaths :: FilePath -> FilePath -> FilePath
-joinUntypedPaths a b = let bs = splitPath (normalise b)
-                           n = length (filter (== "../") bs)
-                in normalise $ walkup n a </> joinPath (drop n bs)
+joinPaths :: FileDir fd => Path.AbsRelDir -> Path.Rel fd -> Path.AbsRel fd
+joinPaths = runJP $ switchFileDir (JP joinFilePaths) (JP joinDirPaths) (JP joinFDPaths)
+
+newtype JP fd = JP {runJP :: Path.AbsRelDir -> Path.Rel fd -> Path.AbsRel fd }
+
+joinDirPaths :: Path.AbsRelDir -> Path.RelDir -> Path.AbsRelDir
+joinDirPaths x y = result isAbs
   where
-    walkup 0 str = str
-    walkup n str = walkup (pred n) (takeDirectory str)
+  (isAbs, rels, _) = Path.splitPath (Path.normalise $ x Path.</> y)
+  (_, fRel) = foldr go (0, Path.currentDir) rels
+  go :: Path.RelDir -> (Integer, Path.RelDir) -> (Integer, Path.RelDir)
+  go rel (i, r)
+    | rel == Path.rel ".." = (i + 1, r)
+    | i == 0 = (0, rel Path.</> r)
+    | otherwise = (i - 1, r)
+  result True = Path.toAbsRel $ Path.rootDir Path.</> fRel
+  result False = Path.toAbsRel $ fRel
 
--- | Join two paths a and b. Handles walking up relative directories in b. e.g.
---
---     joinPaths "a/b" "../c" == "a/c"
---     joinPaths "a/b" "./c" == "a/b/c"
---
--- Walking beyond the beginning of a just stops when you get to the root of a.
--- TODO: Rewrite it with pathtype
-joinPaths :: FileDir fd => Path.AbsRelDir -> Path.Rel fd -> Path.AbsRel fd
-joinPaths x y= Path.path $ joinUntypedPaths (Path.toString x) (Path.toString y)
+
+joinFilePaths :: Path.AbsRelDir -> Path.RelFile -> Path.AbsRelFile
+joinFilePaths x y = let (d, f) = Path.splitFileName y in joinDirPaths x d Path.</> f
+
+joinFDPaths :: Path.AbsRelDir -> Path.RelFileDir -> Path.AbsRelFileDir
+joinFDPaths x = Path.toFileDir . joinDirPaths x . Path.dirFromFileDir
 
 
 stripQuotes :: Text -> Text

test/Data/Abstract/Path/Spec.hs

@@ -2,19 +2,22 @@ module Data.Abstract.Path.Spec(spec) where
 
 import Data.Abstract.Path
 import SpecHelpers
+import qualified System.Path as Path
 
 spec :: Spec
 spec = parallel $
   describe "joinPaths" $ do
     it "joins empty paths" $
-      joinUntypedPaths "" "" `shouldBe` "."
+      go Path.currentDir Path.currentDir $ Path.currentDir
     it "joins relative paths" $
-      joinUntypedPaths "a/b" "./c" `shouldBe` "a/b/c"
+      go (Path.relDir "a/b") (Path.relFile "./c") $ Path.relFile "a/b/c"
     it "joins absolute paths" $
-      joinUntypedPaths "/a/b" "c" `shouldBe` "/a/b/c"
+      go (Path.absDir "/a/b") (Path.relDir "c" ) $ Path.absDir "/a/b/c"
     it "walks up directories for ../" $
-      joinUntypedPaths "a/b" "../c" `shouldBe` "a/c"
+      go (Path.relDir "a/b") (Path.relFile "../c") $ Path.relFile "a/c"
     it "walks up directories for multiple ../" $
-      joinUntypedPaths "a/b" "../../c" `shouldBe` "c"
+      go (Path.relDir "a/b") (Path.relFile "../../c") $ Path.relFile "c"
     it "stops walking at top directory" $
-      joinUntypedPaths "a/b" "../../../c" `shouldBe` "c"
+      go (Path.relDir "a/b") (Path.relFile "../../../c" ) $ Path.relFile "c"
+  where
+    go x y z = joinPaths (Path.toAbsRel x) y `shouldBe` Path.toAbsRel z