{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}

module System.Directory.Paths (
	Path, path, fromFilePath, joinPaths, splitPaths,
	normPath, subPath, relPathTo,
	dirExists, fileExists, takeDir,
	isParent,
	Paths(..),
	canonicalize,
	absolutise,
	relativise,
	normalize
	) where

import Control.Lens
import Data.List
import Data.Text (Text, pack)
import Data.Text.Lens (unpacked)
import System.Directory
import System.FilePath

-- | Takes much less memory than 'FilePath'
type Path = Text

path :: Lens' Path FilePath
path :: (FilePath -> f FilePath) -> Path -> f Path
path = (FilePath -> f FilePath) -> Path -> f Path
forall t. IsText t => Iso' t FilePath
unpacked

fromFilePath :: FilePath -> Path
fromFilePath :: FilePath -> Path
fromFilePath = FilePath -> Path
pack

joinPaths :: [Path] -> Path
joinPaths :: [Path] -> Path
joinPaths = FilePath -> Path
fromFilePath (FilePath -> Path) -> ([Path] -> FilePath) -> [Path] -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
joinPath ([FilePath] -> FilePath)
-> ([Path] -> [FilePath]) -> [Path] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> FilePath) -> [Path] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path)

splitPaths :: Path -> [Path]
splitPaths :: Path -> [Path]
splitPaths = (FilePath -> Path) -> [FilePath] -> [Path]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Path
fromFilePath ([FilePath] -> [Path]) -> (Path -> [FilePath]) -> Path -> [Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
splitDirectories (FilePath -> [FilePath])
-> (Path -> FilePath) -> Path -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path

normPath :: Path -> Path
normPath :: Path -> Path
normPath = ASetter Path Path FilePath FilePath
-> (FilePath -> FilePath) -> Path -> Path
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Path Path FilePath FilePath
Lens' Path FilePath
path FilePath -> FilePath
normalise

subPath :: Path -> Path -> Path
subPath :: Path -> Path -> Path
subPath Path
p Path
ch = FilePath -> Path
fromFilePath (Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
p FilePath -> FilePath -> FilePath
</> Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
ch)

-- | Make path relative
relPathTo :: Path -> Path -> Path
relPathTo :: Path -> Path -> Path
relPathTo Path
base Path
p = FilePath -> Path
fromFilePath (FilePath -> Path) -> FilePath -> Path
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath
makeRelative (Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
base) (Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
p)

dirExists :: Path -> IO Bool
dirExists :: Path -> IO Bool
dirExists = FilePath -> IO Bool
doesDirectoryExist (FilePath -> IO Bool) -> (Path -> FilePath) -> Path -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path

fileExists :: Path -> IO Bool
fileExists :: Path -> IO Bool
fileExists = FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> (Path -> FilePath) -> Path -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path

takeDir :: Path -> Path
takeDir :: Path -> Path
takeDir = ASetter Path Path FilePath FilePath
-> (FilePath -> FilePath) -> Path -> Path
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Path Path FilePath FilePath
Lens' Path FilePath
path FilePath -> FilePath
takeDirectory

-- | Is one path parent of another
isParent :: Path -> Path -> Bool
isParent :: Path -> Path -> Bool
isParent Path
dir Path
file = Path -> [FilePath]
norm Path
dir [FilePath] -> [FilePath] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Path -> [FilePath]
norm Path
file where
	norm :: Path -> [FilePath]
norm = [FilePath] -> [FilePath]
dropDot ([FilePath] -> [FilePath])
-> (Path -> [FilePath]) -> Path -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
splitDirectories (FilePath -> [FilePath])
-> (Path -> FilePath) -> Path -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
normalise (FilePath -> FilePath) -> (Path -> FilePath) -> Path -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path
	dropDot :: [FilePath] -> [FilePath]
dropDot (FilePath
"." : [FilePath]
chs) = [FilePath]
chs
	dropDot [FilePath]
chs = [FilePath]
chs

-- | Something with paths inside
class Paths a where
	paths :: Traversal' a FilePath

instance Paths FilePath where
	paths :: (FilePath -> f FilePath) -> FilePath -> f FilePath
paths = (FilePath -> f FilePath) -> FilePath -> f FilePath
forall a. a -> a
id

instance Paths Path where
	paths :: (FilePath -> f FilePath) -> Path -> f Path
paths = (FilePath -> f FilePath) -> Path -> f Path
forall t. IsText t => Iso' t FilePath
unpacked

-- | Canonicalize all paths
canonicalize :: Paths a => a -> IO a
canonicalize :: a -> IO a
canonicalize = (FilePath -> IO FilePath) -> a -> IO a
forall a. Paths a => Traversal' a FilePath
paths FilePath -> IO FilePath
canonicalizePath

-- | Absolutise paths
absolutise :: Paths a => Path -> a -> a
absolutise :: Path -> a -> a
absolutise Path
parent = ASetter a a FilePath FilePath -> (FilePath -> FilePath) -> a -> a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter a a FilePath FilePath
forall a. Paths a => Traversal' a FilePath
paths FilePath -> FilePath
addRoot where
	addRoot :: FilePath -> FilePath
addRoot FilePath
p
		| FilePath -> Bool
isRelative FilePath
p = (Path
parent Path -> Getting FilePath Path FilePath -> FilePath
forall s a. s -> Getting a s a -> a
^. Getting FilePath Path FilePath
Lens' Path FilePath
path) FilePath -> FilePath -> FilePath
</> FilePath
p
		| Bool
otherwise = FilePath
p

-- | Relativise paths
relativise :: Paths a => Path -> a -> a
relativise :: Path -> a -> a
relativise Path
parent = ASetter a a FilePath FilePath -> (FilePath -> FilePath) -> a -> a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter a a FilePath FilePath
forall a. Paths a => Traversal' a FilePath
paths (FilePath -> FilePath -> FilePath
makeRelative (Path
parent Path -> Getting FilePath Path FilePath -> FilePath
forall s a. s -> Getting a s a -> a
^. Getting FilePath Path FilePath
Lens' Path FilePath
path))

-- | Normalize paths, with workaround for Windows drives
normalize :: Paths a => a -> a
normalize :: a -> a
normalize = ASetter a a FilePath FilePath -> (FilePath -> FilePath) -> a -> a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter a a FilePath FilePath
forall a. Paths a => Traversal' a FilePath
paths FilePath -> FilePath
normalizePath' where
	normalizePath' :: FilePath -> FilePath
	normalizePath' :: FilePath -> FilePath
normalizePath' = FilePath -> FilePath
fixDrive (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
normalise
	fixDrive :: FilePath -> FilePath
	fixDrive :: FilePath -> FilePath
fixDrive = (FilePath -> FilePath -> FilePath)
-> (FilePath, FilePath) -> FilePath
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FilePath -> FilePath -> FilePath
joinDrive ((FilePath, FilePath) -> FilePath)
-> (FilePath -> (FilePath, FilePath)) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter (FilePath, FilePath) (FilePath, FilePath) FilePath FilePath
-> (FilePath -> FilePath)
-> (FilePath, FilePath)
-> (FilePath, FilePath)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (FilePath, FilePath) (FilePath, FilePath) FilePath FilePath
forall s t a b. Field1 s t a b => Lens s t a b
_1 (FilePath -> FilePath
addTrailingPathSeparator (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isPathSeparator) ((FilePath, FilePath) -> (FilePath, FilePath))
-> (FilePath -> (FilePath, FilePath))
-> FilePath
-> (FilePath, FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> (FilePath, FilePath)
splitDrive