streamly-core-0.3.0: src/Streamly/Internal/FileSystem/Path/Common.hs
{-# LANGUAGE UnliftedFFITypes #-}
-- |
-- Module : Streamly.Internal.FileSystem.Path.Common
-- Copyright : (c) 2023 Composewell Technologies
-- License : BSD3
-- Maintainer : streamly@composewell.com
-- Portability : GHC
--
module Streamly.Internal.FileSystem.Path.Common
(
-- * Types
OS (..)
-- * Validation
, validatePath
, validatePath'
, validateFile
-- * Construction
, fromArray
, unsafeFromArray
, fromChars
, unsafeFromChars
-- * Quasiquoters
, mkQ
-- * Elimination
, toString
, toChars
-- * Separators
, primarySeparator
, isSeparator
, isSeparatorWord
, dropTrailingSeparators
, dropTrailingBy
, hasTrailingSeparator
, hasLeadingSeparator
-- * Tests
, isBranch
, isRooted
, isAbsolute
-- , isRelative -- not isAbsolute
, isRootRelative -- XXX hasRelativeRoot
, isRelativeWithDrive -- XXX hasRelativeDriveRoot
, hasDrive
-- * Joining
, append
, append'
, unsafeAppend
, appendCString
, appendCString'
, unsafeJoinPaths
-- , joinRoot -- XXX append should be enough
-- * Splitting
-- Note: splitting the search path does not belong here, it is shell aware
-- operation. search path is separated by : and : is allowed in paths on
-- posix. Shell would escape it which needs to be handled.
, splitRoot
-- , dropRoot
-- , dropRelRoot -- if relative then dropRoot
, splitHead
, splitTail
, splitPath
, splitPath_
-- * Dir and File
, splitFile
, splitDir
-- * Extensions
, extensionWord
, splitExtension
, splitExtensionBy
-- , addExtension
-- * Equality
-- , processParentRefs
, normalizeSeparators
-- , normalize -- separators and /./ components (split/combine)
, eqPathBytes
, EqCfg(..)
, eqPath
-- , commonPrefix -- common prefix of two paths
-- , eqPrefix -- common prefix is equal to first path
-- , dropPrefix
-- * Utilities
, wordToChar
, charToWord
, unsafeIndexChar
-- * Internal
, unsafeSplitTopLevel
, unsafeSplitDrive
, unsafeSplitUNC
, splitCompact
, splitWithFilter
)
where
#include "assert.hs"
import Control.Monad (when)
import Control.Monad.Catch (MonadThrow(..))
import Control.Monad.IO.Class (MonadIO(..))
import Data.Char (chr, ord, isAlpha, toUpper)
import Data.Function ((&))
import Data.Functor.Identity (Identity(..))
import Data.Word (Word8, Word16)
import Foreign (castPtr)
import Foreign.C (CString, CSize(..))
import GHC.Base (unsafeChr, Addr#)
import GHC.Ptr (Ptr(..))
import Language.Haskell.TH (Q, Exp)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Streamly.Internal.Data.Array (Array(..))
import Streamly.Internal.Data.MutArray (MutArray)
import Streamly.Internal.Data.MutByteArray (Unbox(..))
import Streamly.Internal.Data.Path (PathException(..))
import Streamly.Internal.Data.Stream (Stream)
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.List as List
import qualified Streamly.Internal.Data.Array as Array
import qualified Streamly.Internal.Data.Fold as Fold
import qualified Streamly.Internal.Data.MutArray as MutArray
import qualified Streamly.Internal.Data.Stream as Stream
import qualified Streamly.Internal.Unicode.Stream as Unicode
{- $setup
>>> :m
>>> import Data.Functor.Identity (runIdentity)
>>> import System.IO.Unsafe (unsafePerformIO)
>>> import qualified Streamly.Data.Stream as Stream
>>> import qualified Streamly.Unicode.Stream as Unicode
>>> import qualified Streamly.Internal.Data.Array as Array
>>> import qualified Streamly.Internal.FileSystem.Path.Common as Common
>>> import qualified Streamly.Internal.Unicode.Stream as Unicode
>>> import Streamly.Internal.FileSystem.Path (ignoreTrailingSeparators, allowRelativeEquality, ignoreCase)
>>> packPosix = unsafePerformIO . Stream.fold Array.create . Unicode.encodeUtf8' . Stream.fromList
>>> unpackPosix = runIdentity . Stream.toList . Unicode.decodeUtf8' . Array.read
>>> packWindows = unsafePerformIO . Stream.fold Array.create . Unicode.encodeUtf16le' . Stream.fromList
>>> unpackWindows = runIdentity . Stream.toList . Unicode.decodeUtf16le' . Array.read
-}
data OS = Windows | Posix deriving Eq
------------------------------------------------------------------------------
-- Parsing Operations
------------------------------------------------------------------------------
-- XXX We can use Enum type class to include the Char type as well so that the
-- functions can work on Array Word8/Word16/Char but that may be slow.
-- XXX Windows is supported only on little endian machines so generally we do
-- not need covnersion from LE to BE format unless we want to manipulate
-- windows paths on big-endian machines.
-- | Unsafe, may tructate to shorter word types, can only be used safely for
-- characters that fit in the given word size.
charToWord :: Integral a => Char -> a
charToWord c =
let n = ord c
in assert (n <= 255) (fromIntegral n)
-- | Unsafe, should be a valid character.
wordToChar :: Integral a => a -> Char
wordToChar = unsafeChr . fromIntegral
------------------------------------------------------------------------------
-- Array utils
------------------------------------------------------------------------------
-- | Index a word in an array and convert it to Char.
unsafeIndexChar :: (Unbox a, Integral a) => Int -> Array a -> Char
unsafeIndexChar i a = wordToChar (Array.unsafeGetIndex i a)
-- XXX put this in array module, we can have Array.fold and Array.foldM
foldArr :: Unbox a => Fold.Fold Identity a b -> Array a -> b
foldArr f arr = runIdentity $ Array.foldM f arr
{-# INLINE countLeadingBy #-}
countLeadingBy :: Unbox a => (a -> Bool) -> Array a -> Int
countLeadingBy p = foldArr (Fold.takeEndBy_ (not . p) Fold.length)
countTrailingBy :: Unbox a => (a -> Bool) -> Array a -> Int
countTrailingBy p = Array.foldRev (Fold.takeEndBy_ (not . p) Fold.length)
------------------------------------------------------------------------------
-- Separator parsing
------------------------------------------------------------------------------
extensionWord :: Integral a => a
extensionWord = charToWord '.'
posixSeparator :: Char
posixSeparator = '/'
windowsSeparator :: Char
windowsSeparator = '\\'
-- | Primary path separator character, @/@ on Posix and @\\@ on Windows.
-- Windows supports @/@ too as a separator. Please use 'isSeparator' for
-- testing if a char is a separator char.
{-# INLINE primarySeparator #-}
primarySeparator :: OS -> Char
primarySeparator Posix = posixSeparator
primarySeparator Windows = windowsSeparator
-- | On Posix only @/@ is a path separator but in windows it could be either
-- @/@ or @\\@.
{-# INLINE isSeparator #-}
isSeparator :: OS -> Char -> Bool
isSeparator Posix c = c == posixSeparator
isSeparator Windows c = (c == windowsSeparator) || (c == posixSeparator)
{-# INLINE isSeparatorWord #-}
isSeparatorWord :: Integral a => OS -> a -> Bool
isSeparatorWord os = isSeparator os . wordToChar
------------------------------------------------------------------------------
-- Separator normalization
------------------------------------------------------------------------------
-- | If the path is @//@ the result is @/@. If it is @a//@ then the result is
-- @a@. On Windows "c:" and "c:/" are different paths, therefore, we do not
-- drop the trailing separator from "c:/" or for that matter a separator
-- preceded by a ':'.
--
-- Can't use any arbitrary predicate "p", the logic in this depends on assuming
-- that it is a path separator.
{-# INLINE dropTrailingBy #-}
dropTrailingBy :: (Unbox a, Integral a) =>
OS -> (a -> Bool) -> Array a -> Array a
dropTrailingBy os p arr =
let len = Array.length arr
n = countTrailingBy p arr
arr1 = fst $ Array.unsafeBreakAt (len - n) arr
in if n == 0
then arr
else if n == len -- "////"
then
-- Even though "//" is not allowed as a valid path.
-- We still handle that case in this low level function.
if os == Windows
&& n >= 2
&& Array.unsafeGetIndex 0 arr == Array.unsafeGetIndex 1 arr
then fst $ Array.unsafeBreakAt 2 arr -- make it "//" share name
else fst $ Array.unsafeBreakAt 1 arr
-- "c:////" - keep one "/" after colon in ".*:///" otherwise it will
-- change the meaning. "c:/" may also appear, in the middle e.g.
-- in UNC paths.
else if (os == Windows)
&& (Array.unsafeGetIndex (len - n - 1) arr == charToWord ':')
then fst $ Array.unsafeBreakAt (len - n + 1) arr
else arr1
-- XXX we cannot compact "//" to "/" on windows
{-# INLINE compactTrailingBy #-}
compactTrailingBy :: Unbox a => (a -> Bool) -> Array a -> Array a
compactTrailingBy p arr =
let len = Array.length arr
n = countTrailingBy p arr
in if n <= 1
then arr
else fst $ Array.unsafeBreakAt (len - n + 1) arr
{-# INLINE dropTrailingSeparators #-}
dropTrailingSeparators :: (Unbox a, Integral a) => OS -> Array a -> Array a
dropTrailingSeparators os =
dropTrailingBy os (isSeparator os . wordToChar)
-- | A path starting with a separator.
hasLeadingSeparator :: (Unbox a, Integral a) => OS -> Array a -> Bool
hasLeadingSeparator os a
| Array.null a = False -- empty path should not occur
| isSeparatorWord os (Array.unsafeGetIndex 0 a) = True
| otherwise = False
{-# INLINE hasTrailingSeparator #-}
hasTrailingSeparator :: (Integral a, Unbox a) => OS -> Array a -> Bool
hasTrailingSeparator os path =
let e = Array.getIndexRev 0 path
in case e of
Nothing -> False
Just x -> isSeparatorWord os x
{-# INLINE toDefaultSeparator #-}
toDefaultSeparator :: Integral a => a -> a
toDefaultSeparator x =
if isSeparatorWord Windows x
then charToWord (primarySeparator Windows)
else x
-- | Change all separators in the path to default separator on windows.
{-# INLINE normalizeSeparators #-}
normalizeSeparators :: (Integral a, Unbox a) => Array a -> Array a
normalizeSeparators a =
-- XXX We can check and return the original array if no change is needed.
Array.fromPureStreamN (Array.length a)
$ fmap toDefaultSeparator
$ Array.read a
------------------------------------------------------------------------------
-- Windows drive parsing
------------------------------------------------------------------------------
-- | @C:...@, does not check array length.
{-# INLINE unsafeHasDrive #-}
unsafeHasDrive :: (Unbox a, Integral a) => Array a -> Bool
unsafeHasDrive a
-- Check colon first for quicker return
| unsafeIndexChar 1 a /= ':' = False
-- XXX If we found a colon anyway this cannot be a valid path unless it has
-- a drive prefix. colon is not a valid path character.
-- XXX check isAlpha perf
| not (isAlpha (unsafeIndexChar 0 a)) = False
| otherwise = True
-- | A path that starts with a alphabet followed by a colon e.g. @C:...@.
hasDrive :: (Unbox a, Integral a) => Array a -> Bool
hasDrive a = Array.length a >= 2 && unsafeHasDrive a
-- | A path that contains only an alphabet followed by a colon e.g. @C:@.
isDrive :: (Unbox a, Integral a) => Array a -> Bool
isDrive a = Array.length a == 2 && unsafeHasDrive a
------------------------------------------------------------------------------
-- Relative or Absolute
------------------------------------------------------------------------------
-- | A path relative to cur dir it is either @.@ or starts with @./@.
isRelativeCurDir :: (Unbox a, Integral a) => OS -> Array a -> Bool
isRelativeCurDir os a
| len == 0 = False -- empty path should not occur
| wordToChar (Array.unsafeGetIndex 0 a) /= '.' = False
| len < 2 = True
| otherwise = isSeparatorWord os (Array.unsafeGetIndex 1 a)
where
len = Array.length a
-- | A non-UNC path starting with a separator.
-- Note that "\\/share/x" is treated as "C:/share/x".
isRelativeCurDriveRoot :: (Unbox a, Integral a) => Array a -> Bool
isRelativeCurDriveRoot a
| len == 0 = False -- empty path should not occur
| len == 1 && sep0 = True
| sep0 && c0 /= c1 = True -- "\\/share/x" is treated as "C:/share/x".
| otherwise = False
where
len = Array.length a
c0 = Array.unsafeGetIndex 0 a
c1 = Array.unsafeGetIndex 1 a
sep0 = isSeparatorWord Windows c0
-- | @C:@ or @C:a...@.
isRelativeWithDrive :: (Unbox a, Integral a) => Array a -> Bool
isRelativeWithDrive a =
hasDrive a
&& ( Array.length a < 3
|| not (isSeparator Windows (unsafeIndexChar 2 a))
)
isRootRelative :: (Unbox a, Integral a) => OS -> Array a -> Bool
isRootRelative Posix a = isRelativeCurDir Posix a
isRootRelative Windows a =
isRelativeCurDir Windows a
|| isRelativeCurDriveRoot a
|| isRelativeWithDrive a
-- | @C:\...@. Note that "C:" or "C:a" is not absolute.
isAbsoluteWithDrive :: (Unbox a, Integral a) => Array a -> Bool
isAbsoluteWithDrive a =
Array.length a >= 3
&& unsafeHasDrive a
&& isSeparator Windows (unsafeIndexChar 2 a)
-- | @\\\\...@ or @//...@
isAbsoluteUNC :: (Unbox a, Integral a) => Array a -> Bool
isAbsoluteUNC a
| Array.length a < 2 = False
| isSeparatorWord Windows c0 && c0 == c1 = True
| otherwise = False
where
c0 = Array.unsafeGetIndex 0 a
c1 = Array.unsafeGetIndex 1 a
-- XXX rename to isRootAbsolute
-- | Note that on Windows a path starting with a separator is relative to
-- current drive while on Posix this is absolute path as there is only one
-- drive.
isAbsolute :: (Unbox a, Integral a) => OS -> Array a -> Bool
isAbsolute Posix arr =
hasLeadingSeparator Posix arr
isAbsolute Windows arr =
isAbsoluteWithDrive arr || isAbsoluteUNC arr
------------------------------------------------------------------------------
-- Location or Segment
------------------------------------------------------------------------------
-- XXX API for static processing of .. (normalizeParentRefs)
--
-- Note: paths starting with . or .. are ambiguous and can be considered
-- segments or rooted. We consider a path starting with "." as rooted, when
-- someone uses "./x" they explicitly mean x in the current directory whereas
-- just "x" can be taken to mean a path segment without any specific root.
-- However, in typed paths the programmer can convey the meaning whether they
-- mean it as a segment or a rooted path. So even "./x" can potentially be used
-- as a segment which can just mean "x".
--
-- XXX For the untyped Path we can allow appending "./x" to other paths. We can
-- leave this to the programmer. In typed paths we can allow "./x" in segments.
-- XXX Empty path can be taken to mean "." except in case of UNC paths
isRooted :: (Unbox a, Integral a) => OS -> Array a -> Bool
isRooted Posix a =
hasLeadingSeparator Posix a
|| isRelativeCurDir Posix a
isRooted Windows a =
hasLeadingSeparator Windows a
|| isRelativeCurDir Windows a
|| hasDrive a -- curdir-in-drive relative, drive absolute
isBranch :: (Unbox a, Integral a) => OS -> Array a -> Bool
isBranch os = not . isRooted os
------------------------------------------------------------------------------
-- Split root
------------------------------------------------------------------------------
unsafeSplitPrefix :: (Unbox a, Integral a) =>
OS -> Int -> Array a -> (Array a, Array a)
unsafeSplitPrefix os prefixLen arr =
Array.unsafeBreakAt cnt arr
where
afterDrive = snd $ Array.unsafeBreakAt prefixLen arr
n = countLeadingBy (isSeparatorWord os) afterDrive
cnt = prefixLen + n
-- Note: We can have normalized splitting functions to normalize as we split
-- for efficiency. But then we will have to allocate new arrays instead of
-- slicing which can make it inefficient.
-- | Split a path prefixed with a separator into (drive, path) tuple.
--
-- >>> toListPosix (a,b) = (unpackPosix a, unpackPosix b)
-- >>> splitPosix = toListPosix . Common.unsafeSplitTopLevel Common.Posix . packPosix
--
-- >>> toListWin (a,b) = (unpackWindows a, unpackWindows b)
-- >>> splitWin = toListWin . Common.unsafeSplitTopLevel Common.Windows . packWindows
--
-- >>> splitPosix "/"
-- ("/","")
--
-- >>> splitPosix "//"
-- ("//","")
--
-- >>> splitPosix "/home"
-- ("/","home")
--
-- >>> splitPosix "/home/user"
-- ("/","home/user")
--
-- >>> splitWin "\\"
-- ("\\","")
--
-- >>> splitWin "\\home"
-- ("\\","home")
unsafeSplitTopLevel :: (Unbox a, Integral a) =>
OS -> Array a -> (Array a, Array a)
-- Note on Windows we should be here only when the path starts with exactly one
-- separator, otherwise it would be UNC path. But on posix multiple separators
-- are valid.
unsafeSplitTopLevel os = unsafeSplitPrefix os 1
-- In some cases there is no valid drive component e.g. "\\a\\b", though if we
-- consider relative roots then we could use "\\" as the root in this case. In
-- other cases there is no valid path component e.g. "C:" or "\\share\\" though
-- the latter is not a valid path and in the former case we can use "." as the
-- path component.
-- | Split a path prefixed with drive into (drive, path) tuple.
--
-- >>> toList (a,b) = (unpackPosix a, unpackPosix b)
-- >>> split = toList . Common.unsafeSplitDrive . packPosix
--
-- >>> split "C:"
-- ("C:","")
--
-- >>> split "C:a"
-- ("C:","a")
--
-- >>> split "C:\\"
-- ("C:\\","")
--
-- >>> split "C:\\\\" -- this is invalid path
-- ("C:\\\\","")
--
-- >>> split "C:\\\\a" -- this is invalid path
-- ("C:\\\\","a")
--
-- >>> split "C:\\/a/b" -- is this valid path?
-- ("C:\\/","a/b")
unsafeSplitDrive :: (Unbox a, Integral a) => Array a -> (Array a, Array a)
unsafeSplitDrive = unsafeSplitPrefix Windows 2
-- | Skip separators and then parse the next path segment.
-- Return (segment offset, segment length).
parseSegment :: (Unbox a, Integral a) => Array a -> Int -> (Int, Int)
parseSegment arr sepOff = (segOff, segCnt)
where
arr1 = snd $ Array.unsafeBreakAt sepOff arr
sepCnt = countLeadingBy (isSeparatorWord Windows) arr1
segOff = sepOff + sepCnt
arr2 = snd $ Array.unsafeBreakAt segOff arr
segCnt = countLeadingBy (not . isSeparatorWord Windows) arr2
-- XXX We can split a path as "root, . , rest" or "root, /, rest".
-- XXX We can remove the redundant path separator after the root. With that
-- joining root vs other paths will become similar. But there are some special
-- cases e.g. (1) "C:a" does not have a separator, can we make this "C:.\\a"?
-- (2) In case of "/home" we have "/" as root - while joining root and path we
-- should not add another separator between root and path - thus joining root
-- and path in this case is anyway special.
-- | Split a path prefixed with "\\" into (drive, path) tuple.
--
-- >>> toList (a,b) = (unpackPosix a, unpackPosix b)
-- >>> split = toList . Common.unsafeSplitUNC . packPosix
--
-- >> split ""
-- ("","")
--
-- >>> split "\\\\"
-- ("\\\\","")
--
-- >>> split "\\\\server"
-- ("\\\\server","")
--
-- >>> split "\\\\server\\"
-- ("\\\\server\\","")
--
-- >>> split "\\\\server\\home"
-- ("\\\\server\\","home")
--
-- >>> split "\\\\?\\c:"
-- ("\\\\?\\c:","")
--
-- >>> split "\\\\?\\c:/"
-- ("\\\\?\\c:/","")
--
-- >>> split "\\\\?\\c:\\home"
-- ("\\\\?\\c:\\","home")
--
-- >>> split "\\\\?\\UNC/"
-- ("\\\\?\\UNC/","")
--
-- >>> split "\\\\?\\UNC\\server"
-- ("\\\\?\\UNC\\server","")
--
-- >>> split "\\\\?\\UNC/server\\home"
-- ("\\\\?\\UNC/server\\","home")
--
unsafeSplitUNC :: (Unbox a, Integral a) => Array a -> (Array a, Array a)
unsafeSplitUNC arr =
if cnt1 == 1 && unsafeIndexChar 2 arr == '?'
then do
if uncLen == 3
&& unsafeIndexChar uncOff arr == 'U'
&& unsafeIndexChar (uncOff + 1) arr == 'N'
&& unsafeIndexChar (uncOff + 2) arr == 'C'
then unsafeSplitPrefix Windows (serverOff + serverLen) arr
else unsafeSplitPrefix Windows sepOff1 arr
else unsafeSplitPrefix Windows sepOff arr
where
arr1 = snd $ Array.unsafeBreakAt 2 arr
cnt1 = countLeadingBy (not . isSeparatorWord Windows) arr1
sepOff = 2 + cnt1
-- XXX there should be only one separator in a valid path?
-- XXX it should either be UNC or two letter drive in a valid path
(uncOff, uncLen) = parseSegment arr sepOff
sepOff1 = uncOff + uncLen
(serverOff, serverLen) = parseSegment arr sepOff1
-- XXX should we make the root Maybe? Both components will have to be Maybe to
-- avoid an empty path.
-- XXX Should we keep the trailing separator in the directory components?
{-# INLINE splitRoot #-}
splitRoot :: (Unbox a, Integral a) => OS -> Array a -> (Array a, Array a)
-- NOTE: validatePath depends on splitRoot splitting the path without removing
-- any redundant chars etc. It should just split and do nothing else.
-- XXX We can put an assert here "arrLen == rootLen + stemLen".
-- XXX assert (isValidPath path == isValidPath root)
--
-- NOTE: we cannot drop the trailing "/" on the root even if we want to -
-- because "c:/" will become "c:" and the two are not equivalent.
splitRoot Posix arr
| isRooted Posix arr
= unsafeSplitTopLevel Posix arr
| otherwise = (Array.empty, arr)
splitRoot Windows arr
| isRelativeCurDriveRoot arr || isRelativeCurDir Windows arr
= unsafeSplitTopLevel Windows arr
| hasDrive arr = unsafeSplitDrive arr
| isAbsoluteUNC arr = unsafeSplitUNC arr
| otherwise = (Array.empty, arr)
------------------------------------------------------------------------------
-- Split path
------------------------------------------------------------------------------
-- | Raw split an array on path separartor word using a filter to filter out
-- some splits.
{-# INLINE splitWithFilter #-}
splitWithFilter
:: (Unbox a, Integral a, Monad m)
=> ((Int, Int) -> Bool)
-> Bool
-> OS
-> Array a
-> Stream m (Array a)
splitWithFilter filt withSep os arr =
f (isSeparatorWord os) (Array.read arr)
& Stream.filter filt
& fmap (\(i, len) -> Array.unsafeSliceOffLen i len arr)
where
f = if withSep then Stream.indexEndBy else Stream.indexEndBy_
-- | Split a path on separator chars and compact contiguous separators and
-- remove /./ components. Note this does not treat the path root in a special
-- way.
{-# INLINE splitCompact #-}
splitCompact
:: (Unbox a, Integral a, Monad m)
=> Bool
-> OS
-> Array a
-> Stream m (Array a)
splitCompact withSep os arr =
splitWithFilter (not . shouldFilterOut) withSep os arr
where
sepFilter (off, len) =
( len == 1
&& isSeparator os (unsafeIndexChar off arr)
)
||
-- Note, last component may have len == 2 but second char may not
-- be slash, so we need to check for slash explicitly.
--
( len == 2
&& unsafeIndexChar off arr == '.'
&& isSeparator os (unsafeIndexChar (off + 1) arr)
)
{-# INLINE shouldFilterOut #-}
shouldFilterOut (off, len) =
len == 0
-- Note this is needed even when withSep is true - for the last
-- component case.
|| (len == 1 && unsafeIndexChar off arr == '.')
-- XXX Ensure that these are statically removed by GHC when withSep
-- is False.
|| (withSep && sepFilter (off, len))
-- Split a path into its components.
--
-- Usage:
-- @
-- splitPathUsing withSep ignoreLeading os arr
-- @
--
-- if withSep == True then keep the trailing separators.
--
-- if ignoreLeading == True we drop all leading separators and relative paths.
-- Example behaviour (psuedo-code):
-- @
-- > f = splitPathUsing (withSep = False) (ignoreLeading = True)
-- > f "./a/b/c" == ["a","b","c"]
-- > f "./a/./b/c" == ["a","b","c"]
-- > f "/a/./b/c" == ["a","b","c"]
-- > f "/./a/./b/c" == ["a","b","c"]
-- > f "././a/./b/c" == ["a","b","c"]
-- > f "a/./b/c" == ["a","b","c"]
-- @
--
-- We can safely set @ignoreLeading = True@ if we splitRoot prior and only pass
-- the stem of the path to this function.
{-# INLINE splitPathUsing #-}
splitPathUsing
:: (Unbox a, Integral a, Monad m)
=> Bool
-> Bool
-> OS
-> Array a
-> Stream m (Array a)
splitPathUsing withSep ignoreLeading os arr =
let stream = splitCompact withSep os rest
in if ignoreLeading || Array.null root
then stream
else Stream.cons root1 stream
where
-- We should not filter out a leading '.' on Posix or Windows.
-- We should not filter out a '.' in the middle of a UNC root on windows.
-- Therefore, we split the root and treat it in a special way.
(root, rest) = splitRoot os arr
root1 =
if withSep
then compactTrailingBy (isSeparator os . wordToChar) root
else dropTrailingSeparators os root
{-# INLINE splitPath_ #-}
splitPath_
:: (Unbox a, Integral a, Monad m)
=> OS -> Array a -> Stream m (Array a)
splitPath_ = splitPathUsing False False
{-# INLINE splitPath #-}
splitPath
:: (Unbox a, Integral a, Monad m)
=> OS -> Array a -> Stream m (Array a)
splitPath = splitPathUsing True False
-- | Split the first non-empty path component.
--
-- /Unimplemented/
{-# INLINE splitHead #-}
splitHead :: -- (Unbox a, Integral a) =>
OS -> Array a -> (Array a, Maybe (Array a))
splitHead _os _arr = undefined
-- | Split the last non-empty path component.
--
-- /Unimplemented/
{-# INLINE splitTail #-}
splitTail :: -- (Unbox a, Integral a) =>
OS -> Array a -> (Maybe (Array a), Array a)
splitTail _os _arr = undefined
------------------------------------------------------------------------------
-- File or Dir
------------------------------------------------------------------------------
-- | Returns () if the path can be a valid file, otherwise throws an
-- exception.
validateFile :: (MonadThrow m, Unbox a, Integral a) => OS -> Array a -> m ()
validateFile os arr = do
s1 <-
Stream.toList
$ Stream.take 3
$ Stream.takeWhile (not . isSeparator os)
$ fmap wordToChar
$ Array.readRev arr
-- XXX On posix we just need to check last 3 bytes of the array
-- XXX Display the path in the exception messages.
case s1 of
[] -> throwM $ InvalidPath "A file name cannot have a trailing separator"
'.' : xs ->
case xs of
[] -> throwM $ InvalidPath "A file name cannot have a trailing \".\""
'.' : [] ->
throwM $ InvalidPath "A file name cannot have a trailing \"..\""
_ -> pure ()
_ -> pure ()
case os of
Windows ->
-- XXX We can exclude a UNC root as well but just the UNC root is
-- not even a valid path.
when (isDrive arr)
$ throwM $ InvalidPath "A drive root is not a valid file name"
Posix -> pure ()
{-# INLINE splitFile #-}
splitFile :: (Unbox a, Integral a) =>
OS -> Array a -> Maybe (Maybe (Array a), Array a)
splitFile os arr =
let p x =
if os == Windows
then x == charToWord ':' || isSeparatorWord os x
else isSeparatorWord os x
-- XXX Use Array.revBreakEndBy?
fileLen = runIdentity
$ Stream.fold (Fold.takeEndBy_ p Fold.length)
$ Array.readRev arr
arrLen = Array.length arr
baseLen = arrLen - fileLen
(base, file) = Array.unsafeBreakAt baseLen arr
fileFirst = Array.unsafeGetIndex 0 file
fileSecond = Array.unsafeGetIndex 1 file
in
if fileLen > 0
-- exclude the file == '.' case
&& not (fileLen == 1 && fileFirst == charToWord '.')
-- exclude the file == '..' case
&& not (fileLen == 2
&& fileFirst == charToWord '.'
&& fileSecond == charToWord '.')
then
if baseLen <= 0
then Just (Nothing, arr)
else Just (Just $ Array.unsafeSliceOffLen 0 baseLen base, file) -- "/"
else Nothing
-- | Split a multi-component path into (dir, last component). If the path has a
-- single component and it is a root then return (path, "") otherwise return
-- ("", path).
--
-- Split a single component into (dir, "") if it can be a dir i.e. it is either
-- a path root, "." or ".." or has a trailing separator.
--
-- The only difference between splitFile and splitDir:
--
-- >> splitFile "a/b/"
-- ("a/b/", "")
-- >> splitDir "a/b/"
-- ("a/", "b/")
--
-- This is equivalent to splitPath and keeping the last component but is usually
-- faster.
--
-- >>> toList (a,b) = (unpackPosix a, unpackPosix b)
-- >>> splitPosix = toList . Common.splitDir Common.Posix . packPosix
--
-- >> splitPosix "/"
-- ("/","")
--
-- >> splitPosix "."
-- (".","")
--
-- >> splitPosix "/."
-- ("/.","")
--
-- >> splitPosix "/x"
-- ("/","x")
--
-- >> splitPosix "/x/"
-- ("/","x/")
--
-- >> splitPosix "//"
-- ("//","")
--
-- >> splitPosix "./x"
-- ("./","x")
--
-- >> splitPosix "x"
-- ("","x")
--
-- >> splitPosix "x/"
-- ("x/","")
--
-- >> splitPosix "x/y"
-- ("x/","y")
--
-- >> splitPosix "x/y/"
-- ("x/","y/")
--
-- >> splitPosix "x/y//"
-- ("x/","y//")
--
-- >> splitPosix "x//y"
-- ("x//","y")
--
-- >> splitPosix "x/./y"
-- ("x/./","y")
--
-- /Unimplemented/
{-# INLINE splitDir #-}
splitDir :: -- (Unbox a, Integral a) =>
OS -> Array a -> (Array a, Array a)
splitDir _os _arr = undefined
------------------------------------------------------------------------------
-- Split extensions
------------------------------------------------------------------------------
-- | Like split extension but we can specify the extension char to be used.
{-# INLINE splitExtensionBy #-}
splitExtensionBy :: (Unbox a, Integral a) =>
a -> OS -> Array a -> Maybe (Array a, Array a)
splitExtensionBy c os arr =
let p x = x == c || isSeparatorWord os x
-- XXX Use Array.revBreakEndBy_
extLen = runIdentity
$ Stream.fold (Fold.takeEndBy p Fold.length)
$ Array.readRev arr
arrLen = Array.length arr
baseLen = arrLen - extLen
-- XXX We can use reverse split operation on the array
res@(base, ext) = Array.unsafeBreakAt baseLen arr
baseLast = Array.unsafeGetIndexRev 0 base
extFirst = Array.unsafeGetIndex 0 ext
in
-- For an extension to be present the path must be at least 3 chars.
-- non-empty base followed by extension char followed by non-empty
-- extension.
if arrLen > 2
-- If ext is empty, then there is no extension and we should not
-- strip an extension char if any at the end of base.
&& extLen > 1
&& extFirst == c
-- baseLast is always either base name char or '/' unless empty
-- if baseLen is 0 then we have not found an extension.
&& baseLen > 0
-- If baseLast is '/' then base name is empty which means it is a
-- dot file and there is no extension.
&& not (isSeparatorWord os baseLast)
-- On Windows if base is 'c:.' or a UNC path ending in '/c:.' then
-- it is a dot file, no extension.
&& not (os == Windows && baseLast == charToWord ':')
then Just res
else Nothing
{-# INLINE splitExtension #-}
splitExtension :: (Unbox a, Integral a) => OS -> Array a -> Maybe (Array a, Array a)
splitExtension = splitExtensionBy extensionWord
{-
-- Instead of this keep calling splitExtension until there is no more extension
-- returned.
{-# INLINE splitAllExtensionsBy #-}
splitAllExtensionsBy :: (Unbox a, Integral a) =>
Bool -> a -> OS -> Array a -> (Array a, Array a)
-- If the isFileName arg is true, it means that the path supplied does not have
-- any separator chars, so we can do it more efficiently.
splitAllExtensionsBy isFileName extChar os arr =
let file =
if isFileName
then arr
else snd $ splitFile os arr
fileLen = Array.length file
arrLen = Array.length arr
baseLen = foldArr (Fold.takeEndBy_ (== extChar) Fold.length) file
extLen = fileLen - baseLen
in
-- XXX unsafeBreakAt itself should use Array.empty in case of no split
if fileLen > 0 && extLen > 1 && extLen /= fileLen
then (Array.unsafeBreakAt (arrLen - extLen) arr)
else (arr, Array.empty)
-- |
--
-- TODO: This function needs to be consistent with splitExtension. It should
-- strip all valid extensions by that definition.
--
-- splitAllExtensions "x/y.tar.gz" gives ("x/y", ".tar.gz")
--
-- >>> toList (a,b) = (unpackPosix a, unpackPosix b)
-- >>> splitPosix = toList . Common.splitAllExtensions Common.Posix . packPosix
--
-- >>> toListWin (a,b) = (unpackWindows a, unpackWindows b)
-- >>> splitWin = toListWin . Common.splitAllExtensions Common.Windows . packWindows
--
-- >>> splitPosix "/"
-- ("/","")
--
-- >>> splitPosix "."
-- (".","")
--
-- >>> splitPosix "x"
-- ("x","")
--
-- >>> splitPosix "/x"
-- ("/x","")
--
-- >>> splitPosix "x/"
-- ("x/","")
--
-- >>> splitPosix "./x"
-- ("./x","")
--
-- >>> splitPosix "x/."
-- ("x/.","")
--
-- >>> splitPosix "x/y."
-- ("x/y.","")
--
-- >>> splitPosix "/x.y"
-- ("/x",".y")
--
-- >>> splitPosix "x/.y"
-- ("x/.y","")
--
-- >>> splitPosix ".x"
-- (".x","")
--
-- >>> splitPosix "x."
-- ("x.","")
--
-- >>> splitPosix ".x.y"
-- (".x",".y")
--
-- >>> splitPosix "x/y.z"
-- ("x/y",".z")
--
-- >>> splitPosix "x.y.z"
-- ("x",".y.z")
--
-- >>> splitPosix "x..y" -- ??
-- ("x.",".y")
--
-- >>> splitPosix ".."
-- ("..","")
--
-- >>> splitPosix "..."
-- ("...","")
--
-- >>> splitPosix "...x"
-- ("...x","")
--
-- >>> splitPosix "x/y.z/"
-- ("x/y.z/","")
--
-- >>> splitPosix "x/y"
-- ("x/y","")
--
-- >>> splitWin "x:y"
-- ("x:y","")
--
-- >>> splitWin "x:.y"
-- ("x:.y","")
--
{-# INLINE splitAllExtensions #-}
splitAllExtensions :: (Unbox a, Integral a) =>
OS -> Array a -> (Array a, Array a)
splitAllExtensions = splitAllExtensionsBy False extensionWord
-}
------------------------------------------------------------------------------
-- Construction
------------------------------------------------------------------------------
{-# INLINE isInvalidPathChar #-}
isInvalidPathChar :: Integral a => OS -> a -> Bool
isInvalidPathChar Posix x = x == 0
isInvalidPathChar Windows x =
-- case should be faster than list search
case x of
34 -> True -- '"'
42 -> True -- '*'
58 -> True -- ':'
60 -> True -- '<'
62 -> True -- '>'
63 -> True -- '?'
124 -> True -- '|'
_ -> x <= charToWord '\US'
countLeadingValid :: (Unbox a, Integral a) => OS -> Array a -> Int
countLeadingValid os path =
let f = Fold.takeEndBy_ (isInvalidPathChar os) Fold.length
in foldArr f path
-- XXX Supply it an array for checking and use a more efficient prefix matching
-- check.
-- | Only for windows.
isInvalidPathComponent :: Integral a => [[a]]
isInvalidPathComponent = fmap (fmap charToWord)
[ "CON","PRN","AUX","NUL","CLOCK$"
, "COM1","COM2","COM3","COM4","COM5","COM6","COM7","COM8","COM9"
, "LPT1","LPT2","LPT3","LPT4","LPT5","LPT6","LPT7","LPT8","LPT9"
]
{- HLINT ignore "Use when" -}
validatePathWith :: (MonadThrow m, Integral a, Unbox a) =>
Bool -> OS -> Array a -> m ()
validatePathWith _ Posix path =
let pathLen = Array.length path
validLen = countLeadingValid Posix path
in if pathLen == 0
then throwM $ InvalidPath "Empty path"
else if pathLen /= validLen
then throwM $ InvalidPath
$ "Null char found after " ++ show validLen ++ " characters."
else pure ()
validatePathWith allowRoot Windows path
| Array.null path = throwM $ InvalidPath "Empty path"
| otherwise = do
if hasDrive path && postDriveSep > 1 -- "C://"
then throwM $ InvalidPath
"More than one separators between drive root and the path"
else if isAbsoluteUNC path
then
if postDriveSep > 1 -- "///x"
then throwM $ InvalidPath
"Path starts with more than two separators"
else if invalidRootComponent -- "//prn/x"
then throwM $ InvalidPath
-- XXX print the invalid component name
"Special filename component found in share root"
else if rootEndSeps /= 1 -- "//share//x"
then throwM $ InvalidPath
$ "Share name is needed and exactly one separator is needed "
++ "after the share root"
else if not allowRoot && Array.null stem -- "//share/"
then throwM $ InvalidPath
"the share root must be followed by a non-empty path"
else pure ()
else pure ()
if stemLen /= validStemLen -- "x/x>y"
then throwM $ InvalidPath
$ "Disallowed char found after "
++ show (rootLen + validStemLen)
++ " characters. The invalid char is: "
++ show (chr (fromIntegral invalidVal))
++ " [" ++ show invalidVal ++ "]"
else if invalidComponent -- "x/prn/y"
-- XXX print the invalid component name
then throwM $ InvalidPath "Disallowed Windows filename in path"
else pure ()
where
postDrive = snd $ Array.unsafeBreakAt 2 path
postDriveSep = countLeadingBy (isSeparatorWord Windows) postDrive
-- XXX check invalid chars in the path root as well - except . and '?'?
(root, stem) = splitRoot Windows path
rootLen = Array.length root
stemLen = Array.length stem
validStemLen = countLeadingValid Windows stem
invalidVal = fromIntegral (Array.unsafeGetIndex validStemLen stem) :: Word16
rootEndSeps = countTrailingBy (isSeparatorWord Windows) root
-- TBD: We are not currently validating the sharenames against disallowed
-- file names. Apparently windows does not allow even sharenames with those
-- names. To match against sharenames we will have to strip the separators
-- and drive etc from the root. Or we can use the parsing routines
-- themselves to validate.
toUp w16 =
if w16 < 256
then charToWord $ toUpper (wordToChar w16)
else w16
-- Should we strip all space chars as in Data.Char.isSpace?
isSpace x = x == charToWord ' '
-- XXX instead of using a list based check, pass the array to the checker.
-- We do not need to upcase the array, it can be done in the checker. Thus
-- we do not need to create a new array, the original slice can be checked.
getBaseName x =
runIdentity
$ Stream.toList
$ fmap toUp
$ Array.read
$ Array.dropAround isSpace
$ fst $ Array.breakEndBy_ (== extensionWord) x
components =
runIdentity
. Stream.toList
. fmap getBaseName
. splitCompact False Windows
invalidRootComponent =
List.any (`List.elem` isInvalidPathComponent) (components root)
invalidComponent =
List.any (`List.elem` isInvalidPathComponent) (components stem)
-- | A valid root, share root or a valid path.
{-# INLINE validatePath #-}
validatePath :: (MonadThrow m, Integral a, Unbox a) => OS -> Array a -> m ()
validatePath = validatePathWith True
{-# INLINE validatePath' #-}
validatePath' :: (MonadThrow m, Integral a, Unbox a) => OS -> Array a -> m ()
validatePath' = validatePathWith False
{-# INLINE unsafeFromArray #-}
unsafeFromArray :: Array a -> Array a
unsafeFromArray = id
{-# INLINE fromArray #-}
fromArray :: forall m a. (MonadThrow m, Unbox a, Integral a) =>
OS -> Array a -> m (Array a)
fromArray os arr = validatePath os arr >> pure arr
{-
let arr1 = Array.unsafeCast arr :: Array a
in validatePath os arr1 >> pure arr1
fromArray Windows arr =
case Array.cast arr of
Nothing ->
throwM
$ InvalidPath
$ "Encoded path length " ++ show (Array.byteLength arr)
++ " is not a multiple of 16-bit."
Just x -> validatePath Windows x >> pure x
-}
{-# INLINE unsafeFromChars #-}
unsafeFromChars :: (Unbox a) =>
(Stream Identity Char -> Stream Identity a)
-> Stream Identity Char
-> Array a
unsafeFromChars encode s =
let n = runIdentity $ Stream.fold Fold.length s
in Array.fromPureStreamN n (encode s)
-- XXX Writing a custom fold for parsing a Posix path may be better for
-- efficient bulk parsing when needed. We need the same code to validate a
-- Chunk where we do not need to create an array.
{-# INLINE fromChars #-}
fromChars :: (MonadThrow m, Unbox a, Integral a) =>
OS
-> (Stream Identity Char -> Stream Identity a)
-> Stream Identity Char
-> m (Array a)
fromChars os encode s =
let arr = unsafeFromChars encode s
in fromArray os (Array.unsafeCast arr)
{-# INLINE toChars #-}
toChars :: (Monad m, Unbox a) =>
(Stream m a -> Stream m Char) -> Array a -> Stream m Char
toChars decode arr = decode $ Array.read arr
{-# INLINE toString #-}
toString :: Unbox a =>
(Stream Identity a -> Stream Identity Char) -> Array a -> [Char]
toString decode = runIdentity . Stream.toList . toChars decode
------------------------------------------------------------------------------
-- Statically Verified Literals
------------------------------------------------------------------------------
-- XXX pass the quote name for errors?
mkQ :: (String -> Q Exp) -> QuasiQuoter
mkQ f =
QuasiQuoter
{ quoteExp = f
, quotePat = err "pattern"
, quoteType = err "type"
, quoteDec = err "declaration"
}
where
err x _ = fail $ "QuasiQuote used as a " ++ x
++ ", can be used only as an expression"
------------------------------------------------------------------------------
-- Operations of Path
------------------------------------------------------------------------------
-- See also cstringLength# in GHC.CString in ghc-prim
foreign import ccall unsafe "string.h strlen" c_strlen_pinned
:: Addr# -> IO CSize
{-# INLINE appendCStringWith #-}
appendCStringWith ::
(Int -> IO (MutArray Word8))
-> OS
-> Array Word8
-> CString
-> IO (Array Word8)
appendCStringWith create os a b@(Ptr addrB#) = do
let lenA = Array.length a
lenB <- fmap fromIntegral $ c_strlen_pinned addrB#
assertM(lenA /= 0 && lenB /= 0)
let len = lenA + 1 + lenB
arr <- create len
arr1 <- MutArray.unsafeSplice arr (Array.unsafeThaw a)
arr2 <- MutArray.unsafeSnoc arr1 (charToWord (primarySeparator os))
arr3 :: MutArray.MutArray Word8 <-
MutArray.unsafeAppendPtrN arr2 (castPtr b) lenB
return (Array.unsafeFreeze arr3)
{-# INLINE appendCString #-}
appendCString :: OS -> Array Word8 -> CString -> IO (Array Word8)
appendCString = appendCStringWith MutArray.emptyOf
{-# INLINE appendCString' #-}
appendCString' :: OS -> Array Word8 -> CString -> IO (Array Word8)
appendCString' = appendCStringWith MutArray.emptyOf'
{-# INLINE doAppend #-}
doAppend :: (Unbox a, Integral a) => OS -> Array a -> Array a -> Array a
doAppend os a b = unsafePerformIO $ do
let lenA = Array.length a
lenB = Array.length b
assertM(lenA /= 0 && lenB /= 0)
let lastA = Array.unsafeGetIndexRev 0 a
sepA = isSeparatorWord os lastA
sepB = isSeparatorWord os (Array.unsafeGetIndex 0 b)
let len = lenA + 1 + lenB
arr <- MutArray.emptyOf len
arr1 <- MutArray.unsafeSplice arr (Array.unsafeThaw a)
arr2 <-
if lenA /= 0
&& lenB /= 0
&& not sepA
&& not sepB
&& not (os == Windows && lastA == charToWord ':')
then MutArray.unsafeSnoc arr1 (charToWord (primarySeparator os))
else pure arr1
-- Note: if the last char on the first array is ":" and first char on the
-- second array is "/" then we cannot drop the "/". We drop only if both
-- are separators excluding ":".
let arrB =
if sepA && sepB
then snd $ Array.unsafeBreakAt 1 b
else b
arr3 <- MutArray.unsafeSplice arr2 (Array.unsafeThaw arrB)
return (Array.unsafeFreeze arr3)
{-# INLINE withAppendCheck #-}
withAppendCheck :: (Unbox b, Integral b) =>
OS -> (Array b -> String) -> Array b -> a -> a
withAppendCheck os toStr arr f =
if isRooted os arr
then error $ "append: cannot append a rooted path " ++ toStr arr
else f
{-# INLINE unsafeAppend #-}
unsafeAppend :: (Unbox a, Integral a) =>
OS -> (Array a -> String) -> Array a -> Array a -> Array a
unsafeAppend os _toStr = doAppend os
{-# INLINE append #-}
append :: (Unbox a, Integral a) =>
OS -> (Array a -> String) -> Array a -> Array a -> Array a
append os toStr a b = withAppendCheck os toStr b (doAppend os a b)
{-# INLINE append' #-}
append' :: (Unbox a, Integral a) =>
OS -> (Array a -> String) -> Array a -> Array a -> Array a
append' os toStr a b =
let hasSep = countTrailingBy (isSeparatorWord os) a > 0
hasColon =
os == Windows
&& Array.getIndexRev 0 a == Just (charToWord ':')
in if hasSep || hasColon
then withAppendCheck os toStr b (doAppend os a b)
else error
$ "append': first path must be dir like i.e. must have a "
++ "trailing separator or colon on windows: " ++ toStr a
-- XXX MonadIO?
-- | Join paths by path separator. Does not check if the paths being appended
-- are rooted or path segments. Note that splitting and joining may not give
-- exactly the original path but an equivalent, normalized path.
{-# INLINE unsafeJoinPaths #-}
unsafeJoinPaths
:: (Unbox a, Integral a, MonadIO m)
=> OS -> Stream m (Array a) -> m (Array a)
unsafeJoinPaths os =
-- XXX This can be implemented more efficiently using an Array intersperse
-- operation. Which can be implemented by directly copying arrays rather
-- than converting them to stream first. Also fromStreamN would be more
-- efficient if we have to use streams.
-- XXX We can remove leading and trailing separators first, if any, except
-- the leading separator from the first path. But it is not necessary.
-- Instead we can avoid adding a separator if it is already present.
Array.fromStream . Array.concatSepBy (charToWord $ primarySeparator os)
------------------------------------------------------------------------------
-- Equality
------------------------------------------------------------------------------
eqPathBytes :: Array a -> Array a -> Bool
eqPathBytes = Array.byteEq
-- On posix macOs can have case insensitive comparison. On Windows also
-- case sensitive behavior may depend on the file system being used.
-- Use eq prefix?
-- | Options for path comparison operation. By default path comparison uses a
-- strict criteria for equality. The following options are provided to
-- control the strictness.
--
-- The default configuration is as follows:
--
-- >>> :{
-- defaultMod = ignoreTrailingSeparators False
-- . ignoreCase False
-- . allowRelativeEquality False
-- :}
--
data EqCfg =
EqCfg
{ _ignoreTrailingSeparators :: Bool -- ^ Allows "x\/" == "x"
, _ignoreCase :: Bool -- ^ Allows "x" == \"X\"
, _allowRelativeEquality :: Bool
-- ^ A leading dot is ignored, thus ".\/x" == ".\/x" and ".\/x" == "x".
-- On Windows allows "\/x" == \/x" and "C:x == C:x"
-- , resolveParentReferences -- "x\/..\/y" == "y"
-- , noIgnoreRedundantSeparators -- "x\/\/y" \/= "x\/y"
-- , noIgnoreRedundantDot -- "x\/.\/" \/= "x"
}
data PosixRoot = PosixRootAbs | PosixRootRel deriving Eq
data WindowsRoot =
WindowsRootPosix -- /x or ./x
| WindowsRootNonPosix -- C:... or \\...
deriving Eq
-- | Change to upper case and replace separators by primary separator
{-# INLINE normalizeCaseAndSeparators #-}
normalizeCaseAndSeparators :: Monad m => Array Word16 -> Stream m Char
normalizeCaseAndSeparators =
fmap toUpper
. Unicode.decodeUtf16le'
. fmap toDefaultSeparator
. Array.read
{-# INLINE normalizeCaseWith #-}
normalizeCaseWith :: (Monad m, Unbox a) =>
(Stream m a -> Stream m Char) -> Array a -> Stream m Char
normalizeCaseWith decoder =
fmap toUpper
. decoder
. Array.read
eqWindowsRootStrict :: (Unbox a, Integral a) =>
Bool -> Array a -> Array a -> Bool
eqWindowsRootStrict ignCase a b =
let f = normalizeCaseAndSeparators
in if ignCase
then
-- XXX We probably do not want to equate UNC with UnC etc.
runIdentity
$ Stream.eqBy (==)
(f $ Array.unsafeCast a) (f $ Array.unsafeCast b)
else
runIdentity
$ Stream.eqBy (==)
(fmap toDefaultSeparator $ Array.read a)
(fmap toDefaultSeparator $ Array.read b)
{-# INLINE eqRootStrict #-}
eqRootStrict :: (Unbox a, Integral a) =>
Bool -> OS -> Array a -> Array a -> Bool
eqRootStrict _ Posix a b =
-- a can be "/" and b can be "//"
-- We call this only when the roots are either absolute or null.
Array.null a == Array.null b
eqRootStrict ignCase Windows a b = eqWindowsRootStrict ignCase a b
-- | Compare Posix roots or Windows roots without a drive or share name.
{-# INLINE eqPosixRootLax #-}
eqPosixRootLax :: (Unbox a, Integral a) => Array a -> Array a -> Bool
eqPosixRootLax a b = getRoot a == getRoot b
where
-- Can only be either "", '.', './' or '/' (or Windows separators)
getRoot arr =
if Array.null arr || unsafeIndexChar 0 arr == '.'
then PosixRootRel
else PosixRootAbs
{-# INLINABLE eqRootLax #-}
eqRootLax :: (Unbox a, Integral a) => Bool -> OS -> Array a -> Array a -> Bool
eqRootLax _ Posix a b = eqPosixRootLax a b
eqRootLax ignCase Windows a b =
let aType = getRootType a
bType = getRootType b
in aType == bType
&& (
(aType == WindowsRootPosix && eqPosixRootLax a b)
|| eqWindowsRootStrict ignCase a b
)
where
getRootType arr =
if isAbsoluteUNC arr || hasDrive arr
then WindowsRootNonPosix
else WindowsRootPosix
{-# INLINE eqComponentsWith #-}
eqComponentsWith :: (Unbox a, Integral a) =>
EqCfg
-> (Stream Identity a -> Stream Identity Char)
-> OS
-> Array a
-> Array a
-> Bool
eqComponentsWith EqCfg{..} decoder os a b =
if _ignoreCase
then
let streamEq x y = runIdentity $ Stream.eqBy (==) x y
toComponents = fmap (normalizeCaseWith decoder) . splitter os
-- XXX check perf/fusion
in runIdentity
$ Stream.eqBy streamEq (toComponents a) (toComponents b)
else
runIdentity
$ Stream.eqBy
Array.byteEq (splitter os a) (splitter os b)
where
splitter = splitPathUsing False _allowRelativeEquality
-- XXX can we do something like SpecConstr for such functions e.g. without
-- inlining the function we can use two copies one for _allowRelativeEquality
-- True and other for False and so on for other values of PathEq.
{-# INLINE eqPath #-}
eqPath :: (Unbox a, Integral a) =>
(Stream Identity a -> Stream Identity Char)
-> OS -> EqCfg -> Array a -> Array a -> Bool
eqPath decoder os eqCfg@(EqCfg{..}) a b =
let (rootA, stemA) = splitRoot os a
(rootB, stemB) = splitRoot os b
eqRelative =
if _allowRelativeEquality
then eqRootLax _ignoreCase os rootA rootB
else (not (isRootRelative os rootA)
&& not (isRootRelative os rootB))
&& eqRootStrict _ignoreCase os rootA rootB
-- XXX If one ends in a "." and the other ends in ./ (and same for ".."
-- and "../") then they can be equal. We can append a slash in these two
-- cases before comparing.
eqTrailingSep =
_ignoreTrailingSeparators
|| hasTrailingSeparator os a == hasTrailingSeparator os b
in
eqRelative
&& eqTrailingSep
&& eqComponentsWith eqCfg decoder os stemA stemB