path 0.7.0 → 0.7.1
raw patch · 6 files changed
+192/−20 lines, 6 filesdep ~base
Dependency ranges changed: base
Files
- CHANGELOG +5/−0
- path.cabal +8/−7
- src/Path/Include.hs +91/−3
- src/Path/Internal.hs +28/−7
- test/TH.hs +58/−0
- test/Windows.hs +2/−3
CHANGELOG view
@@ -1,3 +1,8 @@+0.7.1:+ * Test with GHC 8.8.2, 8.8.3, 8.10.1.+ * Export SomeBase constructor.+ * Fix Lift severe Lift instance bug+ 0.7.0: * BREAKING CHANGE: "fileExtension" now throws an exception if the file has no extension. You can use the result as a "Maybe" in pure
path.cabal view
@@ -1,5 +1,5 @@ name: path-version: 0.7.0+version: 0.7.1 synopsis: Support for well-typed paths description: Support for well-typed paths. license: BSD3@@ -10,7 +10,7 @@ category: System, Filesystem build-type: Simple cabal-version: 1.18-tested-with: GHC==8.2.2, GHC==8.4.4, GHC==8.6.5+tested-with: GHC==8.6.5, GHC==8.8.3, GHC==8.10.1 extra-source-files: README.md , CHANGELOG , src/Path/Include.hs@@ -27,11 +27,11 @@ , Path.Posix , Path.Windows build-depends: aeson- , base >= 4.10 && < 5+ , base >= 4.12 && < 5 , deepseq , exceptions >= 0.4 && < 0.11 , filepath < 1.2.0.1 || >= 1.3- , hashable >= 1.2 && < 1.3+ , hashable >= 1.2 && < 1.4 , text , template-haskell if flag(dev)@@ -43,7 +43,6 @@ -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances- -Wnoncanonical-monadfail-instances default-language: Haskell2010 test-suite test@@ -52,14 +51,16 @@ other-modules: Posix , Windows , Common+ , TH hs-source-dirs: test build-depends: aeson- , base >= 4.10 && < 5+ , base >= 4.12 && < 5 , bytestring , filepath < 1.2.0.1 || >= 1.3 , hspec >= 2.0 && < 3 , mtl >= 2.0 && < 3 , path+ , template-haskell if flag(dev) ghc-options: -Wall -Werror else@@ -73,7 +74,7 @@ hs-source-dirs: test build-depends: QuickCheck , aeson- , base >= 4.10 && < 5+ , base >= 4.12 && < 5 , bytestring , filepath < 1.2.0.1 || >= 1.3 , genvalidity >= 0.8
src/Path/Include.hs view
@@ -21,6 +21,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} @@ -31,6 +32,7 @@ ,Rel ,File ,Dir+ ,SomeBase(..) -- * Exceptions ,PathException(..) -- * QuasiQuoters@@ -63,12 +65,16 @@ ,parseRelDir ,parseAbsFile ,parseRelFile+ ,parseSomeDir+ ,parseSomeFile -- * Conversion ,toFilePath ,fromAbsDir ,fromRelDir ,fromAbsFile ,fromRelFile+ ,fromSomeDir+ ,fromSomeFile -- * TemplateHaskell constructors -- | These require the TemplateHaskell language extension. ,mkAbsDir@@ -86,15 +92,19 @@ ) where +import Control.Applicative (Alternative(..))+import Control.DeepSeq (NFData (..)) import Control.Exception (Exception(..)) import Control.Monad (liftM, when) import Control.Monad.Catch (MonadThrow(..))-import Data.Aeson (FromJSON (..), FromJSONKey(..))+import Data.Aeson (FromJSON (..), FromJSONKey(..), ToJSON(..)) import qualified Data.Aeson.Types as Aeson import Data.Data import qualified Data.Text as T-import Data.List+import Data.Hashable+import qualified Data.List as L import Data.Maybe+import GHC.Generics (Generic) import Language.Haskell.TH import Language.Haskell.TH.Syntax (lift) import Language.Haskell.TH.Quote (QuasiQuoter(..))@@ -176,6 +186,8 @@ | InvalidRelDir FilePath | InvalidAbsFile FilePath | InvalidRelFile FilePath+ | InvalidFile FilePath+ | InvalidDir FilePath | NotAProperPrefix FilePath FilePath | HasNoExtension FilePath | InvalidExtension String@@ -307,7 +319,7 @@ stripProperPrefix :: MonadThrow m => Path b Dir -> Path b t -> m (Path Rel t) stripProperPrefix (Path p) (Path l) =- case stripPrefix p l of+ case L.stripPrefix p l of Nothing -> throwM (NotAProperPrefix p l) Just "" -> throwM (NotAProperPrefix p l) Just ok -> return (Path ok)@@ -794,6 +806,82 @@ normalizeFilePath | IS_WINDOWS = normalizeWindowsSeps . FilePath.normalise | otherwise = normalizeLeadingSeps . FilePath.normalise++-- | Path of some type. @t@ represents the type, whether file or+-- directory. Pattern match to find whether the path is absolute or+-- relative.+data SomeBase t = Abs (Path Abs t)+ | Rel (Path Rel t)+ deriving (Typeable, Generic, Eq, Ord)++instance NFData (SomeBase t) where+ rnf (Abs p) = rnf p+ rnf (Rel p) = rnf p++instance Show (SomeBase t) where+ show = show . fromSomeBase++instance ToJSON (SomeBase t) where+ toJSON = toJSON . fromSomeBase+ {-# INLINE toJSON #-}+#if MIN_VERSION_aeson(0,10,0)+ toEncoding = toEncoding . fromSomeBase+ {-# INLINE toEncoding #-}+#endif++instance Hashable (SomeBase t) where+ -- See 'Hashable' 'Path' instance for details.+ hashWithSalt n path = hashWithSalt n (fromSomeBase path)++instance FromJSON (SomeBase Dir) where+ parseJSON = parseJSONWith parseSomeDir+ {-# INLINE parseJSON #-}++instance FromJSON (SomeBase File) where+ parseJSON = parseJSONWith parseSomeFile+ {-# INLINE parseJSON #-}++-- | Convert a valid path to a 'FilePath'.+fromSomeBase :: SomeBase t -> FilePath+fromSomeBase (Abs p) = toFilePath p+fromSomeBase (Rel p) = toFilePath p++-- | Convert a valid directory to a 'FilePath'.+fromSomeDir :: SomeBase Dir -> FilePath+fromSomeDir = fromSomeBase++-- | Convert a valid file to a 'FilePath'.+fromSomeFile :: SomeBase File -> FilePath+fromSomeFile = fromSomeBase++-- | Convert an absolute or relative 'FilePath' to a normalized 'SomeBase'+-- representing a directory.+--+-- Throws: 'InvalidDir' when the supplied path:+--+-- * contains a @..@ path component representing the parent directory+-- * is not a valid path (See 'FilePath.isValid')+parseSomeDir :: MonadThrow m => FilePath -> m (SomeBase Dir)+parseSomeDir fp = maybe (throwM (InvalidDir fp)) pure+ $ (Abs <$> parseAbsDir fp)+ <|> (Rel <$> parseRelDir fp)++-- | Convert an absolute or relative 'FilePath' to a normalized 'SomeBase'+-- representing a file.+--+-- Throws: 'InvalidFile' when the supplied path:+--+-- * is a directory path i.e.+--+-- * has a trailing path separator+-- * is @.@ or ends in @/.@+--+-- * contains a @..@ path component representing the parent directory+-- * is not a valid path (See 'FilePath.isValid')+parseSomeFile :: MonadThrow m => FilePath -> m (SomeBase File)+parseSomeFile fp = maybe (throwM (InvalidFile fp)) pure+ $ (Abs <$> parseAbsFile fp)+ <|> (Rel <$> parseRelFile fp) -------------------------------------------------------------------------------- -- Deprecated
src/Path/Internal.hs view
@@ -20,8 +20,8 @@ import GHC.Generics (Generic) import Data.Data import Data.Hashable-import Data.List-import Language.Haskell.TH.Syntax (Exp(..), Lift(..), Lit(..))+import qualified Data.List as L+import qualified Language.Haskell.TH.Syntax as TH import qualified System.FilePath as FilePath -- | Path of some base and type.@@ -104,14 +104,35 @@ hasParentDir :: FilePath -> Bool hasParentDir filepath' = (filepath' == "..") ||- ("/.." `isSuffixOf` filepath) ||- ("/../" `isInfixOf` filepath) ||- ("../" `isPrefixOf` filepath)+ ("/.." `L.isSuffixOf` filepath) ||+ ("/../" `L.isInfixOf` filepath) ||+ ("../" `L.isPrefixOf` filepath) where filepath = case FilePath.pathSeparator of '/' -> filepath' x -> map (\y -> if x == y then '/' else y) filepath' -instance Lift (Path a b) where- lift (Path str) = [|Path $(return (LitE (StringL str)))|]+instance (Typeable a, Typeable b) => TH.Lift (Path a b) where+ lift p@(Path str) = do+ let btc = typeRepTyCon $ typeRep $ mkBaseProxy p+ ttc = typeRepTyCon $ typeRep $ mkTypeProxy p+ bn <- lookupTypeNameThrow $ tyConName btc+ tn <- lookupTypeNameThrow $ tyConName ttc+ [|Path $(return (TH.LitE (TH.StringL str))) :: Path+ $(return $ TH.ConT bn)+ $(return $ TH.ConT tn)+ |]+ where+ mkBaseProxy :: Path a b -> Proxy a+ mkBaseProxy _ = Proxy++ mkTypeProxy :: Path a b -> Proxy b+ mkTypeProxy _ = Proxy++ lookupTypeNameThrow n = TH.lookupTypeName n+ >>= maybe (fail $ "Not in scope: type constructor ‘" ++ n ++ "’") return++#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped = TH.unsafeTExpCoerce . TH.lift+#endif
+ test/TH.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module TH where++import qualified Language.Haskell.TH.Syntax as TH+import Path+import Path.Internal++++class Foo a b where+ foo :: Path a b -> FilePath+ foo = toFilePath++instance Foo Abs Dir+instance Foo Abs File+instance Foo Rel Dir+instance Foo Rel File++++qqAbsDir :: FilePath+qqAbsDir = foo [absdir|/foo/|]++qqAbsFile :: FilePath+qqAbsFile = foo [absfile|/foo|]++qqRelDir :: FilePath+qqRelDir = foo [reldir|foo/|]++qqRelFile :: FilePath+qqRelFile = foo [relfile|foo|]++thAbsDir :: FilePath+thAbsDir = foo $(mkAbsDir "/foo/")++thAbsFile :: FilePath+thAbsFile = foo $(mkAbsFile "/foo")++thRelDir :: FilePath+thRelDir = foo $(mkRelDir "foo/")++thRelFile :: FilePath+thRelFile = foo $(mkRelFile "foo")++liftAbsDir :: FilePath+liftAbsDir = foo $(TH.lift (Path "/foo/" :: Path Abs Dir))++liftAbsFile :: FilePath+liftAbsFile = foo $(TH.lift (Path "/foo" :: Path Abs File))++liftRelDir :: FilePath+liftRelDir = foo $(TH.lift (Path "foo/" :: Path Rel Dir))++liftRelFile :: FilePath+liftRelFile = foo $(TH.lift (Path "foo" :: Path Rel File))
test/Windows.hs view
@@ -11,7 +11,6 @@ import Control.Monad import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as LBS-import Data.Function (on) import Data.Maybe import Path.Windows import Path.Internal@@ -82,7 +81,7 @@ $(mkRelDir ".")) it "dirname C:\\ must be a Rel path" ((parseAbsDir $ show $ dirname (fromJust (parseAbsDir "C:\\")) :: Maybe (Path Abs Dir)) == Nothing)- where dirnamesShouldBeEqual = (==) `on` dirname+ where dirnamesShouldBeEqual x y = dirname x == dirname y -- | The 'filename' operation. operationFilename :: Spec@@ -103,7 +102,7 @@ (filenamesShouldBeEqual ($(mkAbsDir "\\\\?\\C:\\home\\chris\\") </> $(mkRelFile "bar.txt")) $(mkRelFile "bar.txt"))- where filenamesShouldBeEqual = (==) `on` filename+ where filenamesShouldBeEqual x y = filename x == filename y -- | The 'parent' operation. operationParent :: Spec