path (empty) → 0.0.0
raw patch · 6 files changed
+571/−0 lines, 6 filesdep +HUnitdep +basedep +exceptionssetup-changed
Dependencies added: HUnit, base, exceptions, filepath, hspec, mtl, path, template-haskell
Files
- LICENSE +24/−0
- Setup.hs +2/−0
- path.cabal +31/−0
- src/Path.hs +275/−0
- src/Path/Internal.hs +49/−0
- test/Main.hs +190/−0
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2015, FP Complete+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of paths nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ path.cabal view
@@ -0,0 +1,31 @@+name: path+version: 0.0.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/Path.hs view
@@ -0,0 +1,275 @@+{-# 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+ ,parentAbs+ ,filename+ -- * 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++-- | A relative path; one without a root.+data Rel++-- | A file path.+data File++-- | A directory path.+data Dir++-- | 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. Produces a normalized+-- path which always ends in a path separator.+--+-- 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. Produces a normalized+-- path which always ends in a path separator.+--+-- 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:+--+-- @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++-- | 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
+ src/Path/Internal.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Internal types and functions.++module Path.Internal+ (Path(..))+ where++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\/@+--+-- All directories end in a trailing separator. There are no duplicate+-- path separators @\/\/@, no @..@, no @.\/@, no @~\/@, etc.+newtype Path b t = Path FilePath+ deriving (Typeable,Generic)++-- | String equality.+--+-- The following property holds:+--+-- @show x == show y ≡ x == y@+instance Eq (Path b t) where+ (==) (Path x) (Path y) = x == y++-- | String ordering.+--+-- The following property holds:+--+-- @show x \`compare\` show y ≡ x \`compare\` y@+instance Ord (Path b t) where+ compare (Path x) (Path y) = compare x y++-- | Same as 'Path.toFilePath'.+--+-- The following property holds:+--+-- @x == y ≡ show x == show y@+instance Show (Path b t) where+ show (Path x) = show x
+ test/Main.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Test suite.++module Main where++import Data.Monoid+import Path+import Path.Internal+import Test.Hspec++-- | Test suite entry point, returns exit failure if any test fails.+main :: IO ()+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+ 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+parseAbsDirSpec =+ 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)++-- | Tests for the tokenizer.+parseRelDirSpec :: Spec+parseRelDirSpec =+ do 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)++-- | Tests for the tokenizer.+parseAbsFileSpec :: Spec+parseAbsFileSpec =+ do failing ""+ failing "./"+ failing "~/"+ failing "./foo.txt"+ 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)++-- | Tests for the tokenizer.+parseRelFileSpec :: Spec+parseRelFileSpec =+ do failing ""+ failing "/"+ failing "//"+ failing "~/"+ failing "/"+ failing "./"+ failing "//"+ 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)++-- | Parser test.+parserTest :: (Show a1,Show a,Eq a1)+ => (a -> Maybe a1) -> a -> Maybe a1 -> SpecWith ()+parserTest parser input expected =+ it ((case expected of+ Nothing -> "Failing: "+ Just{} -> "Succeeding: ") <>+ "Parsing " <>+ show input <>+ " " <>+ case expected of+ Nothing -> "should fail."+ Just x -> "should succeed with: " <> show x)+ (actual == expected)+ where actual = parser input