{-# 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 = unpacked

fromFilePath :: FilePath -> Path
fromFilePath = pack

joinPaths :: [Path] -> Path
joinPaths = fromFilePath . joinPath . map (view path)

splitPaths :: Path -> [Path]
splitPaths = map fromFilePath . splitDirectories . view path

normPath :: Path -> Path
normPath = over path normalise

subPath :: Path -> Path -> Path
subPath p ch = fromFilePath (view path p </> view path ch)

-- | Make path relative
relPathTo :: Path -> Path -> Path
relPathTo base p = fromFilePath $ makeRelative (view path base) (view path p)

dirExists :: Path -> IO Bool
dirExists = doesDirectoryExist . view path

fileExists :: Path -> IO Bool
fileExists = doesFileExist . view path

takeDir :: Path -> Path
takeDir = over path takeDirectory

-- | Is one path parent of another
isParent :: Path -> Path -> Bool
isParent dir file = norm dir `isPrefixOf` norm file where
        norm = dropDot . splitDirectories . normalise . view path
        dropDot ("." : chs) = chs
        dropDot chs = chs

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

instance Paths FilePath where
        paths = id

instance Paths Path where
        paths = unpacked

-- | Canonicalize all paths
canonicalize :: Paths a => a -> IO a
canonicalize = paths canonicalizePath

-- | Absolutise paths
absolutise :: Paths a => Path -> a -> a
absolutise parent = over paths addRoot where
        addRoot p
                | isRelative p = (parent ^. path) </> p
                | otherwise = p

-- | Relativise paths
relativise :: Paths a => Path -> a -> a
relativise parent = over paths (makeRelative (parent ^. path))

-- | Normalize paths, with workaround for Windows drives
normalize :: Paths a => a -> a
normalize = over paths normalizePath' where
        normalizePath' :: FilePath -> FilePath
        normalizePath' = fixDrive . normalise
        fixDrive :: FilePath -> FilePath
        fixDrive = uncurry joinDrive . over _1 (addTrailingPathSeparator . dropWhileEnd isPathSeparator) . splitDrive