module System.Path.Internal
(
Path,
Abs,
Rel,
AbsOrRel,
File,
Dir,
FileOrDir,
AbsFile,
RelFile,
AbsDir,
RelDir,
AbsOrRelFile,
AbsOrRelDir,
AbsFileOrDir,
RelFileOrDir,
AbsOrRelFileOrDir,
AbsPath,
RelPath,
FilePath,
DirPath,
AbsOrRelPath,
FileOrDirPath,
AbsRelClass(..), AbsOrRelClass(..), absRel,
FileOrDirClass(..), FileDirClass(..), fileDir,
toString,
getPathString,
rootDir,
currentDir,
emptyFile,
maybePath,
parsePath,
path,
relFile,
relDir,
absFile,
absDir,
relPath,
absPath,
filePath,
dirPath,
idAbsOrRel, idAbs, idRel,
idFileOrDir, idFile, idDir,
asPath,
asRelFile,
asRelDir,
asAbsFile,
asAbsDir,
asRelPath,
asAbsPath,
asFilePath,
asDirPath,
mkPathAbsOrRel,
mkPathFileOrDir,
mkAbsPath,
mkAbsPathFromCwd,
(</>),
(<.>),
(<++>),
addExtension,
combine,
dropExtension,
dropExtensions,
dropFileName,
replaceExtension,
replaceBaseName,
replaceDirectory,
replaceFileName,
splitExtension,
splitExtensions,
splitFileName,
takeBaseName,
takeDirectory,
takeExtension,
takeExtensions,
takeFileName,
mapFileName,
equalFilePath,
joinPath,
normalise,
splitPath,
makeRelative,
makeRelativeMaybe,
makeAbsolute,
makeAbsoluteFromCwd,
dynamicMakeAbsolute,
dynamicMakeAbsoluteFromCwd,
genericMakeAbsolute,
genericMakeAbsoluteFromCwd,
pathMap,
dirFromFile,
fileFromDir,
toFileOrDir,
fromFileOrDir,
fileFromFileOrDir,
dirFromFileOrDir,
isAbsolute,
isRelative,
isAbsoluteString,
isRelativeString,
hasAnExtension,
hasExtension,
System(..),
extSeparator,
searchPathSeparator,
isExtSeparator,
isSearchPathSeparator,
genericAddExtension,
genericDropExtension,
genericDropExtensions,
genericSplitExtension,
genericSplitExtensions,
genericTakeExtension,
genericTakeExtensions,
testAll,
isValid,
)
where
import qualified System.Directory as SD
import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad.Trans.State as MS
import Control.Monad (MonadPlus, guard, liftM2, mplus, mzero)
import Control.Applicative (Const(Const), liftA2, (<$>))
import Control.DeepSeq (NFData(rnf))
import qualified Data.Monoid.HT as MonHT
import qualified Data.List.HT as ListHT
import Data.Tagged (Tagged(Tagged), untag)
import Data.Functor.Compose (Compose(Compose), getCompose)
import Data.List (isSuffixOf, isPrefixOf, stripPrefix, intersperse)
import Data.String (IsString(fromString))
import Data.Maybe.HT (toMaybe)
import Data.Maybe (fromMaybe, maybeToList)
import Data.Tuple.HT (mapFst, mapSnd)
import Data.Monoid (Monoid(mempty, mappend, mconcat), Endo(Endo), appEndo)
import Data.Char (isSpace)
import Data.Ord.HT (comparing)
import Data.Eq.HT (equating)
import Text.Show.HT (concatS)
import Text.Printf (printf)
import qualified Test.QuickCheck as QC
import Test.QuickCheck
(Gen, Property, property, Arbitrary(arbitrary), frequency)
import Prelude hiding (FilePath)
newtype Abs = Abs GenComponent
data Rel = Rel
data AbsOrRel = AbsO GenComponent | RelO
absPC :: String -> Abs
absPC = Abs . PathComponent
newtype File = File GenComponent
data Dir = Dir
data FileOrDir = FileOrDir
data Generic = Generic
_osDummy :: Generic
_osDummy = Generic
data Path os ar fd = Path ar [PathComponent os] fd
instance
(System os, AbsOrRelClass ar, FileOrDirClass fd) =>
Eq (Path os ar fd) where
(==) = equating inspectPath
instance
(System os, AbsOrRelClass ar, FileOrDirClass fd) =>
Ord (Path os ar fd) where
compare = comparing inspectPath
inspectPath ::
Path os ar fd -> (WrapAbsRel os ar, [PathComponent os], WrapFileDir os fd)
inspectPath (Path ar pcs fd) = (WrapAbsRel ar, pcs, WrapFileDir fd)
newtype WrapAbsRel os ar = WrapAbsRel {unwrapAbsRel :: ar}
instance (System os, AbsOrRelClass ar) => Eq (WrapAbsRel os ar) where
(==) = equating inspectAbsRel
instance (System os, AbsOrRelClass ar) => Ord (WrapAbsRel os ar) where
compare = comparing inspectAbsRel
inspectAbsRel ::
(AbsOrRelClass ar) =>
WrapAbsRel os ar -> Either (PathComponent os) ()
inspectAbsRel =
absRelPlain (Left . PathComponent) (Right ()) . unwrapAbsRel
newtype WrapFileDir os fd = WrapFileDir {unwrapFileDir :: fd}
instance (System os, FileOrDirClass fd) => Eq (WrapFileDir os fd) where
(==) = equating inspectFileDir
instance (System os, FileOrDirClass fd) => Ord (WrapFileDir os fd) where
compare = comparing inspectFileDir
inspectFileDir ::
(FileOrDirClass ar) =>
WrapFileDir os ar -> Either (PathComponent os) ()
inspectFileDir =
fileOrDirPlain (Left . retagPC) (Right ()) (Right ()) . unwrapFileDir
type GenComponent = PathComponent Generic
newtype PathComponent os = PathComponent String
instance (System os) => Eq (PathComponent os) where
(==) = equating (applyComp canonicalize)
instance (System os) => Ord (PathComponent os) where
compare = comparing (applyComp canonicalize)
applyComp :: Tagged os (String -> String) -> PathComponent os -> String
applyComp (Tagged canon) (PathComponent pc) = canon pc
retagPC :: GenComponent -> PathComponent os
retagPC (PathComponent pc) = PathComponent pc
untagPC :: PathComponent os -> GenComponent
untagPC (PathComponent pc) = PathComponent pc
selTag :: Path os ar fd -> Tagged os a -> a
selTag _ = untag
type AbsFile os = Path os Abs File
type RelFile os = Path os Rel File
type AbsDir os = Path os Abs Dir
type RelDir os = Path os Rel Dir
type AbsOrRelFile os = Path os AbsOrRel File
type AbsOrRelDir os = Path os AbsOrRel Dir
type AbsFileOrDir os = Path os Abs FileOrDir
type RelFileOrDir os = Path os Rel FileOrDir
type AbsOrRelFileOrDir os = Path os AbsOrRel FileOrDir
type AbsPath os fd = Path os Abs fd
type RelPath os fd = Path os Rel fd
type FilePath os ar = Path os ar File
type DirPath os ar = Path os ar Dir
type AbsOrRelPath os fd = Path os AbsOrRel fd
type FileOrDirPath os ar = Path os ar FileOrDir
instance NFData (PathComponent os) where
rnf (PathComponent pc) = rnf pc
instance NFData Abs where
rnf (Abs drive) = rnf drive
instance NFData Rel where
rnf Rel = ()
instance NFData File where
rnf (File pc) = rnf pc
instance NFData Dir where
rnf Dir = ()
instance NFData FileOrDir where
rnf FileOrDir = ()
instance (AbsOrRelClass ar, FileOrDirClass fd) => NFData (Path os ar fd) where
rnf (Path ar pcs fd) =
rnf (absRelPlain rnf () ar, pcs, fileOrDirPlain rnf () () fd)
absRelPlain :: (AbsOrRelClass ar) => (String -> a) -> a -> ar -> a
absRelPlain fAbs fRel =
runFuncArg $
switchAbsOrRel
(FuncArg $ \(Abs (PathComponent drive)) -> fAbs drive)
(FuncArg $ \Rel -> fRel)
(FuncArg $ \ar ->
case ar of
AbsO (PathComponent drive) -> fAbs drive
RelO -> fRel)
fileDirPlain :: (FileDirClass fd) => (GenComponent -> a) -> a -> fd -> a
fileDirPlain fFile fDir =
runFuncArg $
switchFileDir (FuncArg $ \(File pc) -> fFile pc) (FuncArg $ \Dir -> fDir)
fileOrDirPlain ::
(FileOrDirClass fd) => (GenComponent -> a) -> a -> a -> fd -> a
fileOrDirPlain fFile fDir fFileOrDir =
runFuncArg $
switchFileOrDir (FuncArg $ \(File pc) -> fFile pc)
(FuncArg $ \Dir -> fDir) (FuncArg $ \FileOrDir -> fFileOrDir)
newtype FuncArg b a = FuncArg {runFuncArg :: a -> b}
pathMap ::
(FileOrDirClass fd) => (String -> String) -> Path os ar fd -> Path os ar fd
pathMap f (Path ar pcs fd) = Path ar (map (pcMap f) pcs) (fdMap f fd)
fdMap :: (FileOrDirClass fd) => (String -> String) -> fd -> fd
fdMap f = appEndo $ switchFileOrDir (Endo $ fileMap f) (Endo id) (Endo id)
fileMap :: (String -> String) -> File -> File
fileMap f (File pc) = File $ pcMap f pc
pcMap :: (String -> String) -> PathComponent os -> PathComponent os
pcMap f (PathComponent s) = PathComponent (f s)
mapFilePart ::
(GenComponent -> GenComponent) -> FilePath os ar -> FilePath os ar
mapFilePart f (Path ar pcs (File fd)) = Path ar pcs $ File $ f fd
splitFilePart ::
(GenComponent -> (GenComponent, a)) -> FilePath os ar -> (FilePath os ar, a)
splitFilePart f (Path ar pcs (File fd)) = mapFst (Path ar pcs . File) $ f fd
mapPathDirs ::
([PathComponent os] -> [PathComponent os]) -> Path os ar fd -> Path os ar fd
mapPathDirs f ~(Path ar pcs fd) = Path ar (f pcs) fd
class Private p
instance Private Abs
instance Private Rel
instance Private AbsOrRel
instance Private File
instance Private Dir
instance Private FileOrDir
class Private ar => AbsOrRelClass ar where
switchAbsOrRel :: f Abs -> f Rel -> f AbsOrRel -> f ar
instance AbsOrRelClass Abs where switchAbsOrRel f _ _ = f
instance AbsOrRelClass Rel where switchAbsOrRel _ f _ = f
instance AbsOrRelClass AbsOrRel where switchAbsOrRel _ _ f = f
class AbsOrRelClass ar => AbsRelClass ar where
switchAbsRel :: f Abs -> f Rel -> f ar
instance AbsRelClass Abs where switchAbsRel f _ = f
instance AbsRelClass Rel where switchAbsRel _ f = f
absRel ::
(AbsOrRelClass ar) =>
(AbsPath os fd -> a) -> (RelPath os fd -> a) -> Path os ar fd -> a
absRel fAbs fRel (Path ar pcs fd) =
absRelPlain
(\drive -> fAbs $ Path (Abs (PathComponent drive)) pcs fd)
(fRel $ Path Rel pcs fd)
ar
class AbsRelClass ar => IsAbs ar where switchAbs :: f Abs -> f ar
instance IsAbs Abs where switchAbs = id
class AbsRelClass ar => IsRel ar where switchRel :: f Rel -> f ar
instance IsRel Rel where switchRel = id
class Private fd => FileOrDirClass fd where
switchFileOrDir :: f File -> f Dir -> f FileOrDir -> f fd
instance FileOrDirClass File where switchFileOrDir f _ _ = f
instance FileOrDirClass Dir where switchFileOrDir _ f _ = f
instance FileOrDirClass FileOrDir where switchFileOrDir _ _ f = f
switchFileOrDirPath ::
(FileOrDirClass fd) =>
f (FilePath os ar) -> f (DirPath os ar) -> f (FileOrDirPath os ar) ->
f (Path os ar fd)
switchFileOrDirPath f d fd =
getCompose $ switchFileOrDir (Compose f) (Compose d) (Compose fd)
class FileOrDirClass fd => FileDirClass fd where
switchFileDir :: f File -> f Dir -> f fd
instance FileDirClass File where switchFileDir f _ = f
instance FileDirClass Dir where switchFileDir _ f = f
switchFileDirPath ::
(FileDirClass fd) =>
f (FilePath os ar) -> f (DirPath os ar) -> f (Path os ar fd)
switchFileDirPath f d =
getCompose $ switchFileDir (Compose f) (Compose d)
fileDir ::
(FileDirClass fd) =>
(FilePath os ar -> a) -> (DirPath os ar -> a) -> Path os ar fd -> a
fileDir f g = runFuncArg $ switchFileDirPath (FuncArg f) (FuncArg g)
class FileDirClass fd => IsFile fd where switchFile :: f File -> f fd
instance IsFile File where switchFile = id
class FileDirClass fd => IsDir fd where switchDir :: f Dir -> f fd
instance IsDir Dir where switchDir = id
_eitherFromAbsRel ::
AbsOrRelClass ar => Path os ar fd -> Either (AbsPath os fd) (RelPath os fd)
_eitherFromAbsRel = absRel Left Right
_eitherFromFileDir ::
FileDirClass fd => Path os ar fd -> Either (FilePath os ar) (DirPath os ar)
_eitherFromFileDir = fileDir Left Right
instance
(System os, AbsOrRelClass ar, FileOrDirClass fd) =>
Show (Path os ar fd) where
showsPrec = untag showsPrecTagged
showsPrecTagged ::
(System os, AbsOrRelClass ar, FileOrDirClass fd) =>
Tagged os (Int -> Path os ar fd -> ShowS)
showsPrecTagged =
flip fmap rootStringTagged $ \root d x ->
case pathComponents x of
(ar, pcs) ->
showParen (d>5) $ concatS $
intersperse
(showChar ' ' . showString combineOperator . showChar ' ') $
absRelPlain
(\drive ->
if drive == root
then showString rootName
else showsCons absDirName drive)
(showString currentName)
ar :
map (\(PathComponent pc) -> showsCons relPathName pc) pcs
showsCons :: Show a => String -> a -> ShowS
showsCons name arg = showString name . showChar ' ' . showsPrec 11 arg
instance
(System os, AbsOrRelClass ar, FileOrDirClass fd) =>
Read (Path os ar fd) where
readsPrec d = readParen (d>5) $ untag readsPrecTagged
readsPrecTagged ::
(System os, AbsOrRelClass ar, FileOrDirClass fd) =>
Tagged os (ReadS (Path os ar fd))
readsPrecTagged =
flip fmap readsSplitDrive $ \readsSplDrv ->
let go =
handleMismatch
(skipSpaces >> matchString combineOperator)
(return [])
(liftM2 (:) (fmap PathComponent $ readsCons relPathName) go)
in MS.runStateT $ do
skipSpaces
MT.lift . maybeToList =<<
liftM2 maybePathFromComponents readsSplDrv go
skipSpaces :: (Monad m) => MS.StateT String m ()
skipSpaces = MS.modify $ dropWhile isSpace
readsCons :: (Read a) => String -> MS.StateT String [] a
readsCons name = do
skipSpaces
matchString name
MS.StateT $ readsPrec 11
handleMismatch ::
MS.StateT s Maybe () ->
MS.StateT s m a -> MS.StateT s m a -> MS.StateT s m a
handleMismatch act err success =
MS.StateT $ \s0 ->
case MS.execStateT act s0 of
Nothing -> MS.runStateT err s0
Just s1 -> MS.runStateT success s1
matchString :: (MonadPlus m) => String -> MS.StateT String m ()
matchString prefix =
MS.StateT $ maybe mzero (return . (,) ()) . stripPrefix prefix
readsSplitDrive ::
(System os, AbsOrRelClass ar) => Tagged os (MS.StateT String [] ar)
readsSplitDrive =
flip fmap readsSplitDriveAbs $ \readsSplDrvAbs ->
switchAbsOrRel
readsSplDrvAbs
readsSplitDriveRel
(mplus
(fmap (\(Abs drive) -> AbsO drive) readsSplDrvAbs)
(fmap (\Rel -> RelO) readsSplitDriveRel))
readsSplitDriveAbs :: (System os) => Tagged os (MS.StateT String [] Abs)
readsSplitDriveAbs =
flip fmap rootStringTagged $ \root ->
fmap absPC $
(matchString rootName >> return root)
`mplus`
readsCons absDirName
readsSplitDriveRel :: (MonadPlus m) => MS.StateT String m Rel
readsSplitDriveRel = matchString currentName >> return Rel
toString ::
(System os, AbsOrRelClass ar, FileOrDirClass fd) => Path os ar fd -> String
toString = getPathString
getPathString ::
(System os, AbsOrRelClass ar, FileOrDirClass fd) => Path os ar fd -> String
getPathString = flip getPathStringS ""
getPathStringS ::
(System os, AbsOrRelClass ar, FileOrDirClass fd) => Path os ar fd -> ShowS
getPathStringS x =
case pathComponents x of
(ar, []) ->
absRelPlain showString (showString currentDirComponent) ar
(ar, pcs) ->
concatS $
absRelPlain (\drive -> (showString drive :)) id ar $
intersperse (showChar (selTag x pathSeparator)) $
map (\(PathComponent pc) -> showString pc) pcs
prop_asPath_getPathString :: (System os) => AbsFile os -> Property
prop_asPath_getPathString p = property $ p == asPath (getPathString p)
rootDir :: (System os) => AbsDir os
rootDir = untag rootDirTagged
rootDirTagged :: (System os) => Tagged os (AbsDir os)
rootDirTagged = fmap (\root -> Path (absPC root) [] Dir) rootStringTagged
rootStringTagged :: (System os) => Tagged os String
rootStringTagged = fmap (\sep -> [sep]) pathSeparator
currentDir :: (System os) => RelDir os
currentDir = Path Rel [] Dir
emptyFile :: (System os) => RelFile os
emptyFile = Path Rel [] $ File emptyPC
emptyPC :: PathComponent os
emptyPC = PathComponent ""
rootName :: String
rootName = "rootDir"
currentName :: String
currentName = "currentDir"
currentDirComponent :: String
currentDirComponent = "."
absDirName :: String
absDirName = "absDir"
relPathName :: String
relPathName = "relPath"
maybePath ::
(System os, AbsOrRelClass ar, FileOrDirClass fd) =>
String -> Maybe (Path os ar fd)
maybePath str = do
let (ar0, pcs0, fd0) = untag makePathComponents str
ar <-
case ar0 of
AbsO pc -> switchAbsOrRel (Just $ Abs pc) Nothing (Just ar0)
RelO -> switchAbsOrRel Nothing (Just Rel) (Just ar0)
(pcs, fd) <-
case fd0 of
Left FileOrDir -> arrangeComponents pcs0
Right Dir ->
fmap ((,) pcs0) $
switchFileOrDir Nothing (Just Dir) (Just FileOrDir)
return $ Path ar pcs fd
parsePath ::
(System os, AbsOrRelClass ar, FileOrDirClass fd) =>
String -> Either String (Path os ar fd)
parsePath = pathWithNames arName fdName
pathWithNames ::
(System os, AbsOrRelClass ar, FileOrDirClass fd) =>
Const String ar -> Const String fd ->
String -> Either String (Path os ar fd)
pathWithNames (Const ar) (Const fd) str =
maybe (Left (printf "\"%s\" is not a valid %s%spath" str ar fd)) Right $
maybePath str
arName :: (AbsOrRelClass ar) => Const String ar
arName = switchAbsOrRel (Const "absolute ") (Const "relative ") (Const "")
fdName :: (FileOrDirClass fd) => Const String fd
fdName = switchFileOrDir (Const "file ") (Const "directory ") (Const "")
path ::
(System os, AbsOrRelClass ar, FileOrDirClass fd) =>
String -> Path os ar fd
path = either error id . parsePath
relFile :: (System os) => String -> RelFile os
relFile = path
relDir :: (System os) => String -> RelDir os
relDir = path
absFile :: (System os) => String -> AbsFile os
absFile = path
absDir :: (System os) => String -> AbsDir os
absDir = path
relPath :: (System os, FileOrDirClass fd) => String -> RelPath os fd
relPath = path
absPath :: (System os, FileOrDirClass fd) => String -> AbsPath os fd
absPath = path
filePath :: (System os, AbsOrRelClass ar) => String -> FilePath os ar
filePath = path
dirPath :: (System os, AbsOrRelClass ar) => String -> DirPath os ar
dirPath = path
idAbsOrRel :: AbsOrRelPath os fd -> AbsOrRelPath os fd
idAbsOrRel = id
idAbs :: AbsPath os fd -> AbsPath os fd
idAbs = id
idRel :: RelPath os fd -> RelPath os fd
idRel = id
idFileOrDir :: FileOrDirPath os fd -> FileOrDirPath os fd
idFileOrDir = id
idFile :: FilePath os fd -> FilePath os fd
idFile = id
idDir :: DirPath os fd -> DirPath os fd
idDir = id
asPath ::
(System os, AbsOrRelClass ar, FileOrDirClass fd) => String -> Path os ar fd
asPath = uncurry mkPathFromComponents . untag mkPathComponents
asRelFile :: (System os) => String -> RelFile os
asRelFile = asPath
asRelDir :: (System os) => String -> RelDir os
asRelDir = asPath
asAbsFile :: (System os) => String -> AbsFile os
asAbsFile = asPath
asAbsDir :: (System os) => String -> AbsDir os
asAbsDir = asPath
asRelPath :: (System os, FileOrDirClass fd) => String -> RelPath os fd
asRelPath = asPath
asAbsPath :: (System os, FileOrDirClass fd) => String -> AbsPath os fd
asAbsPath = asPath
asFilePath :: (System os, AbsOrRelClass ar) => String -> FilePath os ar
asFilePath = asPath
asDirPath :: (System os, AbsOrRelClass ar) => String -> DirPath os ar
asDirPath = asPath
instance
(ForbiddenSystem os, ForbiddenAbsRel ar, ForbiddenFileDir fd) =>
IsString (Path os ar fd) where fromString = forbiddenFromString
class System os => ForbiddenSystem os where
forbiddenFromString :: String -> Path os ar fd
class AbsRelClass ar => ForbiddenAbsRel ar where
class FileDirClass fd => ForbiddenFileDir fd where
mkPathAbsOrRel ::
(System os, FileOrDirClass fd) =>
String -> Either (AbsPath os fd) (RelPath os fd)
mkPathAbsOrRel = eitherAbsOrRel . asPath
eitherAbsOrRel :: AbsOrRelPath os fd -> Either (AbsPath os fd) (RelPath os fd)
eitherAbsOrRel (Path ar pcs fd) =
case ar of
AbsO drive -> Left $ Path (Abs drive) pcs fd
RelO -> Right $ Path Rel pcs fd
mkPathFileOrDir ::
(System os, AbsOrRelClass ar) =>
String -> IO (Maybe (Either (FilePath os ar) (DirPath os ar)))
mkPathFileOrDir s = do
isfile <- SD.doesFileExist s
isdir <- SD.doesDirectoryExist s
case (isfile, isdir) of
(False, False) -> return Nothing
(True, False) -> return $ Just $ Left $ asPath s
(False, True ) -> return $ Just $ Right $ asPath s
(True, True ) -> ioError $ userError "mkPathFileOrDir - object type changed while checking"
mkAbsPath ::
(System os, FileOrDirClass fd) => AbsDir os -> String -> AbsPath os fd
mkAbsPath d = either id (makeAbsolute d) . mkPathAbsOrRel
mkAbsPathFromCwd ::
(System os, FileOrDirClass fd) => String -> IO (AbsPath os fd)
mkAbsPathFromCwd = either return makeAbsoluteFromCwd . mkPathAbsOrRel
mkPathFromComponents ::
(FileOrDirClass fd) => ar -> [PathComponent os] -> Path os ar fd
mkPathFromComponents ar pcs =
uncurry (Path ar) $
switchFileOrDir
(mapSnd File $
ListHT.switchR ([], emptyPC) (curry $ mapSnd untagPC) pcs)
(pcs, Dir)
(pcs, FileOrDir)
maybePathFromComponents ::
(FileOrDirClass fd) => ar -> [PathComponent os] -> Maybe (Path os ar fd)
maybePathFromComponents ar pcs =
fmap (uncurry $ Path ar) $ arrangeComponents pcs
arrangeComponents ::
(FileOrDirClass fd) => [PathComponent os] -> Maybe ([PathComponent os], fd)
arrangeComponents pcs =
getCompose $
switchFileOrDir
(Compose $ fmap (mapSnd (File . untagPC)) $ ListHT.viewR pcs)
(Compose $ Just (pcs, Dir))
(Compose $ Just (pcs, FileOrDir))
mkPathComponents ::
(System os, AbsOrRelClass ar) =>
Tagged os (String -> (ar, [PathComponent os]))
mkPathComponents =
liftA2
(\isSep splDriveOS ->
mapSnd (nonEmptyComponents . ListHT.chop isSep)
. MS.runState splDriveOS)
isPathSeparator splitDriveOS
makePathComponents ::
(System os) =>
Tagged os (String -> (AbsOrRel, [PathComponent os], Either FileOrDir Dir))
makePathComponents =
liftA2
(\isSep splAbsolute str ->
let (ar, pct) =
mapSnd (ListHT.chop isSep) $
MS.runState splAbsolute str
(pcs1, fd) =
case ListHT.viewR pct of
Nothing -> ([], Right Dir)
Just (pcs, pc) ->
if null pc
then (pcs, Right Dir)
else (pct, Left FileOrDir)
in (ar, nonEmptyComponents pcs1, fd))
isPathSeparator splitAbsoluteO
nonEmptyComponents :: [String] -> [PathComponent os]
nonEmptyComponents = map PathComponent . filter (not . null)
splitDriveOS ::
(System os, AbsOrRelClass ar) => Tagged os (MS.State String ar)
splitDriveOS =
liftA2
(\splDrive splAbsolute ->
switchAbsOrRel (fmap absPC splDrive) (return Rel) splAbsolute)
splitDriveAbs splitAbsoluteO
splitDriveAbs :: (System os) => Tagged os (MS.State String String)
splitDriveAbs =
liftA2
(\isSep splDrive -> do
drive <- splDrive
xt <- MS.get
case xt of
[] -> return drive
x:xs ->
if isSep x
then MS.put xs >> return (drive++[x])
else return drive)
isPathSeparator splitDrive
splitAbsoluteO :: (System os) => Tagged os (MS.State String AbsOrRel)
splitAbsoluteO =
fmap (\drive -> if null drive then RelO else AbsO $ PathComponent drive)
<$>
splitAbsolute
pathComponents ::
(FileOrDirClass fd) => Path os ar fd -> (ar, [PathComponent os])
pathComponents (Path ar pcs fd) =
(ar, pcs ++ fileOrDirPlain ((:[]) . retagPC) [] [] fd)
prop_mkPathFromComponents_pathComponents :: (System os) => AbsDir os -> Property
prop_mkPathFromComponents_pathComponents p =
property $ uncurry mkPathFromComponents (pathComponents p) == p
combineOperator :: String
combineOperator = "</>"
instance (IsRel ar, IsDir fd) => Monoid (Path os ar fd) where
mempty = Path relVar [] dirVar
mappend (Path rel pcs0 _dir) (Path _rel pcs1 dir) =
Path rel (pcs0 ++ pcs1) dir
mconcat paths =
Path relVar (concatMap (\(Path _rel pcs _dir) -> pcs) paths) dirVar
relVar :: IsRel ar => ar
relVar = unwrapAbsRel $ switchRel $ WrapAbsRel Rel
dirVar :: IsDir fd => fd
dirVar = unwrapFileDir $ switchDir $ WrapFileDir Dir
(</>) :: DirPath os ar -> RelPath os fd -> Path os ar fd
Path ar pcs0 Dir </> Path Rel pcs1 fd = Path ar (pcs0 ++ pcs1) fd
infixr 5 </>
(<.>) :: FilePath os ar -> String -> FilePath os ar
p <.> ext = mapFilePart (flip addExtensionPC ext) p
infixl 7 <.>
(<++>) :: FilePath os ar -> String -> FilePath os ar
p <++> str = mapFileName (++str) p
infixl 7 <++>
addExtension :: FilePath os ar -> String -> FilePath os ar
addExtension = (<.>)
combine :: DirPath os ar -> RelPath os fd -> Path os ar fd
combine = (</>)
prop_combine_currentDir :: (System os) => RelDir os -> Property
prop_combine_currentDir p = property $ combine currentDir p == p
dropExtension :: FilePath os ar -> FilePath os ar
dropExtension = fst . splitExtension
dropExtensions :: FilePath os ar -> FilePath os ar
dropExtensions = fst . splitExtensions
dropFileName :: FilePath os ar -> DirPath os ar
dropFileName = fst . splitFileName
replaceExtension :: FilePath os ar -> String -> FilePath os ar
replaceExtension p ext = dropExtension p <.> ext
replaceBaseName :: FilePath os ar -> String -> FilePath os ar
replaceBaseName p bn =
mapFilePart (addExtensionPC (PathComponent bn) . snd . splitExtensionPC) p
replaceDirectory :: FilePath os ar1 -> DirPath os ar2 -> FilePath os ar2
replaceDirectory (Path _ _ fd) (Path ar pcs _) = Path ar pcs fd
replaceFileName :: FilePath os ar -> String -> FilePath os ar
replaceFileName p fn = mapFilePart (const (PathComponent fn)) p
splitExtension :: FilePath os ar -> (FilePath os ar, String)
splitExtension = splitFilePart splitExtensionPC
splitExtensions :: FilePath os ar -> (FilePath os ar, String)
splitExtensions = splitFilePart splitExtensionsPC
prop_split_combineExt :: (System os) => AbsFile os -> Property
prop_split_combineExt p = property $ p == uncurry (<.>) (splitExtension p)
splitFileName :: FilePath os ar -> (DirPath os ar, RelFile os)
splitFileName (Path ar pcs fd) = (Path ar pcs Dir, Path Rel [] fd)
prop_split_combine :: (System os) => AbsFile os -> Property
prop_split_combine p = property $ uncurry combine (splitFileName p) == p
takeBaseName :: FilePath os ar -> RelFile os
takeBaseName = takeFileName . dropExtension
takeDirectory :: FilePath os ar -> DirPath os ar
takeDirectory = fst . splitFileName
takeExtension :: FilePath os ar -> String
takeExtension = snd . splitExtension
takeExtensions :: FilePath os ar -> String
takeExtensions = snd . splitExtensions
takeFileName :: FilePath os ar -> RelFile os
takeFileName (Path _ _ fd) = Path Rel [] fd
prop_takeFileName_end :: (System os) => AbsFile os -> Property
prop_takeFileName_end p =
property $ getPathString (takeFileName p) `isSuffixOf` getPathString p
mapFileName :: (String -> String) -> FilePath os ar -> FilePath os ar
mapFileName = mapFilePart . pcMap
equalFilePath :: (System os) => Tagged os (String -> String -> Bool)
equalFilePath = equating <$> mkPathAbsOrRelTagged
mkPathAbsOrRelTagged ::
(System os) =>
Tagged os (String -> Either (AbsFileOrDir os) (RelFileOrDir os))
mkPathAbsOrRelTagged = Tagged mkPathAbsOrRel
joinPath :: (FileOrDirClass fd) => [String] -> RelPath os fd
joinPath = mkPathFromComponents Rel . map PathComponent
normalise :: (System os) => Path os ar fd -> Path os ar fd
normalise = mapPathDirs (filter (PathComponent currentDirComponent /=))
splitPath ::
(AbsOrRelClass ar, FileDirClass fd) =>
Path os ar fd -> (Bool, [RelDir os], Maybe (RelFile os))
splitPath (Path ar pcs fd) =
(isAbsolutePlain ar,
map (\pc -> Path Rel [pc] Dir) pcs,
maybeFileDir fd)
isAbsolutePlain :: (AbsOrRelClass ar) => ar -> Bool
isAbsolutePlain = absRelPlain (const True) False
maybeFileDir :: (FileDirClass fd) => fd -> Maybe (RelFile os)
maybeFileDir = fileDirPlain (Just . Path Rel [] . File) Nothing
makeRelative ::
(System os, FileOrDirClass fd) =>
AbsDir os -> AbsPath os fd -> RelPath os fd
makeRelative relTo orig =
fromMaybe
(error $
printf "System.Path can't make (%s) relative to (%s)"
(getPathString orig) (getPathString relTo)) $
makeRelativeMaybe relTo orig
makeRelativeMaybe ::
(System os, FileOrDirClass fd) =>
AbsDir os -> AbsPath os fd -> Maybe (RelPath os fd)
makeRelativeMaybe relTo orig =
case (inspectPath relTo, inspectPath orig) of
((relToAR, relToPCs, WrapFileDir Dir),
(origAR, origPCs, WrapFileDir fd)) ->
fmap (flip (Path Rel) fd) $
guard (relToAR == origAR) >> stripPrefix relToPCs origPCs
makeAbsolute :: (System os) => AbsDir os -> RelPath os fd -> AbsPath os fd
makeAbsolute = genericMakeAbsolute
makeAbsoluteFromCwd :: (System os) => RelPath os fd -> IO (AbsPath os fd)
makeAbsoluteFromCwd = genericMakeAbsoluteFromCwd
dynamicMakeAbsolute ::
(System os) => AbsDir os -> AbsOrRelPath os fd -> AbsPath os fd
dynamicMakeAbsolute = genericMakeAbsolute
dynamicMakeAbsoluteFromCwd ::
(System os) => AbsOrRelPath os fd -> IO (AbsPath os fd)
dynamicMakeAbsoluteFromCwd = genericMakeAbsoluteFromCwd
genericMakeAbsolute ::
(System os, AbsOrRelClass ar) => AbsDir os -> Path os ar fd -> AbsPath os fd
genericMakeAbsolute base p = absRel id (base </>) p
genericMakeAbsoluteFromCwd ::
(System os, AbsOrRelClass ar) => Path os ar fd -> IO (AbsPath os fd)
genericMakeAbsoluteFromCwd p = do
cwdString <- SD.getCurrentDirectory
return $ genericMakeAbsolute (asAbsDir cwdString) p
prop_makeAbsoluteFromDir_endSame ::
(System os) => AbsDir os -> RelFile os -> Property
prop_makeAbsoluteFromDir_endSame base p =
property $ getPathString p `isSuffixOf` getPathString (makeAbsolute base p)
prop_makeAbsoluteFromDir_startSame ::
(System os) => AbsDir os -> RelFile os -> Property
prop_makeAbsoluteFromDir_startSame base p =
property $ getPathString base `isPrefixOf` getPathString (makeAbsolute base p)
dirFromFile :: FilePath os ar -> DirPath os ar
dirFromFile p = uncurry Path (pathComponents p) Dir
fileFromDir :: DirPath os ar -> Maybe (FilePath os ar)
fileFromDir = fileFromAny
toFileOrDir :: (FileOrDirClass fd) => Path os ar fd -> FileOrDirPath os ar
toFileOrDir p = uncurry Path (pathComponents p) FileOrDir
fromFileOrDir ::
(FileOrDirClass fd) => FileOrDirPath os ar -> Maybe (Path os ar fd)
fromFileOrDir p =
switchFileOrDirPath
(fileFromFileOrDir p)
(Just $ dirFromFileOrDir p)
(Just p)
fileFromFileOrDir :: FileOrDirPath os ar -> Maybe (FilePath os ar)
fileFromFileOrDir = fileFromAny
fileFromAny :: Path os ar fd -> Maybe (FilePath os ar)
fileFromAny (Path ar pcs _) =
fmap (uncurry (Path ar) . mapSnd (File . untagPC)) $ ListHT.viewR pcs
dirFromFileOrDir :: FileOrDirPath os ar -> DirPath os ar
dirFromFileOrDir (Path ar pcs FileOrDir) = Path ar pcs Dir
isAbsolute :: AbsOrRelClass ar => Path os ar fd -> Bool
isAbsolute = absRel (const True) (const False)
isRelative :: AbsOrRelClass ar => Path os ar fd -> Bool
isRelative = not . isAbsolute
isAbsoluteString :: (System os) => Tagged os (String -> Bool)
isAbsoluteString =
fmap (\split -> not . null . MS.evalState split) splitAbsolute
isRelativeString :: (System os) => Tagged os (String -> Bool)
isRelativeString = (not .) <$> isAbsoluteString
hasAnExtension :: FilePath os ar -> Bool
hasAnExtension = not . null . snd . splitExtension
hasExtension :: String -> FilePath os ar -> Bool
hasExtension ext = (==ext) . snd . splitExtension
extSeparator :: Char
extSeparator = '.'
searchPathSeparator :: Char
searchPathSeparator = ':'
isExtSeparator :: Char -> Bool
isExtSeparator = (== extSeparator)
isSearchPathSeparator :: Char -> Bool
isSearchPathSeparator = (== searchPathSeparator)
genericAddExtension ::
(FileOrDirClass fd) => Path os ar fd -> String -> Path os ar fd
genericAddExtension =
flip $ \ext ->
appEndo $ MonHT.when (not $ null ext) $
switchFileOrDirPath
(Endo $ flip addExtension ext)
(Endo $ componentsAddExtension ext)
(Endo $ componentsAddExtension ext)
componentsAddExtension :: String -> Path os ar fd -> Path os ar fd
componentsAddExtension ext (Path ar pcs0 fd) =
let pcs = if null pcs0 then [emptyPC] else pcs0
in Path ar (mapLast (flip addExtensionPC ext) pcs) fd
genericDropExtension :: (FileOrDirClass fd) => Path os ar fd -> Path os ar fd
genericDropExtension = fst . genericSplitExtension
genericDropExtensions :: (FileOrDirClass fd) => Path os ar fd -> Path os ar fd
genericDropExtensions = fst . genericSplitExtensions
genericSplitExtension ::
(FileOrDirClass fd) => Path os ar fd -> (Path os ar fd, String)
genericSplitExtension =
runSplitExtension $
switchFileOrDirPath
(SplitExtension splitExtension)
(SplitExtension componentsSplitExtension)
(SplitExtension componentsSplitExtension)
componentsSplitExtension :: Path os ar b -> (Path os ar b, String)
componentsSplitExtension (Path ar pcs fd) =
mapFst (flip (Path ar) fd) $
mapLastPair
(error "genericSplitExtension: empty path")
splitExtensionPC pcs
genericSplitExtensions ::
(FileOrDirClass fd) => Path os ar fd -> (Path os ar fd, String)
genericSplitExtensions =
runSplitExtension $
switchFileOrDirPath
(SplitExtension splitExtensions)
(SplitExtension componentsSplitExtensions)
(SplitExtension componentsSplitExtensions)
componentsSplitExtensions :: Path os ar b -> (Path os ar b, String)
componentsSplitExtensions (Path ar pcs fd) =
mapFst (flip (Path ar) fd) $
mapLastPair
(error "genericSplitExtensions: empty path")
splitExtensionsPC pcs
genericTakeExtension :: (FileOrDirClass fd) => Path os ar fd -> String
genericTakeExtension = snd . genericSplitExtension
genericTakeExtensions :: (FileOrDirClass fd) => Path os ar fd -> String
genericTakeExtensions = snd . genericSplitExtension
newtype
SplitExtension path =
SplitExtension {runSplitExtension :: path -> (path, String)}
mapLast :: (a -> a) -> [a] -> [a]
mapLast f xs = zipWith id (drop 1 $ map (const id) xs ++ [f]) xs
mapLastPair :: b -> (a -> (a,b)) -> [a] -> ([a], b)
mapLastPair b f =
ListHT.switchR ([], b) (\as a -> mapFst ((as++) . (:[])) $ f a)
mapLastPairFoldr :: b -> (a -> (a,b)) -> [a] -> ([a], b)
mapLastPairFoldr b _ [] = ([], b)
mapLastPairFoldr _ f (x:xs) =
foldr
(\y1 go y0 -> mapFst (y0:) $ go y1)
(\y -> mapFst (:[]) $ f y)
xs x
mapLastPairRec :: b -> (a -> (a,b)) -> [a] -> ([a], b)
mapLastPairRec b _ [] = ([], b)
mapLastPairRec _ f (x:xs) =
let go y [] = mapFst (:[]) $ f y
go y0 (y1:ys) = mapFst (y0:) $ go y1 ys
in go x xs
mapLastPairRev :: b -> (a -> (a,b)) -> [a] -> ([a], b)
mapLastPairRev b0 f xs =
case reverse xs of
[] -> (xs, b0)
y:ys ->
let (a, b) = f y
in (reverse ys ++ [a], b)
_prop_mapLastPair :: String -> Int -> [String] -> Bool
_prop_mapLastPair b n strs =
let f = splitAt n
in all (mapLastPair b f strs ==) $
mapLastPairFoldr b f strs :
mapLastPairRev b f strs :
mapLastPairRec b f strs :
[]
addExtensionPC :: PathComponent os -> String -> PathComponent os
addExtensionPC p "" = p
addExtensionPC (PathComponent pc) ext =
PathComponent $ pc ++
if [extSeparator] `isPrefixOf` ext
then ext
else extSeparator : ext
splitExtensionPC :: PathComponent os -> (PathComponent os, String)
splitExtensionPC (PathComponent s) =
mapFst PathComponent $
maybe (s, "") (mapFst concat) $
((\p@(pcs,_) -> toMaybe (not (null pcs)) p) =<<) $ ListHT.viewR $
ListHT.segmentBefore isExtSeparator s
_splitExtensionPC :: PathComponent os -> (PathComponent os, String)
_splitExtensionPC (PathComponent s) =
mapFst PathComponent $
case break isExtSeparator $ reverse s of
(_, "") -> (s, "")
(rext, dot:rstem) -> (reverse rstem, dot : reverse rext)
splitExtensionsPC :: PathComponent os -> (PathComponent os, String)
splitExtensionsPC (PathComponent s) =
mapFst PathComponent $ break isExtSeparator s
class System os where
pathSeparator :: Tagged os Char
pathSeparators :: Tagged os [Char]
pathSeparators = (:[]) <$> pathSeparator
isPathSeparator :: Tagged os (Char -> Bool)
isPathSeparator = flip elem <$> pathSeparators
splitAbsolute :: Tagged os (MS.State String String)
canonicalize :: Tagged os (String -> String)
splitDrive :: Tagged os (MS.State String String)
genDrive :: Tagged os (Gen String)
isValid ::
(System os, AbsOrRelClass ar, FileOrDirClass fd) =>
Path os ar fd -> Bool
isValid = untag isValidTagged
isValidTagged ::
(System os, AbsOrRelClass ar, FileOrDirClass fd) =>
Tagged os (Path os ar fd -> Bool)
isValidTagged =
fmap
(\isValidPC (Path ar pcs fd) ->
absRelPlain isValidComponent True ar
&&
all isValidPC pcs
&&
fileOrDirPlain (isValidPC . retagPC) True True fd)
isValidPathComponent
isValidComponent :: String -> Bool
isValidComponent = not . null
isValidPathComponent ::
(System os) => Tagged os (PathComponent os -> Bool)
isValidPathComponent =
fmap
(\isSep (PathComponent str) ->
isValidComponent str && not (any isSep str))
isPathSeparator
testAll :: (System os) => os -> [(String, IO ())]
testAll os =
("asPath_getPathString",
quickCheck os prop_asPath_getPathString) :
("mkPathFromComponents_pathComponents",
quickCheck os prop_mkPathFromComponents_pathComponents) :
("combine_currentDir",
quickCheck os prop_combine_currentDir) :
("makeAbsoluteFromDir_endSame",
quickCheck os prop_makeAbsoluteFromDir_endSame) :
("makeAbsoluteFromDir_startSame",
quickCheck os prop_makeAbsoluteFromDir_startSame) :
("split_combine",
quickCheck os prop_split_combine) :
("takeFileName_end",
quickCheck os prop_takeFileName_end) :
("split_combineExt",
quickCheck os prop_split_combineExt) :
[]
quickCheck ::
(QC.Testable prop, System os, FileOrDirClass fd, AbsOrRelClass ar) =>
os -> (Path os ar fd -> prop) -> IO ()
quickCheck _ = QC.quickCheck
qcFileComponent :: Gen (PathComponent os)
qcFileComponent = PathComponent <$> frequency [
(1, return "someFile"),
(1, return "fileWith.ext"),
(1, return "file.with.multiple.exts"),
(1, return "file with spcs")
]
qcDirComponent :: Gen (PathComponent os)
qcDirComponent = PathComponent <$> frequency [
(1, return "someDir"),
(1, return "aDir"),
(1, return "aFolder"),
(1, return "a folder"),
(1, return "directory")
]
qcAbsRel :: (System os, AbsOrRelClass ar) => Tagged os (Gen ar)
qcAbsRel =
flip fmap genDrive $ \drive ->
switchAbsOrRel (fmap absPC drive) (return Rel)
(QC.oneof [fmap (AbsO . PathComponent) drive, return RelO])
qcGenPath ::
Tagged os (Gen ar) ->
(Gen ar -> Gen (Path os ar fd)) ->
Gen (Path os ar fd)
qcGenPath qcAR gen = gen $ untag qcAR
qcFilePath :: (System os, AbsOrRelClass ar) => Gen (FilePath os ar)
qcFilePath = qcGenPath qcAbsRel $ \qcAR -> do
ar <- qcAR
pcs <- QC.listOf qcDirComponent
pc <- qcFileComponent
return $ Path ar pcs $ File pc
qcDirPath :: (System os, AbsOrRelClass ar) => fd -> Gen (Path os ar fd)
qcDirPath fd = qcGenPath qcAbsRel $ \qcAR -> do
ar <- qcAR
pcs <- QC.listOf qcDirComponent
return $ Path ar pcs fd
qcPath ::
(System os, AbsOrRelClass ar, FileOrDirClass fd) => Gen (Path os ar fd)
qcPath = switchFileOrDirPath qcFilePath (qcDirPath Dir) (qcDirPath FileOrDir)
instance
(System os, AbsOrRelClass ar, FileOrDirClass fd) =>
Arbitrary (Path os ar fd) where
arbitrary = qcPath