From c4895949eed591c1c0a563e6502a9871f3102235 Mon Sep 17 00:00:00 2001
From: Chris Done <chrisdone@gmail.com>
Date: Fri, 8 May 2015 13:33:37 +0200
Subject: [PATCH] Add some operations

---
 src/Path.hs  | 83 ++++++++++++++++++++++++++++++++++++++++++++++
 test/Main.hs | 94 ++++++++++++++++++++++++++++++++++++++++++++++++----
 2 files changed, 170 insertions(+), 7 deletions(-)

diff --git a/src/Path.hs b/src/Path.hs
index cea8d7f..6977efc 100644
--- a/src/Path.hs
+++ b/src/Path.hs
@@ -23,6 +23,12 @@ module Path
   ,mkRelDir
   ,mkAbsFile
   ,mkRelFile
+  -- * Operations
+  ,(</>)
+  ,stripDir
+  ,isParentOf
+  ,parentAbs
+  ,filename
   -- * Conversion
   ,toFilePath
   )
@@ -32,6 +38,7 @@ import           Control.Exception (Exception)
 import           Control.Monad.Catch (MonadThrow(..))
 import           Data.Data
 import           Data.List
+import           Data.Maybe
 import           Language.Haskell.TH
 import           Path.Internal
 import qualified System.FilePath as FilePath
@@ -172,6 +179,82 @@ mkRelFile s =
 toFilePath :: Path b t -> FilePath
 toFilePath (Path l) = l
 
