Switch to new layout

hpath.cabal

@@ -15,7 +15,7 @@ extra-source-files:  README.md, CHANGELOG
 library
   hs-source-dirs:    src/
   ghc-options:       -Wall -O2
-  exposed-modules:   HPath, HPath.Internal
+  exposed-modules:   HPath, HPath.Foreign, HPath.Internal
   build-depends:     base >= 4 && <5
                    , exceptions
                    , filepath

src/HPath.hs

@@ -13,33 +13,27 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
 {-# OPTIONS_HADDOCK ignore-exports #-}
 
 module HPath
   (
   -- * Types
    Abs
-  ,NoTPS
   ,Path
   ,Rel
-  ,TPS
+  ,Fn
   -- * PatternSynonyms/ViewPatterns
   ,pattern Path
    -- * Parsing
   ,PathParseException
-  ,parseAbsMaybeTPS
+  ,parseAbs
-  ,parseAbsNoTPS
+  ,parseFn
-  ,parseAbsTPS
+  ,parseRel
-  ,parseRelMaybeTPS
-  ,parseRelNoTPS
-  ,parseRelTPS
   -- * Constructors
-  ,mkAbsMaybeTPS
+  ,mkAbs
-  ,mkAbsNoTPS
+  ,mkFn
-  ,mkAbsTPS
+  ,mkRel
-  ,mkRelMaybeTPS
-  ,mkRelNoTPS
-  ,mkRelTPS
   -- * Operations
   ,(</>)
   ,basename
@@ -47,24 +41,32 @@ module HPath
   ,isParentOf
   ,stripDir
   -- * Conversion
-  ,fromAbsMaybeTPS
+  ,canonicalizePath
-  ,fromAbsNoTPS
+  ,fromAbs
-  ,fromAbsTPS
+  ,fromRel
-  ,fromRelMaybeTPS
+  ,normalize
-  ,fromRelNoTPS
-  ,fromRelTPS
   ,toFilePath
-  ,toNoTPS
+  -- * Queries
-  ,toTPS
+  ,hasDot
+  ,hasDoublePS
+  ,hasParentDir
+  ,isFileName
+  -- * String based functions
+  ,realPath
   )
   where
 
 import           Control.Exception (Exception)
+import           Control.Monad(void)
 import           Control.Monad.Catch (MonadThrow(..))
 import           Data.Data
 import           Data.List
 import           Data.Maybe
+import           Foreign.C.Error
+import           Foreign.C.String
+import           Foreign.Marshal.Alloc(allocaBytes)
 import           Language.Haskell.TH
+import           HPath.Foreign
 import           HPath.Internal
 import qualified System.FilePath as FilePath
 
@@ -77,29 +79,21 @@ data Abs deriving (Typeable)
 -- | A relative path; one without a root.
 data Rel deriving (Typeable)
 
--- | A path without trailing separator.
+-- | A filename, without any '/'.
-data NoTPS deriving (Typeable)
+data Fn 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
+  = InvalidAbs FilePath
-  | InvalidRelTPS FilePath
+  | InvalidRel FilePath
-  | InvalidAbsNoTPS FilePath
+  | InvalidFn FilePath
-  | InvalidRelNoTPS FilePath
-  | InvalidAbsMaybeTPS FilePath
-  | InvalidRelMaybeTPS FilePath
   | Couldn'tStripPrefixTPS FilePath FilePath
   deriving (Show,Typeable)
 instance Exception PathParseException
 
+instance RelC Rel
+instance RelC Fn
+
 --------------------------------------------------------------------------------
 -- PatternSynonyms
 
@@ -108,21 +102,18 @@ pattern Path x <- (MkPath x)
 --------------------------------------------------------------------------------
 -- Parsers
 
--- | Get a location for an absolute path. Produces a normalized
+-- | Get a location for an absolute path.
---  path which always ends in a path separator.
 --
 -- Throws: 'PathParseException'
 --
-parseAbsTPS :: MonadThrow m
+parseAbs :: MonadThrow m
-            => FilePath -> m (Path Abs TPS)
+         => FilePath -> m (Path Abs)
-parseAbsTPS filepath =
+parseAbs filepath =
   if FilePath.isAbsolute filepath &&
-     not (null (normalizeTPS filepath)) &&
+     not (null filepath) &&
-     not ("~/" `isPrefixOf` filepath) &&
-     not (hasParentDir filepath) &&
      FilePath.isValid filepath
-     then return (MkPath (normalizeTPS filepath))
+     then return (MkPath filepath)
-     else throwM (InvalidAbsTPS filepath)
+     else throwM (InvalidAbs filepath)
 
 -- | Get a location for a relative path. Produces a normalized
 -- path which always ends in a path separator.
@@ -132,107 +123,24 @@ parseAbsTPS filepath =
 --
 -- Throws: 'PathParseException'
 --
-parseRelTPS :: MonadThrow m
+parseRel :: MonadThrow m
-            => FilePath -> m (Path Rel TPS)
+         => FilePath -> m (Path Rel)
-parseRelTPS filepath =
+parseRel 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))
+     then return (MkPath filepath)
-     else throwM (InvalidRelTPS filepath)
+     else throwM (InvalidRel filepath)
 
