Fork chrisdone's path library

I wasn't happy with the way it dealt with Dir vs File things. In his
version of the library, a `Path b Dir` always ends with a trailing
path separator and `Path b File` never ends with a trailing path separator.

IMO, it is nonsensical to make a Dir vs File distinction on path level,
although it first seems nice.
Some of the reasons are:
* a path is just that: a path. It is completely disconnected from IO level
  and even if a `Dir`/`File` type theoretically allows us to say "this path
  ought to point to a file", there is literally zero guarantee that it will
  hold true at runtime. So this basically gives a false feeling of a
  type-safe file distinction.
* it's imprecise about Dir vs File distinction, which makes it even worse,
  because a directory is also a file (just not a regular file). Add symlinks
  to that and the confusion is complete.
* it makes the API oddly complicated for use cases where we basically don't
  care (yet) whether something turns out to be a directory or not

Still, it comes also with a few perks:
* it simplifies some functions, because they now have guarantees whether a
  path ends in a trailing path separator or not
* it may be safer for interaction with other library functions, which behave
  differently depending on a trailing path separator (like probably shelly)

Not limited to, but also in order to fix my remarks without breaking any
benefits, I did:
* rename the `Dir`/`File` types to `TPS`/`NoTPS`, so it's clear we are only
  giving information about trailing path separators and not actual file
  types we don't know about yet
* add a `MaybeTPS` type, which does not mess with trailing path separators
  and also gives no guarantees about them... then added `toNoTPS` and
  `toTPS` to allow type-safe conversion
* make some functions accept more general types, so we don't unnecessarily
  force paths with trailing separators for `(</>)` for example... instead
  these functions now examine the paths to still have correct behavior.
  This is really minor overhead. You might say now "but then I can append
  filepath to filepath". Well, as I said... we don't know whether it's a
  "filepath" at all.
* merge `filename` and `dirname` into `basename` and make `parent` be
  `dirname`, so the function names match the name of the POSIX ones,
  which do (almost) the same...
* fix a bug in `basename` (formerly `dirname`) which broke the type
  guarantees
* add a pattern synonym for easier pattern matching without exporting
  the internal Path constructor

.gitignore

@@ -7,3 +7,6 @@ cabal-dev/
 TAGS
 tags
 *.tag
+.stack-work/
+.cabal-sandbox/
+cabal.sandbox.config

CHANGELOG

@@ -1,4 +1,33 @@
+0.5.8:
+	* First version of the fork.
+0.5.7:
+	* Fix haddock problem.
+0.5.6:
+	* Reject only .. and .
+0.5.5:
+	* Use filepath's isValid function for additional sanity checks
+0.5.4:
+	* Disable parsing of path consisting only of "."
+	* Add NFData instance for Path
+	* Some typo/docs improvements
+	* Add standard headers to modules
+0.5.3:
+	* Added conversion functions.
+
 0.2.0:
 
         * Rename parentAbs to simply parent.
 	* Add dirname.
+
+0.3.0:
+	* Removed Generic instance.
+
+0.4.0:
+	* Implemented stricter parsing, disabling use of "..".
+	* Made stripDir generic over MonadThrow
+
+0.5.0:
+	* Fix stripDir p p /= Nothing bug.
+
+0.5.2:
+	* Removed unused DeriveGeneric.

LICENSE

@@ -1,4 +1,5 @@
-Copyright (c) 2015, FP Complete
+Copyright (c) 2015–2016, FP Complete
+Copyright (c) 2016, Julian Ospald
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without

README.md

@@ -1,4 +1,80 @@
-path
-=====
+# HPath
 
 Support for well-typed paths in Haskell.