+--------------------------------------------------------------------------------
+-- Operations
+
+-- | Append two paths.
+--
+-- The following cases are valid and the equalities hold:
+--
+-- @$(mkAbsDir x) \<\/> $(mkRelDir y) = $(mkAbsDir (x ++ \"/\" ++ y))@
+--
+-- @$(mkAbsDir x) \<\/> $(mkRelFile y) = $(mkAbsFile (x ++ \"/\" ++ y))@
+--
+-- @$(mkRelDir x) \<\/> $(mkRelDir y) = $(mkRelDir (x ++ \"/\" ++ y))@
+--
+-- @$(mkRelDir x) \<\/> $(mkRelFile y) = $(mkRelFile (x ++ \"/\" ++ y))@
+--
+-- The following are proven not possible to express:
+--
+-- @$(mkAbsFile …) \<\/> x@
+--
+-- @$(mkRelFile …) \<\/> x@
+--
+-- @x \<\/> $(mkAbsFile …)@
+--
+-- @x \<\/> $(mkAbsDir …)@
+--
+(</>) :: Path b Dir -> Path Rel t -> Path b t
+(</>) (Path a) (Path b) = Path (a ++ b)
+
+-- | Strip directory from path, making it relative to that directory.
+-- Returns 'Nothing' if directory is not a parent of the path.
+--
+-- The following properties hold:
+--
+-- @stripDir parent (parent <\/> child) = child@
+--
+-- Cases which are proven not possible:
+--
+-- @stripDir (a :: Path Abs …) (b :: Path Rel …)@
+--
+-- @stripDir (a :: Path Rel) (b :: Path Abs …)@
+--
+-- In other words the bases must match.
+--
+stripDir :: Path b Dir -> Path b t -> Maybe (Path Rel t)
+stripDir (Path p) (Path l) =
+  fmap Path (stripPrefix p l)
+
+-- | Is p a parent of the given location? Implemented in terms of
+-- 'stripDir'. The bases must match.
+isParentOf :: Path b Dir -> Path b t -> Bool
+isParentOf p l =
+  isJust (stripDir p l)
+
+-- | Take the absolute parent directory from the absolute path.
+--
+-- The following properties hold:
+--
+-- @parentAbs (parent \<\/> child) == parent@
+--
+-- On the root, getting the parent is idempotent:
+--
+-- @parentAbs (parentAbs \"\/\") = \"\/\"@
+--
+parentAbs :: Path Abs t -> Path Abs t
+parentAbs (Path fp) =
+  Path (normalizeDir (FilePath.takeDirectory (FilePath.dropTrailingPathSeparator fp)))
+
+-- | Extract the relative filename from a given location.
+--
+-- The following properties hold:
+--
+-- @filename (parent \<\/> filename a) == a@
+--
+filename :: Path b File -> Path Rel File
+filename (Path l) = Path (normalizeFile (FilePath.takeFileName l))
+
 --------------------------------------------------------------------------------
 -- Internal functions
 
diff --git a/test/Main.hs b/test/Main.hs
index 7be72b1..d0c7002 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -1,11 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 -- | Test suite.
 
 module Main where
 
+import Data.Monoid
 import Path
 import Path.Internal
-
-import Data.Monoid
 import Test.Hspec
 
 -- | Test suite entry point, returns exit failure if any test fails.
@@ -14,11 +15,90 @@ main = hspec spec
 
 -- | Test suite.
 spec :: Spec
-spec = do
-  describe "Parsing: Path Abs Dir" parseAbsDirSpec
-  describe "Parsing: Path Rel Dir" parseRelDirSpec
-  describe "Parsing: Path Abs File" parseAbsFileSpec
-  describe "Parsing: Path Rel File" parseRelFileSpec
+spec =
+  do describe "Parsing: Path Abs Dir" parseAbsDirSpec
+     describe "Parsing: Path Rel Dir" parseRelDirSpec
+     describe "Parsing: Path Abs File" parseAbsFileSpec
+     describe "Parsing: Path Rel File" parseRelFileSpec
+     describe "Operations: (</>)" operationAppend
+     describe "Operations: stripDir" operationStripDir
+     describe "Operations: isParentOf" operationIsParentOf
+     describe "Operations: parentAbs" operationParentAbs
+     describe "Operations: filename" operationFilename
+
+-- | The 'filename' operation.
+operationFilename :: Spec
+operationFilename =
+  do it "filename ($(mkAbsDir parent) </> filename $(mkRelFile filename)) == $(mkRelFile filename)"
+        (filename ($(mkAbsDir "/home/chris/") </>
+                   filename $(mkRelFile "bar.txt")) ==
+         $(mkRelFile "bar.txt"))
+     it "filename ($(mkRelDir parent) </> filename $(mkRelFile filename)) == $(mkRelFile filename)"
+        (filename ($(mkRelDir "home/chris/") </>
+                   filename $(mkRelFile "bar.txt")) ==
+         $(mkRelFile "bar.txt"))
+
+-- | The 'parentAbs' operation.
+operationParentAbs :: Spec
+operationParentAbs =
+  do it "parentAbs (parent </> child) == parent"
+        (parentAbs ($(mkAbsDir "/foo") </>
+                    $(mkRelDir "bar")) ==
+         $(mkAbsDir "/foo"))
+     it "parentAbs \"\" == \"\""
+        (parentAbs $(mkAbsDir "/") ==
+         $(mkAbsDir "/"))
+     it "parentAbs (parentAbs \"\") == \"\""
+        (parentAbs (parentAbs $(mkAbsDir "/")) ==
+         $(mkAbsDir "/"))
+
+-- | The 'isParentOf' operation.
+operationIsParentOf :: Spec
+operationIsParentOf =
+  do it "isParentOf parent (parent </> child)"
+        (isParentOf
+           $(mkAbsDir "///bar/")
+           ($(mkAbsDir "///bar/") </>
+            $(mkRelFile "bar/foo.txt")))
+     it "isParentOf parent (parent </> child)"
+        (isParentOf
+           $(mkRelDir "bar/")
+           ($(mkRelDir "bar/") </>
+            $(mkRelFile "bob/foo.txt")))
+
+-- | The 'stripDir' operation.
+operationStripDir :: Spec
+operationStripDir =
+  do it "stripDir parent (parent </> child) = child"
+        (stripDir $(mkAbsDir "///bar/")
+                  ($(mkAbsDir "///bar/") </>
+                   $(mkRelFile "bar/foo.txt")) ==
+         Just $(mkRelFile "bar/foo.txt"))
+     it "stripDir parent (parent </> child) = child"
+        (stripDir $(mkRelDir "bar/")
+                  ($(mkRelDir "bar/") </>
+                   $(mkRelFile "bob/foo.txt")) ==
+         Just $(mkRelFile "bob/foo.txt"))
+
+-- | The '</>' operation.
+operationAppend :: Spec
+operationAppend =
+  do it "AbsDir + RelDir = AbsDir"
+        ($(mkAbsDir "/home/") </>
+         $(mkRelDir "chris") ==
+         $(mkAbsDir "/home/chris/"))
+     it "AbsDir + RelFile = AbsFile"
+        ($(mkAbsDir "/home/") </>
+         $(mkRelFile "chris/test.txt") ==
+         $(mkAbsFile "/home/chris/test.txt"))
+     it "RelDir + RelDir = RelDir"
+        ($(mkRelDir "home/") </>
+         $(mkRelDir "chris") ==
+         $(mkRelDir "home/chris"))
+     it "RelDir + RelFile = RelFile"
+        ($(mkRelDir "home/") </>
+         $(mkRelFile "chris/test.txt") ==
+         $(mkRelFile "home/chris/test.txt"))
 
 -- | Tests for the tokenizer.
 parseAbsDirSpec :: Spec