--- | Get a location for an absolute path, which must not end with a trailing
+parseFn :: MonadThrow m
--- path separator.
+        => FilePath -> m (Path Fn)
---
+parseFn filepath =
--- 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) &&
+     isFileName filepath &&
-     not (hasParentDir filepath) &&
-     not (null (normalizeNoTPS filepath)) &&
-     filepath /= "." && filepath /= ".." &&
      FilePath.isValid filepath
-     then return (MkPath (normalizeNoTPS filepath))
+     then return (MkPath filepath)
-     else throwM (InvalidRelMaybeTPS filepath)
+     else throwM (InvalidFn 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
@@ -242,56 +150,28 @@ hasParentDir filepath' =
 -- 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
+mkAbs :: FilePath -> Q Exp
-mkAbsTPS s =
+mkAbs s =
-  case parseAbsTPS s of
+  case parseAbs s of
     Left err -> error (show err)
     Right (MkPath str) ->
-      [|MkPath $(return (LitE (StringL str))) :: Path Abs TPS|]
+      [|MkPath $(return (LitE (StringL str))) :: Path Abs|]
 
 -- | Make a 'Path Rel TPS'.
-mkRelTPS :: FilePath -> Q Exp
+mkRel :: FilePath -> Q Exp
-mkRelTPS s =
+mkRel s =
-  case parseRelTPS s of
+  case parseRel s of
     Left err -> error (show err)
     Right (MkPath str) ->
-      [|MkPath $(return (LitE (StringL str))) :: Path Rel TPS|]
+      [|MkPath $(return (LitE (StringL str))) :: Path Rel|]
 
--- | Make a 'Path Abs NoTPS'.
+-- | Make a 'Path Rel TPS'.
---
+mkFn :: FilePath -> Q Exp
--- Remember: due to the nature of absolute paths this (e.g. @\/home\/foo@)
+mkFn s =
--- may compile on your platform, but it may not compile on another
+  case parseFn s of
--- 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|]
+      [|MkPath $(return (LitE (StringL str))) :: Path Fn|]
-
--- | 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
@@ -301,32 +181,23 @@ mkRelMaybeTPS s =
 -- 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 :: Path b -> FilePath
 toFilePath (MkPath l) = l
 
-fromAbsTPS :: Path Abs TPS -> FilePath
+fromAbs :: Path Abs -> FilePath
-fromAbsTPS = toFilePath
+fromAbs = toFilePath
 
-fromRelTPS :: Path Rel TPS -> FilePath
+fromRel :: RelC r => Path r -> FilePath
-fromRelTPS = toFilePath
+fromRel = toFilePath
 
-fromAbsNoTPS :: Path Abs NoTPS -> FilePath
+normalize :: Path t -> Path t
-fromAbsNoTPS = toFilePath
+normalize (MkPath l) = MkPath $ FilePath.normalise l
 
-fromRelNoTPS :: Path Rel NoTPS -> FilePath
+-- | May fail on `realPath`.
-fromRelNoTPS = toFilePath
+canonicalizePath :: Path Abs -> IO (Path Abs)
-
+canonicalizePath (MkPath l) = do
-fromAbsMaybeTPS :: Path Abs MaybeTPS -> FilePath
+  nl <- realPath l
-fromAbsMaybeTPS = toFilePath
+  return $ MkPath nl
-
-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
@@ -339,7 +210,7 @@ toNoTPS (MkPath l) = MkPath (FilePath.dropTrailingPathSeparator l)
 -- 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