+
+## Motivation
+
+The motivation came during development of
+[hsfm](https://github.com/hasufell/hsfm)
+which has a pretty strict File type, but lacks a strict Path type, e.g.
+for user input.
+
+The library that came closest to my needs was
+[path](https://github.com/chrisdone/path),
+but the API turned out to be oddly complicated for my use case, so I
+decided to fork it.
+
+## Differences to 'path'
+
+I wasn't happy with the way it dealt with Dir vs File things. In his
+version of the library, a `Path b Dir` always ends with a trailing
+path separator and `Path b File` never ends with a trailing path separator.
+
+IMO, it is nonsensical to make a Dir vs File distinction on path level,
+although it first seems nice.
+Some of the reasons are:
+* a path is just that: a path. It is completely disconnected from IO level
+  and even if a `Dir`/`File` type theoretically allows us to say "this path
+  ought to point to a file", there is literally zero guarantee that it will
+  hold true at runtime. So this basically gives a false feeling of a
+  type-safe file distinction.
+* it's imprecise about Dir vs File distinction, which makes it even worse,
+  because a directory is also a file (just not a regular file). Add symlinks
+  to that and the confusion is complete.
+* it makes the API oddly complicated for use cases where we basically don't
+  care (yet) whether something turns out to be a directory or not
+
+Still, it comes also with a few perks:
+* it simplifies some functions, because they now have guarantees whether a
+  path ends in a trailing path separator or not
+* it may be safer for interaction with other library functions, which behave
+  differently depending on a trailing path separator (like probably shelly)
+
+Not limited to, but also in order to fix my remarks without breaking any
+benefits, I did:
+* rename the `Dir`/`File` types to `TPS`/`NoTPS`, so it's clear we are only
+  giving information about trailing path separators and not actual file
+  types we don't know about yet
+* add a `MaybeTPS` type, which does not mess with trailing path separators
+  and also gives no guarantees about them... then added `toNoTPS` and
+  `toTPS` to allow type-safe conversion
+* make some functions accept more general types, so we don't unnecessarily
+  force paths with trailing separators for `(</>)` for example... instead
+  these functions now examine the paths to still have correct behavior.
+  This is really minor overhead. You might say now "but then I can append
+  filepath to filepath". Well, as I said... we don't know whether it's a
+  "filepath" at all.
+* merge `filename` and `dirname` into `basename` and make `parent` be
+  `dirname`, so the function names match the name of the POSIX ones,
+  which do (almost) the same...
+* fix a bug in `basename` (formerly `dirname`) which broke the type
+  guarantees
+* add a pattern synonym for easier pattern matching without exporting
+  the internal Path constructor
+
+## Consequences
+
+So what does that mean? Well, it means that this library does not and
+cannot make any guarantees about what a filepath is meant for or what
+it might point to. And it doesn't pretend it can.
+
+So when you strip the trailing path separator of a path that points to a
+directory  and then shove it into some function which expects a regular
+file... then that function will very likely blow up. That's the nature of IO.
+There is no type that can save you from interfacing such low-level libraries.
+The filesystem is in constant change. What might have been a regular file
+2 seconds ago, can now be a directory or a symlink.
+That means you need a proper File type that is tied to your IO code.
+This is what [hsfm](https://github.com/hasufell/hsfm) does. It currently
+is not a library, maybe it will be in the future.
+

hpath.cabal

@@ -0,0 +1,37 @@
+name:                hpath
+version:             0.5.8
+synopsis:            Support for well-typed paths
+description:         Support for will-typed paths.
+license:             BSD3
+license-file:        LICENSE
+author:              Julian Ospald <hasufell@posteo.de>
+maintainer:          Julian Ospald <hasufell@posteo.de>
+copyright:           2015–2016 FP Complete, Julian Ospald 2016
+category:            Filesystem
+build-type:          Simple
+cabal-version:       >=1.8
+extra-source-files:  README.md, CHANGELOG
+
+library
+  hs-source-dirs:    src/
+  ghc-options:       -Wall -O2
+  exposed-modules:   HPath, HPath.Internal
+  build-depends:     base >= 4 && <5
+                   , exceptions
+                   , filepath
+                   , template-haskell
+                   , deepseq
+
+test-suite test
+    type: exitcode-stdio-1.0
+    main-is: Main.hs
+    hs-source-dirs: test
+    build-depends: HUnit
+                 , base
+                 , hspec
+                 , mtl
+                 , hpath
+
+source-repository head
+    type:     git
+    location: https://github.com/hasufell/hpath

path.cabal

@@ -1,31 +0,0 @@
-name:                path
-version:             0.2.0
-synopsis:            Path
-description:         Path
-license:             BSD3
-license-file:        LICENSE
-author:              Chris Done
-maintainer:          chrisdone@fpcomplete.com
-copyright:           2015 FP Complete
-category:            Filesystem
-build-type:          Simple
-cabal-version:       >=1.8
-
-library
-  hs-source-dirs:    src/
-  ghc-options:       -Wall -O2
-  exposed-modules:   Path, Path.Internal
-  build-depends:     base >= 4 && <5
-                   , exceptions
-                   , filepath
-                   , template-haskell
-
-test-suite test
-    type: exitcode-stdio-1.0
-    main-is: Main.hs
-    hs-source-dirs: test
-    build-depends: HUnit
-                 , base
-                 , hspec
-                 , mtl
-                 , path

src/HPath.hs

@@ -0,0 +1,415 @@
+-- |
+-- Module      :  HPath
+-- Copyright   :  © 2015–2016 FP Complete, 2016 Julian Ospald
+-- License     :  BSD 3 clause
+--
+-- Maintainer  :  Julian Ospald <hasufell@posteo.de>
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- Support for well-typed paths.
+
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module HPath
+  (
+  -- * Types
+   Abs
+  ,NoTPS
+  ,Path
+  ,Rel
+  ,TPS
+  -- * PatternSynonyms/ViewPatterns
+  ,pattern Path
+   -- * Parsing
+  ,PathParseException
+  ,parseAbsMaybeTPS
+  ,parseAbsNoTPS
+  ,parseAbsTPS
+  ,parseRelMaybeTPS
+  ,parseRelNoTPS
+  ,parseRelTPS
+  -- * Constructors
+  ,mkAbsMaybeTPS
+  ,mkAbsNoTPS
+  ,mkAbsTPS
+  ,mkRelMaybeTPS
+  ,mkRelNoTPS
+  ,mkRelTPS
+  -- * Operations
+  ,(</>)
+  ,basename
+  ,dirname
+  ,isParentOf
+  ,stripDir
+  -- * Conversion
+  ,fromAbsMaybeTPS
+  ,fromAbsNoTPS
+  ,fromAbsTPS
+  ,fromRelMaybeTPS
+  ,fromRelNoTPS
+  ,fromRelTPS
+  ,toFilePath
+  ,toNoTPS
+  ,toTPS
+  )
+  where
+
+import           Control.Exception (Exception)
+import           Control.Monad.Catch (MonadThrow(..))
+import           Data.Data
+import           Data.List
+import           Data.Maybe
+import           Language.Haskell.TH
+import           HPath.Internal
+import qualified System.FilePath as FilePath
+
+--------------------------------------------------------------------------------
+-- Types
+
+-- | An absolute path.
+data Abs deriving (Typeable)
+
+-- | A relative path; one without a root.
+data Rel deriving (Typeable)
+
+-- | A path without trailing separator.
+data NoTPS deriving (Typeable)
+
+-- | A path with trailing separator.
+data TPS deriving (Typeable)
+
+-- | A path without any guarantee about whether it ends in a
+-- trailing path separators. Use `toTPS` and `toNoTPS`
+-- if that guarantee is required.
+data MaybeTPS deriving (Typeable)
+
+-- | Exception when parsing a location.
+data PathParseException
+  = InvalidAbsTPS FilePath
+  | InvalidRelTPS FilePath
+  | InvalidAbsNoTPS FilePath
+  | InvalidRelNoTPS FilePath
+  | InvalidAbsMaybeTPS FilePath
+  | InvalidRelMaybeTPS FilePath
+  | Couldn'tStripPrefixTPS FilePath FilePath
+  deriving (Show,Typeable)
+instance Exception PathParseException
+
+--------------------------------------------------------------------------------
+-- PatternSynonyms
+
+pattern Path x <- (MkPath x)
+
+--------------------------------------------------------------------------------
+-- Parsers
+
+-- | Get a location for an absolute path. Produces a normalized
+--  path which always ends in a path separator.
+--
+-- Throws: 'PathParseException'
+--
+parseAbsTPS :: MonadThrow m
+            => FilePath -> m (Path Abs TPS)
+parseAbsTPS filepath =
+  if FilePath.isAbsolute filepath &&
+     not (null (normalizeTPS filepath)) &&
+     not ("~/" `isPrefixOf` filepath) &&
+     not (hasParentDir filepath) &&
+     FilePath.isValid filepath
+     then return (MkPath (normalizeTPS filepath))
+     else throwM (InvalidAbsTPS filepath)
+
+-- | Get a location for a relative path. Produces a normalized
+-- path which always ends in a path separator.
+--
+-- Note that @filepath@ may contain any number of @./@ but may not consist
+-- solely of @./@.  It also may not contain a single @..@ anywhere.
+--
+-- Throws: 'PathParseException'
+--
+parseRelTPS :: MonadThrow m
+            => FilePath -> m (Path Rel TPS)
+parseRelTPS filepath =
+  if not (FilePath.isAbsolute filepath) &&
+     not (null filepath) &&
+     not ("~/" `isPrefixOf` filepath) &&
+     not (hasParentDir filepath) &&
+     not (null (normalizeTPS filepath)) &&
+     filepath /= "." && filepath /= ".." &&
+     FilePath.isValid filepath
+     then return (MkPath (normalizeTPS filepath))
+     else throwM (InvalidRelTPS filepath)
+
+-- | Get a location for an absolute path, which must not end with a trailing
+-- path separator.
+--
+-- Throws: 'PathParseException'
+--
+parseAbsNoTPS :: MonadThrow m
+              => FilePath -> m (Path Abs NoTPS)
+parseAbsNoTPS filepath =
+  if FilePath.isAbsolute filepath &&
+     not (FilePath.hasTrailingPathSeparator filepath) &&
+     not ("~/" `isPrefixOf` filepath) &&
+     not (hasParentDir filepath) &&
+     not (null (normalizeNoTPS filepath)) &&
+     FilePath.isValid filepath
+     then return (MkPath (normalizeNoTPS filepath))
+     else throwM (InvalidAbsNoTPS filepath)
+
+-- | Get a location for a relative path, which must not end with a trailing
+-- path separator.
+--
+-- Note that @filepath@ may contain any number of @./@ but may not contain a
+-- single @..@ anywhere.
+--
+-- Throws: 'PathParseException'
+--
+parseRelNoTPS :: MonadThrow m
+              => FilePath -> m (Path Rel NoTPS)
+parseRelNoTPS filepath =
+  if not (FilePath.isAbsolute filepath ||
+          FilePath.hasTrailingPathSeparator filepath) &&
+     not (null filepath) &&
+     not ("~/" `isPrefixOf` filepath) &&
+     not (hasParentDir filepath) &&
+     not (null (normalizeNoTPS filepath)) &&
+     filepath /= "." && filepath /= ".." &&
+     FilePath.isValid filepath
+     then return (MkPath (normalizeNoTPS filepath))
+     else throwM (InvalidRelNoTPS filepath)
+
+-- | Get a location for an absolute path that may or may not end in a trailing
+-- path separator. Use `toTPS` and `toNoTPS` if that guarantee is required.
+--
+-- Throws: 'PathParseException'
+--
+parseAbsMaybeTPS :: MonadThrow m
+                 => FilePath -> m (Path Abs MaybeTPS)
+parseAbsMaybeTPS filepath =
+  if FilePath.isAbsolute filepath &&
+     not ("~/" `isPrefixOf` filepath) &&
+     not (hasParentDir filepath) &&
+     not (null (normalizeNoTPS filepath)) &&
+     FilePath.isValid filepath
+     then return (MkPath (normalizeNoTPS filepath))
+     else throwM (InvalidAbsMaybeTPS filepath)
+
+-- | Get a location for a relative path that may or may not end in a trailing
+-- path separator. Use `toTPS` and `toNoTPS` if that guarantee is required.
+--
+-- Note that @filepath@ may contain any number of @./@ but may not contain a
+-- single @..@ anywhere.
+--
+-- Throws: 'PathParseException'
+--
+parseRelMaybeTPS :: MonadThrow m
+                 => FilePath -> m (Path Rel MaybeTPS)
+parseRelMaybeTPS filepath =
+  if not (FilePath.isAbsolute filepath) &&
+     not (null filepath) &&
+     not ("~/" `isPrefixOf` filepath) &&
+     not (hasParentDir filepath) &&
+     not (null (normalizeNoTPS filepath)) &&
+     filepath /= "." && filepath /= ".." &&
+     FilePath.isValid filepath
+     then return (MkPath (normalizeNoTPS filepath))
+     else throwM (InvalidRelMaybeTPS filepath)
+
+-- | Helper function: check if the filepath has any parent directories in it.
+-- This handles the logic of checking for different path separators on Windows.
+hasParentDir :: FilePath -> Bool
+hasParentDir filepath' =
+     ("/.." `isSuffixOf` filepath) ||
+     ("/../" `isInfixOf` filepath) ||
+     ("../" `isPrefixOf` filepath)
+  where
+    filepath =
+        case FilePath.pathSeparator of
+            '/' -> filepath'
+            x   -> map (\y -> if x == y then '/' else y) filepath'
+
+--------------------------------------------------------------------------------
+-- Constructors
+
+-- | Make a 'Path Abs TPS'.
+--
+-- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@)
+-- may compile on your platform, but it may not compile on another
+-- platform (Windows).
+mkAbsTPS :: FilePath -> Q Exp
+mkAbsTPS s =
+  case parseAbsTPS s of
+    Left err -> error (show err)
+    Right (MkPath str) ->
+      [|MkPath $(return (LitE (StringL str))) :: Path Abs TPS|]
+
+-- | Make a 'Path Rel TPS'.
+mkRelTPS :: FilePath -> Q Exp
+mkRelTPS s =
+  case parseRelTPS s of
+    Left err -> error (show err)
+    Right (MkPath str) ->
+      [|MkPath $(return (LitE (StringL str))) :: Path Rel TPS|]
+
+-- | Make a 'Path Abs NoTPS'.
+--
+-- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@)
+-- may compile on your platform, but it may not compile on another
+-- platform (Windows).
+mkAbsNoTPS :: FilePath -> Q Exp
+mkAbsNoTPS s =
+  case parseAbsNoTPS s of
+    Left err -> error (show err)
+    Right (MkPath str) ->
+      [|MkPath $(return (LitE (StringL str))) :: Path Abs NoTPS|]
+
+-- | Make a 'Path Rel NoTPS'.
+mkRelNoTPS :: FilePath -> Q Exp
+mkRelNoTPS s =
+  case parseRelNoTPS s of
+    Left err -> error (show err)
+    Right (MkPath str) ->
+      [|MkPath $(return (LitE (StringL str))) :: Path Rel NoTPS|]
+
+-- | Make a 'Path Rel MaybeTPS'.
+mkAbsMaybeTPS :: FilePath -> Q Exp
+mkAbsMaybeTPS s =
+  case parseAbsMaybeTPS s of
+    Left err -> error (show err)
+    Right (MkPath str) ->
+      [|MkPath $(return (LitE (StringL str))) :: Path Abs MaybeTPS|]
+
+-- | Make a 'Path Rel MaybeTPS'.
+mkRelMaybeTPS :: FilePath -> Q Exp
+mkRelMaybeTPS s =
+  case parseRelMaybeTPS s of
+    Left err -> error (show err)
+    Right (MkPath str) ->
+      [|MkPath $(return (LitE (StringL str))) :: Path Rel MaybeTPS|]
+
+--------------------------------------------------------------------------------
+-- Conversion
+
+-- | Convert to a 'FilePath' type.
+--
+-- All TPS data types have a trailing slash, so if you want no trailing
+-- slash, you can use 'System.FilePath.dropTrailingPathSeparator' from
+-- the filepath package.
+toFilePath :: Path b t -> FilePath
+toFilePath (MkPath l) = l
+
+fromAbsTPS :: Path Abs TPS -> FilePath
+fromAbsTPS = toFilePath
+
+fromRelTPS :: Path Rel TPS -> FilePath
+fromRelTPS = toFilePath
+
+fromAbsNoTPS :: Path Abs NoTPS -> FilePath
+fromAbsNoTPS = toFilePath
+
+fromRelNoTPS :: Path Rel NoTPS -> FilePath
+fromRelNoTPS = toFilePath
+
+fromAbsMaybeTPS :: Path Abs MaybeTPS -> FilePath
+fromAbsMaybeTPS = toFilePath
+
+fromRelMaybeTPS :: Path Rel MaybeTPS -> FilePath
+fromRelMaybeTPS = toFilePath
+
+toTPS :: Path b MaybeTPS -> Path b TPS
+toTPS (MkPath l) = MkPath (FilePath.addTrailingPathSeparator l)
+
+toNoTPS :: Path b MaybeTPS -> Path b NoTPS
+toNoTPS (MkPath l) = MkPath (FilePath.dropTrailingPathSeparator l)
+
+--------------------------------------------------------------------------------
+-- Operations
+
+-- | Append two paths.
+--
+-- The second argument must always be a relative path, which ensures
+-- that undefinable things like `"/abc" </> "/def"` cannot happen.
+--
+-- Technically, the first argument can be a path that points to a non-directory,
+-- because this library is IO-agnostic and makes no assumptions about
+-- file types.
+(</>) :: Path b t1 -> Path Rel t2 -> Path b t2
+(</>) (MkPath a) (MkPath b) = MkPath (a' ++ b)
+  where
+    a' = FilePath.addTrailingPathSeparator a
+
+-- | Strip directory from path, making it relative to that directory.
+-- Throws 'Couldn'tStripPrefixDir' if directory is not a parent of the path.
+--
+-- The bases must match.
+--
+stripDir :: MonadThrow m
+         => Path b t1 -> Path b t2 -> m (Path Rel t2)
+stripDir (MkPath p) (MkPath l) =
+  case stripPrefix p' l of
+    Nothing -> throwM (Couldn'tStripPrefixTPS p' l)
+    Just "" -> throwM (Couldn'tStripPrefixTPS p' l)
+    Just ok -> return (MkPath ok)
+  where
+    p' = FilePath.addTrailingPathSeparator p
+
+-- | Is p a parent of the given location? Implemented in terms of
+-- 'stripDir'. The bases must match.
+isParentOf :: Path b t1 -> Path b t2 -> Bool
+isParentOf p l =
+  isJust (stripDir p l)
+
+-- | Extract the directory name of a path.
+--
+-- The following properties hold:
+--
+-- @dirname (p \<\/> a) == dirname p@
+--
+dirname :: Path Abs t -> Path Abs TPS
+dirname (MkPath fp) = MkPath (normalizeTPS (FilePath.takeDirectory $ FilePath.dropTrailingPathSeparator fp))
+
+-- | Extract the file part of a path.
+--
+-- Throws InvalidRelTPS if it's passed e.g. '/', because there is no
+-- basename for that and it would break the `Path Rel t` type.
+--
+-- The following properties hold:
+--
+-- @basename (p \<\/> a) == basename a@
+--
+basename :: MonadThrow m => Path b t -> m (Path Rel t)
+basename (MkPath l)
+  | not (FilePath.isAbsolute rl) = return $ MkPath rl
+  | otherwise                    = throwM (InvalidRelTPS rl)
+  where
+    rl = case FilePath.hasTrailingPathSeparator l of
+           True  -> last (FilePath.splitPath l)
+           False -> normalizeNoTPS (FilePath.takeFileName l)
+
+--------------------------------------------------------------------------------
+-- Internal functions
+
+-- | Internal use for normalizing a path while always adding
+-- a trailing path separator.
+normalizeTPS :: FilePath -> FilePath
+normalizeTPS =
+  clean . FilePath.addTrailingPathSeparator . FilePath.normalise
+  where clean "./" = ""
+        clean ('/':'/':xs) = clean ('/':xs)
+        clean x = x
+
+-- | Internal use for normalizing a path without adding or removing
+-- a trailing path separator.
+normalizeNoTPS :: FilePath -> FilePath
+normalizeNoTPS =
+  clean . FilePath.normalise
+  where clean "./" = ""
+        clean ('/':'/':xs) = clean ('/':xs)
+        clean x = x
+

src/HPath/Internal.hs

@@ -1,28 +1,25 @@
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 -- | Internal types and functions.
 
-module Path.Internal
+module HPath.Internal
   (Path(..))
   where
 
+import Control.DeepSeq (NFData (..))
 import Data.Data
-import GHC.Generics
 
 -- | Path of some base and type.
 --
 -- Internally is a string. The string can be of two formats only:
 --
--- 1. File format: @file.txt@, @foo\/bar.txt@, @\/foo\/bar.txt@
--- 2. Directory format: @foo\/@, @\/foo\/bar\/@
+-- 1. without trailing path separator: @file.txt@, @foo\/bar.txt@, @\/foo\/bar.txt@
+-- 2. with trailing path separator: @foo\/@, @\/foo\/bar\/@
 --
--- All directories end in a trailing separator. There are no duplicate
+-- There are no duplicate
 -- path separators @\/\/@, no @..@, no @.\/@, no @~\/@, etc.
-newtype Path b t = Path FilePath
-  deriving (Typeable,Generic)
+data Path b t = MkPath FilePath
+  deriving (Typeable)
 
 -- | String equality.
 --
@@ -30,7 +27,7 @@ newtype Path b t = Path FilePath
 --
 -- @show x == show y ≡ x == y@
 instance Eq (Path b t) where
-  (==) (Path x) (Path y) = x == y
+  (==) (MkPath x) (MkPath y) = x == y
 
 -- | String ordering.
 --
@@ -38,7 +35,7 @@ instance Eq (Path b t) where
 --
 -- @show x \`compare\` show y ≡ x \`compare\` y@
 instance Ord (Path b t) where
-  compare (Path x) (Path y) = compare x y
+  compare (MkPath x) (MkPath y) = compare x y
 
 -- | Same as 'Path.toFilePath'.
 --
@@ -46,4 +43,8 @@ instance Ord (Path b t) where
 --
 -- @x == y ≡ show x == show y@
 instance Show (Path b t) where
-  show (Path x) = show x
+  show (MkPath x) = show x
+
+instance NFData (Path b t) where
+  rnf (MkPath x) = rnf x
+

src/Path.hs

@@ -1,285 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE EmptyDataDecls #-}
-
--- | A normalizing well-typed path type.
-
-module Path
-  (-- * Types
-   Path
-  ,Abs
-  ,Rel
-  ,File
-  ,Dir
-   -- * Parsing
-  ,parseAbsDir
-  ,parseRelDir
-  ,parseAbsFile
-  ,parseRelFile
-  ,PathParseException
-  -- * Constructors
-  ,mkAbsDir
-  ,mkRelDir
-  ,mkAbsFile
-  ,mkRelFile
-  -- * Operations
-  ,(</>)
-  ,stripDir
-  ,isParentOf
-  ,parent
-  ,filename
-  ,dirname
-  -- * Conversion
-  ,toFilePath
-  )
-  where
-
-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
-
---------------------------------------------------------------------------------
--- Types
-
--- | An absolute path.
-data Abs deriving (Typeable)
-
--- | A relative path; one without a root.
-data Rel deriving (Typeable)
-
--- | A file path.
-data File deriving (Typeable)
-
--- | A directory path.
-data Dir deriving (Typeable)
-
--- | Exception when parsing a location.
-data PathParseException
-  = InvalidAbsDir FilePath
-  | InvalidRelDir FilePath
-  | InvalidAbsFile FilePath
-  | InvalidRelFile FilePath
-  deriving (Show,Typeable)
-instance Exception PathParseException
-
---------------------------------------------------------------------------------
--- Parsers
-
--- | Get a location for an absolute directory. Produces a normalized
---  path which always ends in a path separator.
---
--- Throws: 'PathParseException'
---
-parseAbsDir :: MonadThrow m
-            => FilePath -> m (Path Abs Dir)
-parseAbsDir filepath =
-  if FilePath.isAbsolute filepath &&
-     not (null (normalizeDir filepath)) &&
-     not (isPrefixOf "~/" filepath)
-     then return (Path (normalizeDir filepath))
-     else throwM (InvalidAbsDir filepath)
-
--- | Get a location for a relative directory. Produces a normalized
--- path which always ends in a path separator.
---
--- Throws: 'PathParseException'
---
-parseRelDir :: MonadThrow m
-            => FilePath -> m (Path Rel Dir)
-parseRelDir filepath =
-  if not (FilePath.isAbsolute filepath) &&
-     not (null filepath) &&
-     not (isPrefixOf "~/" filepath) &&
-     not (null (normalizeDir filepath))
-     then return (Path (normalizeDir filepath))
-     else throwM (InvalidRelDir filepath)
-
--- | Get a location for an absolute file.
---
--- Throws: 'PathParseException'
---
-parseAbsFile :: MonadThrow m
-             => FilePath -> m (Path Abs File)
-parseAbsFile filepath =
-  if FilePath.isAbsolute filepath &&
-     not (FilePath.hasTrailingPathSeparator filepath) &&
-     not (isPrefixOf "~/" filepath) &&
-     not (null (normalizeFile filepath))
-     then return (Path (normalizeFile filepath))
-     else throwM (InvalidAbsFile filepath)
-
--- | Get a location for a relative file.
---
--- Throws: 'PathParseException'
---
-parseRelFile :: MonadThrow m
-             => FilePath -> m (Path Rel File)
-parseRelFile filepath =
-  if not (FilePath.isAbsolute filepath || FilePath.hasTrailingPathSeparator filepath) &&
-     not (null filepath) &&
-     not (isPrefixOf "~/" filepath) &&
-     not (null (normalizeFile filepath))
-     then return (Path (normalizeFile filepath))
-     else throwM (InvalidRelFile filepath)
-
---------------------------------------------------------------------------------
--- Constructors
-
--- | Make a 'Path Abs Dir'.
---
--- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@)
--- may compile on your platform, but it may not compile on another
--- platform (Windows).
-mkAbsDir :: FilePath -> Q Exp
-mkAbsDir s =
-  case parseAbsDir s of
-    Left err -> error (show err)
-    Right (Path str) ->
-      [|Path $(return (LitE (StringL str))) :: Path Abs Dir|]
-
--- | Make a 'Path Rel Dir'.
-mkRelDir :: FilePath -> Q Exp
-mkRelDir s =
-  case parseRelDir s of
-    Left err -> error (show err)
-    Right (Path str) ->
-      [|Path $(return (LitE (StringL str))) :: Path Rel Dir|]
-
--- | Make a 'Path Abs File'.
---
--- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@)
--- may compile on your platform, but it may not compile on another
--- platform (Windows).
-mkAbsFile :: FilePath -> Q Exp
-mkAbsFile s =
-  case parseAbsFile s of
-    Left err -> error (show err)
-    Right (Path str) ->
-      [|Path $(return (LitE (StringL str))) :: Path Abs File|]
-
--- | Make a 'Path Rel File'.
-mkRelFile :: FilePath -> Q Exp
-mkRelFile s =
-  case parseRelFile s of
-    Left err -> error (show err)
-    Right (Path str) ->
-      [|Path $(return (LitE (StringL str))) :: Path Rel File|]
-
---------------------------------------------------------------------------------
--- Conversion
-
--- | Convert to a 'FilePath' type.
-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:
---
--- @parent (parent \<\/> child) == parent@
---
--- On the root, getting the parent is idempotent:
---
--- @parent (parent \"\/\") = \"\/\"@
---
-parent :: Path Abs t -> Path Abs Dir
-parent (Path fp) =
-  Path (normalizeDir (FilePath.takeDirectory (FilePath.dropTrailingPathSeparator fp)))
-
--- | Extract the file part of a path.
---
--- The following properties hold:
---
--- @filename (parent \<\/> filename a) == a@
---
-filename :: Path b File -> Path Rel File
-filename (Path l) =
-  Path (normalizeFile (FilePath.takeFileName l))
-
--- | Extract the last directory name of a path.
---
--- The following properties hold:
---
--- @dirname (parent \<\/> dirname a) == a@
---
-dirname :: Path b Dir -> Path Rel Dir
-dirname (Path l) =
-  Path (last (FilePath.splitPath l))
-
---------------------------------------------------------------------------------
--- Internal functions
-
--- | Internal use for normalizing a directory.
-normalizeDir :: FilePath -> FilePath
-normalizeDir =
-  clean . FilePath.addTrailingPathSeparator . FilePath.normalise
-  where clean "./" = ""
-        clean ('/':'/':xs) = clean ('/':xs)
-        clean x = x
-
--- | Internal use for normalizing a fileectory.
-normalizeFile :: FilePath -> FilePath
-normalizeFile =
-  clean . FilePath.normalise
-  where clean "./" = ""
-        clean ('/':'/':xs) = clean ('/':xs)
-        clean x = x

test/Main.hs

@@ -4,9 +4,12 @@
 
 module Main where
 
+import Control.Applicative
+import Control.Monad
+import Data.Maybe
 import Data.Monoid
-import Path
-import Path.Internal
+import HPath
+import HPath.Internal
 import Test.Hspec
 
 -- | Test suite entry point, returns exit failure if any test fails.
@@ -16,129 +19,157 @@ 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
+  do describe "Parsing: Path Abs Dir" parseAbsTPSSpec
+     describe "Parsing: Path Rel Dir" parseRelTPSSpec
+     describe "Parsing: Path Abs File" parseAbsNoTPSSpec
+     describe "Parsing: Path Rel File" parseRelNoTPSSpec
      describe "Operations: (</>)" operationAppend
      describe "Operations: stripDir" operationStripDir
      describe "Operations: isParentOf" operationIsParentOf
-     describe "Operations: parentAbs" operationParentAbs
-     describe "Operations: filename" operationFilename
+     describe "Operations: dirname" operationDirname
+     describe "Operations: basename" operationBasename
+     describe "Restrictions" restrictions
 
--- | 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"))
+-- | Restricting the input of any tricks.
+restrictions :: Spec
+restrictions =
+  do parseFails "~/"
+     parseFails "~/foo"
+     parseFails "~/foo/bar"
+     parseFails "../"
+     parseFails ".."
+     parseFails "."
+     parseFails "/.."
+     parseFails "/foo/../bar/"
+     parseFails "/foo/bar/.."
+  where parseFails x =
+          it (show x ++ " should be rejected")
+             (isNothing (void (parseAbsTPS x) <|>
+                         void (parseRelTPS x) <|>
+                         void (parseAbsNoTPS x) <|>
+                         void (parseRelNoTPS x)))
 
--- | The 'parentAbs' operation.
-operationParentAbs :: Spec
-operationParentAbs =
-  do it "parentAbs (parent </> child) == parent"
-        (parent ($(mkAbsDir "/foo") </>
-                    $(mkRelDir "bar")) ==
-         $(mkAbsDir "/foo"))
-     it "parent \"\" == \"\""
-        (parent $(mkAbsDir "/") ==
-         $(mkAbsDir "/"))
-     it "parent (parent \"\") == \"\""
-        (parent (parent $(mkAbsDir "/")) ==
-         $(mkAbsDir "/"))
+-- | The 'basename' operation.
+operationBasename :: Spec
+operationBasename =
+  do it "basename ($(mkAbsTPS parent) </> basename $(mkRelNoTPS filename)) == $(mkRelNoTPS filename)"
+        ((basename =<< ($(mkAbsTPS "/home/hasufell/") </>)
+                        <$> basename $(mkRelNoTPS "bar.txt")) ==
+         Just $(mkRelNoTPS "bar.txt"))
+     it "basename ($(mkRelTPS parent) </> basename $(mkRelNoTPS filename)) == $(mkRelNoTPS filename)"
+        ((basename =<< ($(mkRelTPS "home/hasufell/") </>)
+                        <$> basename $(mkRelNoTPS "bar.txt")) ==
+         Just $(mkRelNoTPS "bar.txt"))
+
+-- | The 'dirname' operation.
+operationDirname :: Spec
+operationDirname =
+  do it "dirname (parent </> child) == parent"
+        (dirname ($(mkAbsTPS "/foo") </>
+                    $(mkRelTPS "bar")) ==
+         $(mkAbsTPS "/foo"))
+     it "dirname \"\" == \"\""
+        (dirname $(mkAbsTPS "/") ==
+         $(mkAbsTPS "/"))
+     it "dirname (parent \"\") == \"\""
+        (dirname (dirname $(mkAbsTPS "/")) ==
+         $(mkAbsTPS "/"))
 
 -- | The 'isParentOf' operation.
 operationIsParentOf :: Spec
 operationIsParentOf =
   do it "isParentOf parent (parent </> child)"
         (isParentOf
-           $(mkAbsDir "///bar/")
-           ($(mkAbsDir "///bar/") </>
-            $(mkRelFile "bar/foo.txt")))
+           $(mkAbsTPS "///bar/")
+           ($(mkAbsTPS "///bar/") </>
+            $(mkRelNoTPS "bar/foo.txt")))
      it "isParentOf parent (parent </> child)"
         (isParentOf
-           $(mkRelDir "bar/")
-           ($(mkRelDir "bar/") </>
-            $(mkRelFile "bob/foo.txt")))
+           $(mkRelTPS "bar/")
+           ($(mkRelTPS "bar/") </>
+            $(mkRelNoTPS "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"))
+        (stripDir $(mkAbsTPS "///bar/")
+                  ($(mkAbsTPS "///bar/") </>
+                   $(mkRelNoTPS "bar/foo.txt")) ==
+         Just $(mkRelNoTPS "bar/foo.txt"))
      it "stripDir parent (parent </> child) = child"
-        (stripDir $(mkRelDir "bar/")
-                  ($(mkRelDir "bar/") </>
-                   $(mkRelFile "bob/foo.txt")) ==
-         Just $(mkRelFile "bob/foo.txt"))
+        (stripDir $(mkRelTPS "bar/")
+                  ($(mkRelTPS "bar/") </>
+                   $(mkRelNoTPS "bob/foo.txt")) ==
+         Just $(mkRelNoTPS "bob/foo.txt"))
+     it "stripDir parent parent = _|_"
+        (stripDir $(mkAbsTPS "/home/hasufell/foo")
+                  $(mkAbsTPS "/home/hasufell/foo") ==
+         Nothing)
 
 -- | The '</>' operation.
 operationAppend :: Spec
 operationAppend =
   do it "AbsDir + RelDir = AbsDir"
-        ($(mkAbsDir "/home/") </>
-         $(mkRelDir "chris") ==
-         $(mkAbsDir "/home/chris/"))
+        ($(mkAbsTPS "/home/") </>
+         $(mkRelTPS "hasufell") ==
+         $(mkAbsTPS "/home/hasufell/"))
      it "AbsDir + RelFile = AbsFile"
-        ($(mkAbsDir "/home/") </>
-         $(mkRelFile "chris/test.txt") ==
-         $(mkAbsFile "/home/chris/test.txt"))
+        ($(mkAbsTPS "/home/") </>
+         $(mkRelNoTPS "hasufell/test.txt") ==
+         $(mkAbsNoTPS "/home/hasufell/test.txt"))
      it "RelDir + RelDir = RelDir"
-        ($(mkRelDir "home/") </>
-         $(mkRelDir "chris") ==
-         $(mkRelDir "home/chris"))
+        ($(mkRelTPS "home/") </>
+         $(mkRelTPS "hasufell") ==
+         $(mkRelTPS "home/hasufell"))
      it "RelDir + RelFile = RelFile"
-        ($(mkRelDir "home/") </>
-         $(mkRelFile "chris/test.txt") ==
-         $(mkRelFile "home/chris/test.txt"))
+        ($(mkRelTPS "home/") </>
+         $(mkRelNoTPS "hasufell/test.txt") ==
+         $(mkRelNoTPS "home/hasufell/test.txt"))
 
 -- | Tests for the tokenizer.
-parseAbsDirSpec :: Spec
-parseAbsDirSpec =
+parseAbsTPSSpec :: Spec
+parseAbsTPSSpec =
   do failing ""
      failing "./"
      failing "~/"
      failing "foo.txt"
-     succeeding "/" (Path "/")
-     succeeding "//" (Path "/")
-     succeeding "///foo//bar//mu/" (Path "/foo/bar/mu/")
-     succeeding "///foo//bar////mu" (Path "/foo/bar/mu/")
-     succeeding "///foo//bar/.//mu" (Path "/foo/bar/mu/")
-  where failing x = parserTest parseAbsDir x Nothing
-        succeeding x with = parserTest parseAbsDir x (Just with)
+     succeeding "/" (MkPath "/")
+     succeeding "//" (MkPath "/")
+     succeeding "///foo//bar//mu/" (MkPath "/foo/bar/mu/")
+     succeeding "///foo//bar////mu" (MkPath "/foo/bar/mu/")
+     succeeding "///foo//bar/.//mu" (MkPath "/foo/bar/mu/")
+  where failing x = parserTest parseAbsTPS x Nothing
+        succeeding x with = parserTest parseAbsTPS x (Just with)
 
 -- | Tests for the tokenizer.
-parseRelDirSpec :: Spec
-parseRelDirSpec =
+parseRelTPSSpec :: Spec
+parseRelTPSSpec =
   do failing ""
      failing "/"
      failing "//"
      failing "~/"
      failing "/"
      failing "./"
+     failing "././"
      failing "//"
      failing "///foo//bar//mu/"
      failing "///foo//bar////mu"
      failing "///foo//bar/.//mu"
-     succeeding "foo.bak" (Path "foo.bak/")
-     succeeding "./foo" (Path "foo/")
-     succeeding "foo//bar//mu//" (Path "foo/bar/mu/")
-     succeeding "foo//bar////mu" (Path "foo/bar/mu/")
-     succeeding "foo//bar/.//mu" (Path "foo/bar/mu/")
-  where failing x = parserTest parseRelDir x Nothing
-        succeeding x with = parserTest parseRelDir x (Just with)
+     succeeding "..." (MkPath ".../")
+     succeeding "foo.bak" (MkPath "foo.bak/")
+     succeeding "./foo" (MkPath "foo/")
+     succeeding "././foo" (MkPath "foo/")
+     succeeding "./foo/./bar" (MkPath "foo/bar/")
+     succeeding "foo//bar//mu//" (MkPath "foo/bar/mu/")
+     succeeding "foo//bar////mu" (MkPath "foo/bar/mu/")
+     succeeding "foo//bar/.//mu" (MkPath "foo/bar/mu/")
+  where failing x = parserTest parseRelTPS x Nothing
+        succeeding x with = parserTest parseRelTPS x (Just with)
 
 -- | Tests for the tokenizer.
-parseAbsFileSpec :: Spec
-parseAbsFileSpec =
+parseAbsNoTPSSpec :: Spec
+parseAbsNoTPSSpec =
   do failing ""
      failing "./"
      failing "~/"
@@ -146,15 +177,16 @@ parseAbsFileSpec =
      failing "/"
      failing "//"
      failing "///foo//bar//mu/"
-     succeeding "/foo.txt" (Path "/foo.txt")
-     succeeding "///foo//bar////mu.txt" (Path "/foo/bar/mu.txt")
-     succeeding "///foo//bar/.//mu.txt" (Path "/foo/bar/mu.txt")
-  where failing x = parserTest parseAbsFile x Nothing
-        succeeding x with = parserTest parseAbsFile x (Just with)
+     succeeding "/..." (MkPath "/...")
+     succeeding "/foo.txt" (MkPath "/foo.txt")
+     succeeding "///foo//bar////mu.txt" (MkPath "/foo/bar/mu.txt")
+     succeeding "///foo//bar/.//mu.txt" (MkPath "/foo/bar/mu.txt")
+  where failing x = parserTest parseAbsNoTPS x Nothing
+        succeeding x with = parserTest parseAbsNoTPS x (Just with)
 
 -- | Tests for the tokenizer.
-parseRelFileSpec :: Spec
-parseRelFileSpec =
+parseRelNoTPSSpec :: Spec
+parseRelNoTPSSpec =
   do failing ""
      failing "/"
      failing "//"
@@ -165,13 +197,16 @@ parseRelFileSpec =
      failing "///foo//bar//mu/"
      failing "///foo//bar////mu"
      failing "///foo//bar/.//mu"
-     succeeding "foo.txt" (Path "foo.txt")
-     succeeding "./foo.txt" (Path "foo.txt")
-     succeeding "foo//bar//mu.txt" (Path "foo/bar/mu.txt")
-     succeeding "foo//bar////mu.txt" (Path "foo/bar/mu.txt")
-     succeeding "foo//bar/.//mu.txt" (Path "foo/bar/mu.txt")
-  where failing x = parserTest parseRelFile x Nothing
-        succeeding x with = parserTest parseRelFile x (Just with)
+     succeeding "..." (MkPath "...")
+     succeeding "foo.txt" (MkPath "foo.txt")
+     succeeding "./foo.txt" (MkPath "foo.txt")
+     succeeding "././foo.txt" (MkPath "foo.txt")
+     succeeding "./foo/./bar.txt" (MkPath "foo/bar.txt")
+     succeeding "foo//bar//mu.txt" (MkPath "foo/bar/mu.txt")
+     succeeding "foo//bar////mu.txt" (MkPath "foo/bar/mu.txt")
+     succeeding "foo//bar/.//mu.txt" (MkPath "foo/bar/mu.txt")
+  where failing x = parserTest parseRelNoTPS x Nothing
+        succeeding x with = parserTest parseRelNoTPS x (Just with)
 
 -- | Parser test.
 parserTest :: (Show a1,Show a,Eq a1)