+(</>) :: RelC r => Path b -> Path r -> Path b
 (</>) (MkPath a) (MkPath b) = MkPath (a' ++ b)
   where
     a' = FilePath.addTrailingPathSeparator a
@@ -350,7 +221,7 @@ toNoTPS (MkPath l) = MkPath (FilePath.dropTrailingPathSeparator l)
 -- The bases must match.
 --
 stripDir :: MonadThrow m
-         => Path b t1 -> Path b t2 -> m (Path Rel t2)
+         => Path b -> Path b -> m (Path Rel)
 stripDir (MkPath p) (MkPath l) =
   case stripPrefix p' l of
     Nothing -> throwM (Couldn'tStripPrefixTPS p' l)
@@ -361,9 +232,8 @@ stripDir (MkPath p) (MkPath l) =
 
 -- | 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 :: Path b -> Path b -> Bool
-isParentOf p l =
+isParentOf p l = isJust (stripDir p l :: Maybe (Path Rel))
-  isJust (stripDir p l)
 
 -- | Extract the directory name of a path.
 --
@@ -371,45 +241,63 @@ isParentOf p l =
 --
 -- @dirname (p \<\/> a) == dirname p@
 --
-dirname :: Path Abs t -> Path Abs TPS
+dirname :: Path Abs -> Path Abs
-dirname (MkPath fp) = MkPath (normalizeTPS (FilePath.takeDirectory $ FilePath.dropTrailingPathSeparator fp))
+dirname (MkPath fp) = MkPath (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)
+-- Except when "/" is passed in which case the filename "." is returned.
+basename :: Path b -> Path Fn
 basename (MkPath l)
-  | not (FilePath.isAbsolute rl) = return $ MkPath rl
+  | not (FilePath.isAbsolute rl) = MkPath rl
-  | otherwise                    = throwM (InvalidRelTPS rl)
+  | otherwise                    = MkPath "."
   where
-    rl = case FilePath.hasTrailingPathSeparator l of
+    rl = last . FilePath.splitPath . FilePath.dropTrailingPathSeparator $ l
-           True  -> last (FilePath.splitPath l)
-           False -> normalizeNoTPS (FilePath.takeFileName l)
 
 --------------------------------------------------------------------------------
--- Internal functions
+-- Query functions
 
--- | Internal use for normalizing a path while always adding
+-- | Helper function: check if the filepath has any parent directories in it.
--- a trailing path separator.
+hasParentDir :: FilePath -> Bool
-normalizeTPS :: FilePath -> FilePath
+hasParentDir filepath =
-normalizeTPS =
+     ("/.." `isSuffixOf` filepath) ||
-  clean . FilePath.addTrailingPathSeparator . FilePath.normalise
+     ("/../" `isInfixOf` filepath) ||
-  where clean "./" = ""
+     ("../" `isPrefixOf` filepath)
-        clean ('/':'/':xs) = clean ('/':xs)
-        clean x = x
 
--- | Internal use for normalizing a path without adding or removing
+hasDot :: FilePath -> Bool
--- a trailing path separator.
+hasDot filepath =
-normalizeNoTPS :: FilePath -> FilePath
+     ("/." `isSuffixOf` filepath) ||
-normalizeNoTPS =
+     ("/./" `isInfixOf` filepath) ||
-  clean . FilePath.normalise
+     ("./" `isPrefixOf` filepath)
-  where clean "./" = ""
+
-        clean ('/':'/':xs) = clean ('/':xs)
+hasDoublePS :: FilePath -> Bool
-        clean x = x
+hasDoublePS filepath =
+     ("//" `isInfixOf` filepath)
+
+isFileName :: FilePath -> Bool
+isFileName filepath =
+     not ("/" `isInfixOf` filepath)
+
+
+--------------------------------------------------------------------------------
+-- String based path functions
+
+foreign import ccall "realpath"
+  c_realpath :: CString -> CString -> IO CString
+
+-- | return the canonicalized absolute pathname
+--
+-- like canonicalizePath, but uses realpath(3)
+realPath :: String -> IO String
+realPath inp = do
+    allocaBytes pathMax $ \tmp -> do
+        void $ withCString inp
+             $ \cstr -> throwErrnoIfNull "realpath"
+             $ c_realpath cstr tmp
+        peekCAString tmp
 

src/HPath/Foreign.hsc

@@ -0,0 +1,7 @@
+module HPath.Foreign where
+
+#include <limits.h>
+
+pathMax :: Int
+pathMax = #{const PATH_MAX}
+

src/HPath/Internal.hs

@@ -3,7 +3,8 @@
 -- | Internal types and functions.
 
 module HPath.Internal
-  (Path(..))
+  (Path(..)
+  ,RelC)
   where
 
 import Control.DeepSeq (NFData (..))
@@ -18,7 +19,7 @@ import Data.Data
 --
 -- There are no duplicate
 -- path separators @\/\/@, no @..@, no @.\/@, no @~\/@, etc.
-data Path b t = MkPath FilePath
+data Path b = MkPath FilePath
   deriving (Typeable)
 
 -- | String equality.
@@ -26,7 +27,7 @@ data Path b t = MkPath FilePath
 -- The following property holds:
 --
 -- @show x == show y ≡ x == y@
-instance Eq (Path b t) where
+instance Eq (Path b) where
   (==) (MkPath x) (MkPath y) = x == y
 
 -- | String ordering.
@@ -34,7 +35,7 @@ instance Eq (Path b t) where
 -- The following property holds:
 --
 -- @show x \`compare\` show y ≡ x \`compare\` y@
-instance Ord (Path b t) where
+instance Ord (Path b) where
   compare (MkPath x) (MkPath y) = compare x y
 
 -- | Same as 'Path.toFilePath'.
@@ -42,9 +43,12 @@ instance Ord (Path b t) where
 -- The following property holds:
 --
 -- @x == y ≡ show x == show y@
-instance Show (Path b t) where
+instance Show (Path b) where
   show (MkPath x) = show x
 
-instance NFData (Path b t) where
+instance NFData (Path b) where
   rnf (MkPath x) = rnf x
 
+
+class RelC m
+