{-# 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
    , isValidPath
    , isValidPath'
    , validatePath
    , validatePath'
    , validateFile

    -- * Construction
    , fromChunk
    , unsafeFromChunk
    , fromChars
    , unsafeFromChars

    -- * Quasiquoters
    , mkQ

    -- * Elimination
    , toChunk
    , toString
    , toChars

    -- * Separators
    , primarySeparator
    , isSeparator
    , dropTrailingSeparators
    , 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
 -- , addExtension

    -- * Equality
 -- , processParentRefs
    , normalizeSeparators
 -- , normalize -- separators and /./ components (split/combine)
    , eqPathBytes
    , EqCfg(..)
    , eqCfg
    , eqPathWith
    , 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

>>> 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 OS -> OS -> Bool
(OS -> OS -> Bool) -> (OS -> OS -> Bool) -> Eq OS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OS -> OS -> Bool
== :: OS -> OS -> Bool
$c/= :: OS -> OS -> Bool
/= :: OS -> OS -> Bool
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.

-- | 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 :: forall a. Integral a => Char -> a
charToWord Char
c =
    let n :: Int
n = Char -> Int
ord Char
c
     in Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
255) (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)

-- | Unsafe, should be a valid character.
wordToChar :: Integral a => a -> Char
wordToChar :: forall a. Integral a => a -> Char
wordToChar = Int -> Char
unsafeChr (Int -> Char) -> (a -> Int) -> a -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

------------------------------------------------------------------------------
-- Array utils
------------------------------------------------------------------------------

-- | Index a word in an array and convert it to Char.
unsafeIndexChar :: (Unbox a, Integral a) => Int -> Array a -> Char
unsafeIndexChar :: forall a. (Unbox a, Integral a) => Int -> Array a -> Char
unsafeIndexChar Int
i Array a
a = a -> Char
forall a. Integral a => a -> Char
wordToChar (Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndex Int
i Array a
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 :: forall a b. Unbox a => Fold Identity a b -> Array a -> b
foldArr Fold Identity a b
f Array a
arr = Identity b -> b
forall a. Identity a -> a
runIdentity (Identity b -> b) -> Identity b -> b
forall a b. (a -> b) -> a -> b
$ Fold Identity a b -> Array a -> Identity b
forall (m :: * -> *) a b.
(Monad m, Unbox a) =>
Fold m a b -> Array a -> m b
Array.foldM Fold Identity a b
f Array a
arr

{-# INLINE countLeadingBy #-}
countLeadingBy :: Unbox a => (a -> Bool) -> Array a -> Int
countLeadingBy :: forall a. Unbox a => (a -> Bool) -> Array a -> Int
countLeadingBy a -> Bool
p = Fold Identity a Int -> Array a -> Int
forall a b. Unbox a => Fold Identity a b -> Array a -> b
foldArr ((a -> Bool) -> Fold Identity a Int -> Fold Identity a Int
forall (m :: * -> *) a b.
Monad m =>
(a -> Bool) -> Fold m a b -> Fold m a b
Fold.takeEndBy_ (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p) Fold Identity a Int
forall (m :: * -> *) a. Monad m => Fold m a Int
Fold.length)

countTrailingBy :: Unbox a => (a -> Bool) -> Array a -> Int
countTrailingBy :: forall a. Unbox a => (a -> Bool) -> Array a -> Int
countTrailingBy a -> Bool
p = Fold Identity a Int -> Array a -> Int
forall a b. Unbox a => Fold Identity a b -> Array a -> b
Array.foldRev ((a -> Bool) -> Fold Identity a Int -> Fold Identity a Int
forall (m :: * -> *) a b.
Monad m =>
(a -> Bool) -> Fold m a b -> Fold m a b
Fold.takeEndBy_ (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p) Fold Identity a Int
forall (m :: * -> *) a. Monad m => Fold m a Int
Fold.length)

------------------------------------------------------------------------------
-- Separator parsing
------------------------------------------------------------------------------

extensionWord :: Integral a => a
extensionWord :: forall a. Integral a => a
extensionWord = Char -> a
forall a. Integral a => Char -> a
charToWord Char
'.'

posixSeparator :: Char
posixSeparator :: Char
posixSeparator = Char
'/'

windowsSeparator :: Char
windowsSeparator :: Char
windowsSeparator = Char
'\\'

-- | 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 :: OS -> Char
primarySeparator OS
Posix = Char
posixSeparator
primarySeparator OS
Windows = Char
windowsSeparator

-- | On Posix only @/@ is a path separator but in windows it could be either
-- @/@ or @\\@.
{-# INLINE isSeparator #-}
isSeparator :: OS -> Char -> Bool
isSeparator :: OS -> Char -> Bool
isSeparator OS
Posix Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
posixSeparator
isSeparator OS
Windows Char
c = (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
windowsSeparator) Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
posixSeparator)

{-# INLINE isSeparatorWord #-}
isSeparatorWord :: Integral a => OS -> a -> Bool
isSeparatorWord :: forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
os = OS -> Char -> Bool
isSeparator OS
os (Char -> Bool) -> (a -> Char) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Char
forall a. Integral a => a -> Char
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 ':'.
{-# INLINE dropTrailingBy #-}
dropTrailingBy :: (Unbox a, Integral a) =>
    OS -> (a -> Bool) -> Array a -> Array a
dropTrailingBy :: forall a.
(Unbox a, Integral a) =>
OS -> (a -> Bool) -> Array a -> Array a
dropTrailingBy OS
os a -> Bool
p Array a
arr =
    let len :: Int
len = Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
arr
        n :: Int
n = (a -> Bool) -> Array a -> Int
forall a. Unbox a => (a -> Bool) -> Array a -> Int
countTrailingBy a -> Bool
p Array a
arr
        arr1 :: Array a
arr1 = (Array a, Array a) -> Array a
forall a b. (a, b) -> a
fst ((Array a, Array a) -> Array a) -> (Array a, Array a) -> Array a
forall a b. (a -> b) -> a -> b
$ Int -> Array a -> (Array a, Array a)
forall a. Unbox a => Int -> Array a -> (Array a, Array a)
Array.unsafeBreakAt (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Array a
arr
     in if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then Array a
arr
        else if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len -- "////"
        then (Array a, Array a) -> Array a
forall a b. (a, b) -> a
fst ((Array a, Array a) -> Array a) -> (Array a, Array a) -> Array a
forall a b. (a -> b) -> a -> b
$ Int -> Array a -> (Array a, Array a)
forall a. Unbox a => Int -> Array a -> (Array a, Array a)
Array.unsafeBreakAt Int
1 Array a
arr
        -- "c:////"
        else if (OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
Windows)
                Bool -> Bool -> Bool
&& (Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndex (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Array a
arr a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> a
forall a. Integral a => Char -> a
charToWord Char
':')
        then (Array a, Array a) -> Array a
forall a b. (a, b) -> a
fst ((Array a, Array a) -> Array a) -> (Array a, Array a) -> Array a
forall a b. (a -> b) -> a -> b
$ Int -> Array a -> (Array a, Array a)
forall a. Unbox a => Int -> Array a -> (Array a, Array a)
Array.unsafeBreakAt (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Array a
arr
        else Array a
arr1

{-# INLINE compactTrailingBy #-}
compactTrailingBy :: Unbox a => (a -> Bool) -> Array a -> Array a
compactTrailingBy :: forall a. Unbox a => (a -> Bool) -> Array a -> Array a
compactTrailingBy a -> Bool
p Array a
arr =
    let len :: Int
len = Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
arr
        n :: Int
n = (a -> Bool) -> Array a -> Int
forall a. Unbox a => (a -> Bool) -> Array a -> Int
countTrailingBy a -> Bool
p Array a
arr
     in if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
        then Array a
arr
        else (Array a, Array a) -> Array a
forall a b. (a, b) -> a
fst ((Array a, Array a) -> Array a) -> (Array a, Array a) -> Array a
forall a b. (a -> b) -> a -> b
$ Int -> Array a -> (Array a, Array a)
forall a. Unbox a => Int -> Array a -> (Array a, Array a)
Array.unsafeBreakAt (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Array a
arr

-- | 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:/".
--
-- Note that a path with trailing separators may implicitly be considered as a
-- directory by some applications. So dropping it may change the dir nature of
-- the path.
--
-- >>> f a = unpackPosix $ Common.dropTrailingSeparators Common.Posix (packPosix a)
-- >>> f "./"
-- "."
--
{-# INLINE dropTrailingSeparators #-}
dropTrailingSeparators :: (Unbox a, Integral a) => OS -> Array a -> Array a
dropTrailingSeparators :: forall a. (Unbox a, Integral a) => OS -> Array a -> Array a
dropTrailingSeparators OS
os =
    OS -> (a -> Bool) -> Array a -> Array a
forall a.
(Unbox a, Integral a) =>
OS -> (a -> Bool) -> Array a -> Array a
dropTrailingBy OS
os (OS -> Char -> Bool
isSeparator OS
os (Char -> Bool) -> (a -> Char) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Char
forall a. Integral a => a -> Char
wordToChar)

-- | A path starting with a separator.
hasLeadingSeparator :: (Unbox a, Integral a) => OS -> Array a -> Bool
hasLeadingSeparator :: forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
hasLeadingSeparator OS
os Array a
a
    | Array a -> Bool
forall a. Array a -> Bool
Array.null Array a
a = Bool
False -- empty path should not occur
    | OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
os (Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndex Int
0 Array a
a) = Bool
True
    | Bool
otherwise = Bool
False

{-# INLINE hasTrailingSeparator #-}
hasTrailingSeparator :: (Integral a, Unbox a) => OS -> Array a -> Bool
hasTrailingSeparator :: forall a. (Integral a, Unbox a) => OS -> Array a -> Bool
hasTrailingSeparator OS
os Array a
path =
    let e :: Maybe a
e = Int -> Array a -> Maybe a
forall a. Unbox a => Int -> Array a -> Maybe a
Array.getIndexRev Int
0 Array a
path
     in case Maybe a
e of
            Maybe a
Nothing -> Bool
False
            Just a
x -> OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
os a
x

{-# INLINE toDefaultSeparator #-}
toDefaultSeparator :: Integral a => a -> a
toDefaultSeparator :: forall a. Integral a => a -> a
toDefaultSeparator a
x =
    if OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
Windows a
x
    then Char -> a
forall a. Integral a => Char -> a
charToWord (OS -> Char
primarySeparator OS
Windows)
    else a
x

-- | Change all separators in the path to default separator on windows.
{-# INLINE normalizeSeparators #-}
normalizeSeparators :: (Integral a, Unbox a) => Array a -> Array a
normalizeSeparators :: forall a. (Integral a, Unbox a) => Array a -> Array a
normalizeSeparators Array a
a =
    -- XXX We can check and return the original array if no change is needed.
    Int -> Stream Identity a -> Array a
forall a. Unbox a => Int -> Stream Identity a -> Array a
Array.fromPureStreamN (Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
a)
        (Stream Identity a -> Array a) -> Stream Identity a -> Array a
forall a b. (a -> b) -> a -> b
$ (a -> a) -> Stream Identity a -> Stream Identity a
forall a b. (a -> b) -> Stream Identity a -> Stream Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Integral a => a -> a
toDefaultSeparator
        (Stream Identity a -> Stream Identity a)
-> Stream Identity a -> Stream Identity a
forall a b. (a -> b) -> a -> b
$ Array a -> Stream Identity a
forall (m :: * -> *) a. (Monad m, Unbox a) => Array a -> Stream m a
Array.read Array a
a

------------------------------------------------------------------------------
-- Windows drive parsing
------------------------------------------------------------------------------

-- | @C:...@, does not check array length.
{-# INLINE unsafeHasDrive #-}
unsafeHasDrive :: (Unbox a, Integral a) => Array a -> Bool
unsafeHasDrive :: forall a. (Unbox a, Integral a) => Array a -> Bool
unsafeHasDrive Array a
a
    -- Check colon first for quicker return
    | Int -> Array a -> Char
forall a. (Unbox a, Integral a) => Int -> Array a -> Char
unsafeIndexChar Int
1 Array a
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':' = Bool
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
    | Bool -> Bool
not (Char -> Bool
isAlpha (Int -> Array a -> Char
forall a. (Unbox a, Integral a) => Int -> Array a -> Char
unsafeIndexChar Int
0 Array a
a)) = Bool
False
    | Bool
otherwise = Bool
True

-- | A path that starts with a alphabet followed by a colon e.g. @C:...@.
hasDrive :: (Unbox a, Integral a) => Array a -> Bool
hasDrive :: forall a. (Unbox a, Integral a) => Array a -> Bool
hasDrive Array a
a = Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
unsafeHasDrive Array a
a

-- | A path that contains only an alphabet followed by a colon e.g. @C:@.
isDrive :: (Unbox a, Integral a) => Array a -> Bool
isDrive :: forall a. (Unbox a, Integral a) => Array a -> Bool
isDrive Array a
a = Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
&& Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
unsafeHasDrive Array a
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 :: forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
isRelativeCurDir OS
os Array a
a
    | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Bool
False -- empty path should not occur
    | a -> Char
forall a. Integral a => a -> Char
wordToChar (Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndex Int
0 Array a
a) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.' = Bool
False
    | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = Bool
True
    | Bool
otherwise = OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
os (Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndex Int
1 Array a
a)

    where

    len :: Int
len = Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
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 :: forall a. (Unbox a, Integral a) => Array a -> Bool
isRelativeCurDriveRoot Array a
a
    | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Bool
False -- empty path should not occur
    | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Bool
sep0 = Bool
True
    | Bool
sep0 Bool -> Bool -> Bool
&& a
c0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
c1 = Bool
True -- "\\/share/x" is treated as "C:/share/x".
    | Bool
otherwise = Bool
False

    where

    len :: Int
len = Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
a
    c0 :: a
c0 = Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndex Int
0 Array a
a
    c1 :: a
c1 = Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndex Int
1 Array a
a
    sep0 :: Bool
sep0 = OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
Windows a
c0

-- | @C:@ or @C:a...@.
isRelativeWithDrive :: (Unbox a, Integral a) => Array a -> Bool
isRelativeWithDrive :: forall a. (Unbox a, Integral a) => Array a -> Bool
isRelativeWithDrive Array a
a =
    Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
hasDrive Array a
a
        Bool -> Bool -> Bool
&& (  Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3
           Bool -> Bool -> Bool
|| Bool -> Bool
not (OS -> Char -> Bool
isSeparator OS
Windows (Int -> Array a -> Char
forall a. (Unbox a, Integral a) => Int -> Array a -> Char
unsafeIndexChar Int
2 Array a
a))
           )

isRootRelative :: (Unbox a, Integral a) => OS -> Array a -> Bool
isRootRelative :: forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
isRootRelative OS
Posix Array a
a = OS -> Array a -> Bool
forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
isRelativeCurDir OS
Posix Array a
a
isRootRelative OS
Windows Array a
a =
    OS -> Array a -> Bool
forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
isRelativeCurDir OS
Windows Array a
a
        Bool -> Bool -> Bool
|| Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
isRelativeCurDriveRoot Array a
a
        Bool -> Bool -> Bool
|| Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
isRelativeWithDrive Array a
a

-- | @C:\...@. Note that "C:" or "C:a" is not absolute.
isAbsoluteWithDrive :: (Unbox a, Integral a) => Array a -> Bool
isAbsoluteWithDrive :: forall a. (Unbox a, Integral a) => Array a -> Bool
isAbsoluteWithDrive Array a
a =
    Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3
        Bool -> Bool -> Bool
&& Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
unsafeHasDrive Array a
a
        Bool -> Bool -> Bool
&& OS -> Char -> Bool
isSeparator OS
Windows (Int -> Array a -> Char
forall a. (Unbox a, Integral a) => Int -> Array a -> Char
unsafeIndexChar Int
2 Array a
a)

-- | @\\\\...@ or @//...@
isAbsoluteUNC :: (Unbox a, Integral a) => Array a -> Bool
isAbsoluteUNC :: forall a. (Unbox a, Integral a) => Array a -> Bool
isAbsoluteUNC Array a
a
    | Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = Bool
False
    | OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
Windows a
c0 Bool -> Bool -> Bool
&& a
c0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
c1 = Bool
True
    | Bool
otherwise = Bool
False

    where

    c0 :: a
c0 = Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndex Int
0 Array a
a
    c1 :: a
c1 = Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndex Int
1 Array a
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 :: forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
isAbsolute OS
Posix Array a
arr =
    OS -> Array a -> Bool
forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
hasLeadingSeparator OS
Posix Array a
arr
isAbsolute OS
Windows Array a
arr =
    Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
isAbsoluteWithDrive Array a
arr Bool -> Bool -> Bool
|| Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
isAbsoluteUNC Array a
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

-- | Any path that starts with a separator, @./@ or a drive prefix is a rooted
-- path.
--
-- Rooted paths on Posix and Windows,
-- * @/...@ a path starting with a separator
-- * @.@ current dir
-- * @./...@ a location relative to current dir
--
-- Rooted paths on Windows:
-- * @C:@ local drive cur dir location
-- * @C:a\\b@ local drive relative to cur dir location
-- * @C:\\@ local drive absolute location
-- * @\\@ local path relative to current drive
-- * @\\\\share\\@ UNC network location
-- * @\\\\?\\C:\\@ Long UNC local path
-- * @\\\\?\\UNC\\@ Long UNC server location
-- * @\\\\.\\@ DOS local device namespace
-- * @\\\\??\\@ DOS global namespace
--
-- >>> fPosix = Common.isRooted Common.Posix . packPosix
-- >>> fWin = Common.isRooted Common.Windows . packPosix
--
-- >>> fPosix "/"
-- True
-- >>> fPosix "/x"
-- True
-- >>> fPosix "."
-- True
-- >>> fPosix "./x"
-- True
-- >>> fPosix ".."
-- False
-- >>> fPosix "../x"
-- False
--
-- >>> fWin "/"
-- True
-- >>> fWin "/x"
-- True
-- >>> fWin "."
-- True
-- >>> fWin "./x"
-- True
-- >>> fWin ".."
-- False
-- >>> fWin "../x"
-- False
-- >>> fWin "c:"
-- True
-- >>> fWin "c:x"
-- True
-- >>> fWin "c:/"
-- True
-- >>> fWin "//x/y"
-- True
--
isRooted :: (Unbox a, Integral a) => OS -> Array a -> Bool
isRooted :: forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
isRooted OS
Posix Array a
a =
    OS -> Array a -> Bool
forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
hasLeadingSeparator OS
Posix Array a
a
        Bool -> Bool -> Bool
|| OS -> Array a -> Bool
forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
isRelativeCurDir OS
Posix Array a
a
isRooted OS
Windows Array a
a =
    OS -> Array a -> Bool
forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
hasLeadingSeparator OS
Windows Array a
a
        Bool -> Bool -> Bool
|| OS -> Array a -> Bool
forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
isRelativeCurDir OS
Windows Array a
a
        Bool -> Bool -> Bool
|| Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
hasDrive Array a
a -- curdir-in-drive relative, drive absolute

isBranch :: (Unbox a, Integral a) => OS -> Array a -> Bool
isBranch :: forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
isBranch OS
os = Bool -> Bool
not (Bool -> Bool) -> (Array a -> Bool) -> Array a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OS -> Array a -> Bool
forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
isRooted OS
os

------------------------------------------------------------------------------
-- Split root
------------------------------------------------------------------------------

unsafeSplitPrefix :: (Unbox a, Integral a) =>
    OS -> Int -> Array a -> (Array a, Array a)
unsafeSplitPrefix :: forall a.
(Unbox a, Integral a) =>
OS -> Int -> Array a -> (Array a, Array a)
unsafeSplitPrefix OS
os Int
prefixLen Array a
arr =
    Int -> Array a -> (Array a, Array a)
forall a. Unbox a => Int -> Array a -> (Array a, Array a)
Array.unsafeBreakAt Int
cnt Array a
arr

    where

    afterDrive :: Array a
afterDrive = (Array a, Array a) -> Array a
forall a b. (a, b) -> b
snd ((Array a, Array a) -> Array a) -> (Array a, Array a) -> Array a
forall a b. (a -> b) -> a -> b
$ Int -> Array a -> (Array a, Array a)
forall a. Unbox a => Int -> Array a -> (Array a, Array a)
Array.unsafeBreakAt Int
prefixLen Array a
arr
    n :: Int
n = (a -> Bool) -> Array a -> Int
forall a. Unbox a => (a -> Bool) -> Array a -> Int
countLeadingBy (OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
os) Array a
afterDrive
    cnt :: Int
cnt = Int
prefixLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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 :: forall a.
(Unbox a, Integral a) =>
OS -> Array a -> (Array a, Array a)
unsafeSplitTopLevel OS
os = OS -> Int -> Array a -> (Array a, Array a)
forall a.
(Unbox a, Integral a) =>
OS -> Int -> Array a -> (Array a, Array a)
unsafeSplitPrefix OS
os Int
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 :: forall a. (Unbox a, Integral a) => Array a -> (Array a, Array a)
unsafeSplitDrive = OS -> Int -> Array a -> (Array a, Array a)
forall a.
(Unbox a, Integral a) =>
OS -> Int -> Array a -> (Array a, Array a)
unsafeSplitPrefix OS
Windows Int
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 :: forall a. (Unbox a, Integral a) => Array a -> Int -> (Int, Int)
parseSegment Array a
arr Int
sepOff = (Int
segOff, Int
segCnt)

    where

    arr1 :: Array a
arr1 = (Array a, Array a) -> Array a
forall a b. (a, b) -> b
snd ((Array a, Array a) -> Array a) -> (Array a, Array a) -> Array a
forall a b. (a -> b) -> a -> b
$ Int -> Array a -> (Array a, Array a)
forall a. Unbox a => Int -> Array a -> (Array a, Array a)
Array.unsafeBreakAt Int
sepOff Array a
arr
    sepCnt :: Int
sepCnt = (a -> Bool) -> Array a -> Int
forall a. Unbox a => (a -> Bool) -> Array a -> Int
countLeadingBy (OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
Windows) Array a
arr1
    segOff :: Int
segOff = Int
sepOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sepCnt

    arr2 :: Array a
arr2 = (Array a, Array a) -> Array a
forall a b. (a, b) -> b
snd ((Array a, Array a) -> Array a) -> (Array a, Array a) -> Array a
forall a b. (a -> b) -> a -> b
$ Int -> Array a -> (Array a, Array a)
forall a. Unbox a => Int -> Array a -> (Array a, Array a)
Array.unsafeBreakAt Int
segOff Array a
arr
    segCnt :: Int
segCnt = (a -> Bool) -> Array a -> Int
forall a. Unbox a => (a -> Bool) -> Array a -> Int
countLeadingBy (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
Windows) Array a
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 :: forall a. (Unbox a, Integral a) => Array a -> (Array a, Array a)
unsafeSplitUNC Array a
arr =
    if Int
cnt1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Int -> Array a -> Char
forall a. (Unbox a, Integral a) => Int -> Array a -> Char
unsafeIndexChar Int
2 Array a
arr Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'?'
    then do
        if Int
uncLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
                Bool -> Bool -> Bool
&& Int -> Array a -> Char
forall a. (Unbox a, Integral a) => Int -> Array a -> Char
unsafeIndexChar Int
uncOff Array a
arr Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'U'
                Bool -> Bool -> Bool
&& Int -> Array a -> Char
forall a. (Unbox a, Integral a) => Int -> Array a -> Char
unsafeIndexChar (Int
uncOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Array a
arr Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'N'
                Bool -> Bool -> Bool
&& Int -> Array a -> Char
forall a. (Unbox a, Integral a) => Int -> Array a -> Char
unsafeIndexChar (Int
uncOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Array a
arr Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'C'
        then OS -> Int -> Array a -> (Array a, Array a)
forall a.
(Unbox a, Integral a) =>
OS -> Int -> Array a -> (Array a, Array a)
unsafeSplitPrefix OS
Windows (Int
serverOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
serverLen) Array a
arr
        else OS -> Int -> Array a -> (Array a, Array a)
forall a.
(Unbox a, Integral a) =>
OS -> Int -> Array a -> (Array a, Array a)
unsafeSplitPrefix OS
Windows Int
sepOff1 Array a
arr
    else OS -> Int -> Array a -> (Array a, Array a)
forall a.
(Unbox a, Integral a) =>
OS -> Int -> Array a -> (Array a, Array a)
unsafeSplitPrefix OS
Windows Int
sepOff Array a
arr

    where

    arr1 :: Array a
arr1 = (Array a, Array a) -> Array a
forall a b. (a, b) -> b
snd ((Array a, Array a) -> Array a) -> (Array a, Array a) -> Array a
forall a b. (a -> b) -> a -> b
$ Int -> Array a -> (Array a, Array a)
forall a. Unbox a => Int -> Array a -> (Array a, Array a)
Array.unsafeBreakAt Int
2 Array a
arr
    cnt1 :: Int
cnt1 = (a -> Bool) -> Array a -> Int
forall a. Unbox a => (a -> Bool) -> Array a -> Int
countLeadingBy (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
Windows) Array a
arr1
    sepOff :: Int
sepOff = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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
    (Int
uncOff, Int
uncLen) = Array a -> Int -> (Int, Int)
forall a. (Unbox a, Integral a) => Array a -> Int -> (Int, Int)
parseSegment Array a
arr Int
sepOff
    sepOff1 :: Int
sepOff1 = Int
uncOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
uncLen
    (Int
serverOff, Int
serverLen) = Array a -> Int -> (Int, Int)
forall a. (Unbox a, Integral a) => Array a -> Int -> (Int, Int)
parseSegment Array a
arr Int
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?

-- | If a path is rooted then separate the root and the remaining path
-- otherwise root is returned as empty. If the path is rooted then the non-root
-- part is guaranteed to not start with a separator.
--
-- >>> toListPosix (a,b) = (unpackPosix a, unpackPosix b)
-- >>> splitPosix = toListPosix . Common.splitRoot Common.Posix . packPosix
-- >>> toListWin (a,b) = (unpackWindows a, unpackWindows b)
-- >>> splitWin = toListWin . Common.splitRoot Common.Windows . packWindows
--
-- >>> splitPosix "/"
-- ("/","")
--
-- >>> splitPosix "."
-- (".","")
--
-- >>> splitPosix "./"
-- ("./","")
--
-- >>> splitPosix "/home"
-- ("/","home")
--
-- >>> splitPosix "//"
-- ("//","")
--
-- >>> splitPosix "./home"
-- ("./","home")
--
-- >>> splitPosix "home"
-- ("","home")
--
-- >>> splitWin "c:"
-- ("c:","")
--
-- >>> splitWin "c:/"
-- ("c:/","")
--
-- >>> splitWin "//"
-- ("//","")
--
-- >>> splitWin "//x/y"
-- ("//x/","y")
--
--
{-# 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 :: forall a.
(Unbox a, Integral a) =>
OS -> Array a -> (Array a, Array a)
splitRoot OS
Posix Array a
arr
    | OS -> Array a -> Bool
forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
isRooted OS
Posix Array a
arr
        = OS -> Array a -> (Array a, Array a)
forall a.
(Unbox a, Integral a) =>
OS -> Array a -> (Array a, Array a)
unsafeSplitTopLevel OS
Posix Array a
arr
    | Bool
otherwise = (Array a
forall a. Array a
Array.empty, Array a
arr)
splitRoot OS
Windows Array a
arr
    | Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
isRelativeCurDriveRoot Array a
arr Bool -> Bool -> Bool
|| OS -> Array a -> Bool
forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
isRelativeCurDir OS
Windows Array a
arr
        = OS -> Array a -> (Array a, Array a)
forall a.
(Unbox a, Integral a) =>
OS -> Array a -> (Array a, Array a)
unsafeSplitTopLevel OS
Windows Array a
arr
    | Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
hasDrive Array a
arr = Array a -> (Array a, Array a)
forall a. (Unbox a, Integral a) => Array a -> (Array a, Array a)
unsafeSplitDrive Array a
arr
    | Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
isAbsoluteUNC Array a
arr = Array a -> (Array a, Array a)
forall a. (Unbox a, Integral a) => Array a -> (Array a, Array a)
unsafeSplitUNC Array a
arr
    | Bool
otherwise = (Array a
forall a. Array a
Array.empty, Array a
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 :: forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
((Int, Int) -> Bool) -> Bool -> OS -> Array a -> Stream m (Array a)
splitWithFilter (Int, Int) -> Bool
filt Bool
withSep OS
os Array a
arr =
      (a -> Bool) -> Stream m a -> Stream m (Int, Int)
forall {a}. (a -> Bool) -> Stream m a -> Stream m (Int, Int)
f (OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
os) (Array a -> Stream m a
forall (m :: * -> *) a. (Monad m, Unbox a) => Array a -> Stream m a
Array.read Array a
arr)
    Stream m (Int, Int)
-> (Stream m (Int, Int) -> Stream m (Int, Int))
-> Stream m (Int, Int)
forall a b. a -> (a -> b) -> b
& ((Int, Int) -> Bool) -> Stream m (Int, Int) -> Stream m (Int, Int)
forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> Stream m a -> Stream m a
Stream.filter (Int, Int) -> Bool
filt
    Stream m (Int, Int)
-> (Stream m (Int, Int) -> Stream m (Array a))
-> Stream m (Array a)
forall a b. a -> (a -> b) -> b
& ((Int, Int) -> Array a)
-> Stream m (Int, Int) -> Stream m (Array a)
forall a b. (a -> b) -> Stream m a -> Stream m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Int
i, Int
len) -> Int -> Int -> Array a -> Array a
forall a. Unbox a => Int -> Int -> Array a -> Array a
Array.unsafeSliceOffLen Int
i Int
len Array a
arr)

    where

    f :: (a -> Bool) -> Stream m a -> Stream m (Int, Int)
f = if Bool
withSep then (a -> Bool) -> Stream m a -> Stream m (Int, Int)
forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> Stream m a -> Stream m (Int, Int)
Stream.indexEndBy else (a -> Bool) -> Stream m a -> Stream m (Int, Int)
forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> Stream m a -> Stream m (Int, Int)
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 :: forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
Bool -> OS -> Array a -> Stream m (Array a)
splitCompact Bool
withSep OS
os Array a
arr =
    ((Int, Int) -> Bool) -> Bool -> OS -> Array a -> Stream m (Array a)
forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
((Int, Int) -> Bool) -> Bool -> OS -> Array a -> Stream m (Array a)
splitWithFilter (Bool -> Bool
not (Bool -> Bool) -> ((Int, Int) -> Bool) -> (Int, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Bool
forall {a}. (Num a, Eq a) => (Int, a) -> Bool
shouldFilterOut) Bool
withSep OS
os Array a
arr

    where

    sepFilter :: (Int, a) -> Bool
sepFilter (Int
off, a
len) =
        ( a
len a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1
        Bool -> Bool -> Bool
&& OS -> Char -> Bool
isSeparator OS
os (Int -> Array a -> Char
forall a. (Unbox a, Integral a) => Int -> Array a -> Char
unsafeIndexChar Int
off Array a
arr)
        )
        Bool -> Bool -> Bool
||
        -- Note, last component may have len == 2 but second char may not
        -- be slash, so we need to check for slash explicitly.
        --
        ( a
len a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
2
        Bool -> Bool -> Bool
&& Int -> Array a -> Char
forall a. (Unbox a, Integral a) => Int -> Array a -> Char
unsafeIndexChar Int
off Array a
arr Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.'
        Bool -> Bool -> Bool
&& OS -> Char -> Bool
isSeparator OS
os (Int -> Array a -> Char
forall a. (Unbox a, Integral a) => Int -> Array a -> Char
unsafeIndexChar (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Array a
arr)
        )

    {-# INLINE shouldFilterOut #-}
    shouldFilterOut :: (Int, a) -> Bool
shouldFilterOut (Int
off, a
len) =
        a
len a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
            -- Note this is needed even when withSep is true - for the last
            -- component case.
            Bool -> Bool -> Bool
|| (a
len a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 Bool -> Bool -> Bool
&& Int -> Array a -> Char
forall a. (Unbox a, Integral a) => Int -> Array a -> Char
unsafeIndexChar Int
off Array a
arr Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.')
            -- XXX Ensure that these are statically removed by GHC when withSep
            -- is False.
            Bool -> Bool -> Bool
|| (Bool
withSep Bool -> Bool -> Bool
&& (Int, a) -> Bool
forall {a}. (Num a, Eq a) => (Int, a) -> Bool
sepFilter (Int
off, a
len))

{-# INLINE splitPathUsing #-}
splitPathUsing
    :: (Unbox a, Integral a, Monad m)
    => Bool
    -> OS
    -> Array a
    -> Stream m (Array a)
splitPathUsing :: forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
Bool -> OS -> Array a -> Stream m (Array a)
splitPathUsing Bool
withSep OS
os Array a
arr =
    let stream :: Stream m (Array a)
stream = Bool -> OS -> Array a -> Stream m (Array a)
forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
Bool -> OS -> Array a -> Stream m (Array a)
splitCompact Bool
withSep OS
os Array a
rest
    in if Array a -> Bool
forall a. Array a -> Bool
Array.null Array a
root
       then Stream m (Array a)
stream
       else Array a -> Stream m (Array a) -> Stream m (Array a)
forall (m :: * -> *) a.
Applicative m =>
a -> Stream m a -> Stream m a
Stream.cons Array a
root1 Stream m (Array a)
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.
    (Array a
root, Array a
rest) = OS -> Array a -> (Array a, Array a)
forall a.
(Unbox a, Integral a) =>
OS -> Array a -> (Array a, Array a)
splitRoot OS
os Array a
arr
    root1 :: Array a
root1 =
        if Bool
withSep
        then (a -> Bool) -> Array a -> Array a
forall a. Unbox a => (a -> Bool) -> Array a -> Array a
compactTrailingBy (OS -> Char -> Bool
isSeparator OS
os (Char -> Bool) -> (a -> Char) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Char
forall a. Integral a => a -> Char
wordToChar) Array a
root
        else OS -> Array a -> Array a
forall a. (Unbox a, Integral a) => OS -> Array a -> Array a
dropTrailingSeparators OS
os Array a
root

-- | Split a path into components separated by the path separator. "."
-- components in the path are ignored except when in the leading position.
-- Trailing separators in non-root components are dropped.
--
-- >>> :{
--  splitPosix = Stream.toList . fmap unpackPosix . Common.splitPath_ Common.Posix . packPosix
--  splitWin = Stream.toList . fmap unpackWindows . Common.splitPath_ Common.Windows . packWindows
-- :}
--
-- >>> splitPosix "."
-- ["."]
--
-- >>> splitPosix "././"
-- ["."]
--
-- >>> splitPosix ".//"
-- ["."]
--
-- >>> splitWin "c:x"
-- ["c:","x"]
--
-- >>> splitWin "c:/" -- Note, c:/ is not the same as c:
-- ["c:/"]
--
-- >>> splitWin "c:/x"
-- ["c:/","x"]
--
-- >>> splitPosix "//"
-- ["/"]
--
-- >>> splitPosix "//x/y/"
-- ["/","x","y"]
--
-- >>> splitWin "//x/y/"
-- ["//x","y"]
--
-- >>> splitPosix "./a"
-- [".","a"]
--
-- >>> splitWin "./a"
-- [".","a"]
--
-- >>> splitWin "c:./a"
-- ["c:","a"]
--
-- >>> splitPosix "a/."
-- ["a"]
--
-- >>> splitWin "a/."
-- ["a"]
--
-- >>> splitPosix "/"
-- ["/"]
--
-- >>> splitPosix "/x"
-- ["/","x"]
--
-- >>> splitWin "/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"]
--
-- >>> splitWin "/x/\\y"
-- ["/","x","y"]
--
-- >>> splitWin "\\x/\\y"
-- ["\\","x","y"]
--
{-# INLINE splitPath_ #-}
splitPath_
    :: (Unbox a, Integral a, Monad m)
    => OS -> Array a -> Stream m (Array a)
splitPath_ :: forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
OS -> Array a -> Stream m (Array a)
splitPath_ = Bool -> OS -> Array a -> Stream m (Array a)
forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
Bool -> OS -> Array a -> Stream m (Array a)
splitPathUsing Bool
False

-- | Split the path components keeping separators between path components
-- attached to the dir part. Redundant separators are removed, only the first
-- one is kept, but separators are not changed to the default on Windows.
-- Separators are not added either e.g. "." and ".." may not have trailing
-- separators if the original path does not.
--
-- >>> :{
--  splitPosix = Stream.toList . fmap unpackPosix . Common.splitPath Common.Posix . packPosix
--  splitWin = Stream.toList . fmap unpackWindows . Common.splitPath Common.Windows . packWindows
-- :}
--
-- >>> splitPosix "."
-- ["."]
--
-- >>> splitPosix "././"
-- ["./"]
--
-- >>> splitPosix "./a/b/."
-- ["./","a/","b/"]
--
-- >>> splitPosix ".."
-- [".."]
--
-- >>> splitPosix "../"
-- ["../"]
--
-- >>> splitPosix "a/.."
-- ["a/",".."]
--
-- >>> splitPosix "/"
-- ["/"]
--
-- >>> splitPosix "//"
-- ["/"]
--
-- >>> splitPosix "/x"
-- ["/","x"]
--
-- >>> splitWin "/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"]
--
-- >>> splitWin "/x/\\y"
-- ["/","x/","y"]
--
-- >>> splitWin "\\x/\\y" -- this is not valid, multiple seps after share?
-- ["\\","x/","y"]
--
{-# INLINE splitPath #-}
splitPath
    :: (Unbox a, Integral a, Monad m)
    => OS -> Array a -> Stream m (Array a)
splitPath :: forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
OS -> Array a -> Stream m (Array a)
splitPath = Bool -> OS -> Array a -> Stream m (Array a)
forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
Bool -> OS -> Array a -> Stream m (Array a)
splitPathUsing Bool
True

-- | Split the first non-empty path component.
--
-- /Unimplemented/
{-# INLINE splitHead #-}
splitHead :: -- (Unbox a, Integral a) =>
    OS -> Array a -> (Array a, Array a)
splitHead :: forall a. OS -> Array a -> (Array a, Array a)
splitHead OS
_os Array a
_arr = (Array a, Array a)
forall a. (?callStack::CallStack) => a
undefined

-- | Split the last non-empty path component.
--
-- /Unimplemented/
{-# INLINE splitTail #-}
splitTail :: -- (Unbox a, Integral a) =>
    OS -> Array a -> (Array a, Array a)
splitTail :: forall a. OS -> Array a -> (Array a, Array a)
splitTail OS
_os Array a
_arr = (Array a, Array a)
forall a. (?callStack::CallStack) => a
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 :: forall (m :: * -> *) a.
(MonadThrow m, Unbox a, Integral a) =>
OS -> Array a -> m ()
validateFile OS
os Array a
arr = do
    [Char]
s1 <-
            Stream m Char -> m [Char]
forall (m :: * -> *) a. Monad m => Stream m a -> m [a]
Stream.toList
                (Stream m Char -> m [Char]) -> Stream m Char -> m [Char]
forall a b. (a -> b) -> a -> b
$ Int -> Stream m Char -> Stream m Char
forall (m :: * -> *) a.
Applicative m =>
Int -> Stream m a -> Stream m a
Stream.take Int
3
                (Stream m Char -> Stream m Char) -> Stream m Char -> Stream m Char
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Stream m Char -> Stream m Char
forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> Stream m a -> Stream m a
Stream.takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OS -> Char -> Bool
isSeparator OS
os)
                (Stream m Char -> Stream m Char) -> Stream m Char -> Stream m Char
forall a b. (a -> b) -> a -> b
$ (a -> Char) -> Stream m a -> Stream m Char
forall a b. (a -> b) -> Stream m a -> Stream m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Char
forall a. Integral a => a -> Char
wordToChar
                (Stream m a -> Stream m Char) -> Stream m a -> Stream m Char
forall a b. (a -> b) -> a -> b
$ Array a -> Stream m a
forall (m :: * -> *) a. (Monad m, Unbox a) => Array a -> Stream m a
Array.readRev Array a
arr
    -- XXX On posix we just need to check last 3 bytes of the array
    -- XXX Display the path in the exception messages.
    case [Char]
s1 of
        [] -> PathException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PathException -> m ()) -> PathException -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath [Char]
"A file name cannot have a trailing separator"
        Char
'.' : [Char]
xs ->
            case [Char]
xs of
                [] -> PathException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PathException -> m ()) -> PathException -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath [Char]
"A file name cannot have a trailing \".\""
                Char
'.' : [] ->
                    PathException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PathException -> m ()) -> PathException -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath [Char]
"A file name cannot have a trailing \"..\""
                [Char]
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        [Char]
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    case OS
os of
        OS
Windows ->
            -- XXX We can exclude a UNC root as well but just the UNC root is
            -- not even a valid path.
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
isDrive Array a
arr)
                (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ PathException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PathException -> m ()) -> PathException -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath [Char]
"A drive root is not a valid file name"
        OS
Posix -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Split a multi-component path into (dir, file) if its last component can be
-- a file i.e.:
--
-- * the path does not end with a separator
-- * the path does not end with a . or .. component
--
-- Split a single component into ("", path) if it can be a file i.e. it is not
-- a path root, "." or "..".
--
-- If the path cannot be a file then (path, "") is returned.
--
-- >>> toList (a,b) = (unpackPosix a, unpackPosix b)
-- >>> splitPosix = toList . Common.splitFile Common.Posix . packPosix
--
-- >>> splitPosix "/"
-- ("/","")
--
-- >>> splitPosix "."
-- (".","")
--
-- >>> splitPosix "/."
-- ("/.","")
--
-- >>> splitPosix ".."
-- ("..","")
--
-- >>> splitPosix "//"
-- ("//","")
--
-- >>> splitPosix "/home"
-- ("/","home")
--
-- >>> splitPosix "./home"
-- ("./","home")
--
-- >>> splitPosix "home"
-- ("","home")
--
-- >>> splitPosix "x/"
-- ("x/","")
--
-- >>> splitPosix "x/y"
-- ("x/","y")
--
-- >>> splitPosix "x//y"
-- ("x//","y")
--
-- >>> splitPosix "x/./y"
-- ("x/./","y")
{-# INLINE splitFile #-}
splitFile :: (Unbox a, Integral a) => OS -> Array a -> (Array a, Array a)
splitFile :: forall a.
(Unbox a, Integral a) =>
OS -> Array a -> (Array a, Array a)
splitFile OS
os Array a
arr =
    let p :: a -> Bool
p a
x =
            if OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
Windows
            then a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> a
forall a. Integral a => Char -> a
charToWord Char
':' Bool -> Bool -> Bool
|| OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
os a
x
            else OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
os a
x
        -- XXX Use Array.revBreakEndBy?
        fileLen :: Int
fileLen = Identity Int -> Int
forall a. Identity a -> a
runIdentity
                (Identity Int -> Int) -> Identity Int -> Int
forall a b. (a -> b) -> a -> b
$ Fold Identity a Int -> Stream Identity a -> Identity Int
forall (m :: * -> *) a b.
Monad m =>
Fold m a b -> Stream m a -> m b
Stream.fold ((a -> Bool) -> Fold Identity a Int -> Fold Identity a Int
forall (m :: * -> *) a b.
Monad m =>
(a -> Bool) -> Fold m a b -> Fold m a b
Fold.takeEndBy_ a -> Bool
forall {a}. Integral a => a -> Bool
p Fold Identity a Int
forall (m :: * -> *) a. Monad m => Fold m a Int
Fold.length)
                (Stream Identity a -> Identity Int)
-> Stream Identity a -> Identity Int
forall a b. (a -> b) -> a -> b
$ Array a -> Stream Identity a
forall (m :: * -> *) a. (Monad m, Unbox a) => Array a -> Stream m a
Array.readRev Array a
arr
        arrLen :: Int
arrLen = Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
arr
        baseLen :: Int
baseLen = Int
arrLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fileLen
        (Array a
base, Array a
file) = Int -> Array a -> (Array a, Array a)
forall a. Unbox a => Int -> Array a -> (Array a, Array a)
Array.unsafeBreakAt Int
baseLen Array a
arr
        fileFirst :: a
fileFirst = Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndex Int
0 Array a
file
        fileSecond :: a
fileSecond = Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndex Int
1 Array a
file
     in
        if Int
fileLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
            -- exclude the file == '.' case
            Bool -> Bool -> Bool
&& Bool -> Bool
not (Int
fileLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& a
fileFirst a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> a
forall a. Integral a => Char -> a
charToWord Char
'.')
            -- exclude the file == '..' case
            Bool -> Bool -> Bool
&& Bool -> Bool
not (Int
fileLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
                Bool -> Bool -> Bool
&& a
fileFirst a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> a
forall a. Integral a => Char -> a
charToWord Char
'.'
                Bool -> Bool -> Bool
&& a
fileSecond a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> a
forall a. Integral a => Char -> a
charToWord Char
'.')
        then
            if Int
baseLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
            then (Array a
forall a. Array a
Array.empty, Array a
arr)
            else (Int -> Int -> Array a -> Array a
forall a. Unbox a => Int -> Int -> Array a -> Array a
Array.unsafeSliceOffLen Int
0 Int
baseLen Array a
base, Array a
file) -- "/"
        else (Array a
arr, Array a
forall a. Array a
Array.empty)

-- | 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 :: forall a. OS -> Array a -> (Array a, Array a)
splitDir OS
_os Array a
_arr = (Array a, Array a)
forall a. (?callStack::CallStack) => a
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 -> (Array a, Array a)
splitExtensionBy :: forall a.
(Unbox a, Integral a) =>
a -> OS -> Array a -> (Array a, Array a)
splitExtensionBy a
c OS
os Array a
arr =
    let p :: a -> Bool
p a
x = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
c Bool -> Bool -> Bool
|| OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
os a
x
        -- XXX Use Array.revBreakEndBy_
        extLen :: Int
extLen = Identity Int -> Int
forall a. Identity a -> a
runIdentity
                (Identity Int -> Int) -> Identity Int -> Int
forall a b. (a -> b) -> a -> b
$ Fold Identity a Int -> Stream Identity a -> Identity Int
forall (m :: * -> *) a b.
Monad m =>
Fold m a b -> Stream m a -> m b
Stream.fold ((a -> Bool) -> Fold Identity a Int -> Fold Identity a Int
forall (m :: * -> *) a b.
Monad m =>
(a -> Bool) -> Fold m a b -> Fold m a b
Fold.takeEndBy a -> Bool
p Fold Identity a Int
forall (m :: * -> *) a. Monad m => Fold m a Int
Fold.length)
                (Stream Identity a -> Identity Int)
-> Stream Identity a -> Identity Int
forall a b. (a -> b) -> a -> b
$ Array a -> Stream Identity a
forall (m :: * -> *) a. (Monad m, Unbox a) => Array a -> Stream m a
Array.readRev Array a
arr
        arrLen :: Int
arrLen = Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
arr
        baseLen :: Int
baseLen = Int
arrLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
extLen
        -- XXX We can use reverse split operation on the array
        res :: (Array a, Array a)
res@(Array a
base, Array a
ext) = Int -> Array a -> (Array a, Array a)
forall a. Unbox a => Int -> Array a -> (Array a, Array a)
Array.unsafeBreakAt Int
baseLen Array a
arr
        baseLast :: a
baseLast = Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndexRev Int
0 Array a
base
        extFirst :: a
extFirst = Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndex Int
0 Array a
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 Int
arrLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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.
            Bool -> Bool -> Bool
&& Int
extLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
            Bool -> Bool -> Bool
&& a
extFirst a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
c
            -- baseLast is always either base name char or '/' unless empty
            -- if baseLen is 0 then we have not found an extension.
            Bool -> Bool -> Bool
&& Int
baseLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
            -- If baseLast is '/' then base name is empty which means it is a
            -- dot file and there is no extension.
            Bool -> Bool -> Bool
&& Bool -> Bool
not (OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
os a
baseLast)
            -- On Windows if base is 'c:.' or a UNC path ending in '/c:.' then
            -- it is a dot file, no extension.
            Bool -> Bool -> Bool
&& Bool -> Bool
not (OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
Windows Bool -> Bool -> Bool
&& a
baseLast a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> a
forall a. Integral a => Char -> a
charToWord Char
':')
        then (Array a, Array a)
res
        else (Array a
arr, Array a
forall a. Array a
Array.empty)

-- | For the purposes of this function a file is considered to have an
-- extension if the file name can be broken down into a non-empty filename
-- followed by an extension separator (usually ".") followed by a non-empty
-- extension with at least one character other than the extension separator
-- characters. The shortest suffix obtained by this rule, starting with the
-- extension separator is returned as the extension and the remaining prefix
-- part as the filename.
--
-- A directory name does not have an extension.
--
-- Note: On Windows we cannot create a file named "prn." or "prn..". Thus it
-- considers anything starting with and including the first "." as the
-- extension and the part before it as the filename. Our definition considers
-- "prn." as a filename without an extension.

-- >>> toList (a,b) = (unpackPosix a, unpackPosix b)
-- >>> splitPosix = toList . Common.splitExtension Common.Posix . packPosix
--
-- >>> toListWin (a,b) = (unpackWindows a, unpackWindows b)
-- >>> splitWin = toListWin . Common.splitExtension Common.Windows . packWindows
--
-- >>> splitPosix "/"
-- ("/","")
--
-- >>> 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.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 "..x"
-- (".",".x")
--
-- >>> 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 splitExtension #-}
splitExtension :: (Unbox a, Integral a) => OS -> Array a -> (Array a, Array a)
splitExtension :: forall a.
(Unbox a, Integral a) =>
OS -> Array a -> (Array a, Array a)
splitExtension = a -> OS -> Array a -> (Array a, Array a)
forall a.
(Unbox a, Integral a) =>
a -> OS -> Array a -> (Array a, Array a)
splitExtensionBy a
forall a. Integral a => a
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 :: forall a. Integral a => OS -> a -> Bool
isInvalidPathChar OS
Posix a
x = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
isInvalidPathChar OS
Windows a
x =
    -- case should be faster than list search
    case a
x of
        a
34 -> Bool
True -- '"'
        a
42 -> Bool
True -- '*'
        a
58 -> Bool
True -- ':'
        a
60 -> Bool
True -- '<'
        a
62 -> Bool
True -- '>'
        a
63 -> Bool
True -- '?'
        a
124 -> Bool
True -- '|'
        a
_ -> a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> a
forall a. Integral a => Char -> a
charToWord Char
'\US'

countLeadingValid :: (Unbox a, Integral a) => OS -> Array a -> Int
countLeadingValid :: forall a. (Unbox a, Integral a) => OS -> Array a -> Int
countLeadingValid OS
os Array a
path =
    let f :: Fold Identity a Int
f = (a -> Bool) -> Fold Identity a Int -> Fold Identity a Int
forall (m :: * -> *) a b.
Monad m =>
(a -> Bool) -> Fold m a b -> Fold m a b
Fold.takeEndBy_ (OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isInvalidPathChar OS
os) Fold Identity a Int
forall (m :: * -> *) a. Monad m => Fold m a Int
Fold.length
     in Fold Identity a Int -> Array a -> Int
forall a b. Unbox a => Fold Identity a b -> Array a -> b
foldArr Fold Identity a Int
f Array a
path

-- XXX Supply it an array for checking and use a more efficient prefix matching
-- check.

-- | Only for windows.
isInvalidPathComponent :: Integral a => [[a]]
isInvalidPathComponent :: forall a. Integral a => [[a]]
isInvalidPathComponent = ([Char] -> [a]) -> [[Char]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> a) -> [Char] -> [a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> a
forall a. Integral a => Char -> a
charToWord)
    [ [Char]
"CON",[Char]
"PRN",[Char]
"AUX",[Char]
"NUL",[Char]
"CLOCK$"
    , [Char]
"COM1",[Char]
"COM2",[Char]
"COM3",[Char]
"COM4",[Char]
"COM5",[Char]
"COM6",[Char]
"COM7",[Char]
"COM8",[Char]
"COM9"
    , [Char]
"LPT1",[Char]
"LPT2",[Char]
"LPT3",[Char]
"LPT4",[Char]
"LPT5",[Char]
"LPT6",[Char]
"LPT7",[Char]
"LPT8",[Char]
"LPT9"
    ]

{- HLINT ignore "Use when" -}
validatePathWith :: (MonadThrow m, Integral a, Unbox a) =>
    Bool -> OS -> Array a -> m ()
validatePathWith :: forall (m :: * -> *) a.
(MonadThrow m, Integral a, Unbox a) =>
Bool -> OS -> Array a -> m ()
validatePathWith Bool
_ OS
Posix Array a
path =
    let pathLen :: Int
pathLen = Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
path
        validLen :: Int
validLen = OS -> Array a -> Int
forall a. (Unbox a, Integral a) => OS -> Array a -> Int
countLeadingValid OS
Posix Array a
path
     in if Int
pathLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then PathException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PathException -> m ()) -> PathException -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath [Char]
"Empty path"
        else if Int
pathLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
validLen
        then PathException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PathException -> m ()) -> PathException -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath
            ([Char] -> PathException) -> [Char] -> PathException
forall a b. (a -> b) -> a -> b
$ [Char]
"Null char found after " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
validLen [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" characters."
        else () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
validatePathWith Bool
allowRoot OS
Windows Array a
path
  | Array a -> Bool
forall a. Array a -> Bool
Array.null Array a
path = PathException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PathException -> m ()) -> PathException -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath [Char]
"Empty path"
  | Bool
otherwise = do
        if Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
hasDrive Array a
path Bool -> Bool -> Bool
&& Int
postDriveSep Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 -- "C://"
        then PathException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PathException -> m ()) -> PathException -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath
            [Char]
"More than one separators between drive root and the path"
        else if Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
isAbsoluteUNC Array a
path
        then
            if Int
postDriveSep Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 -- "///x"
            then PathException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PathException -> m ()) -> PathException -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath
                [Char]
"Path starts with more than two separators"
            else if Bool
invalidRootComponent -- "//prn/x"
            then PathException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PathException -> m ()) -> PathException -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath
                -- XXX print the invalid component name
                [Char]
"Special filename component found in share root"
            else if Int
rootEndSeps Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1 -- "//share//x"
            then PathException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PathException -> m ()) -> PathException -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath
                ([Char] -> PathException) -> [Char] -> PathException
forall a b. (a -> b) -> a -> b
$ [Char]
"Share name is needed and exactly one separator is needed "
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"after the share root"
            else if Bool -> Bool
not Bool
allowRoot Bool -> Bool -> Bool
&& Array a -> Bool
forall a. Array a -> Bool
Array.null Array a
stem -- "//share/"
            then PathException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PathException -> m ()) -> PathException -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath
                [Char]
"the share root must be followed by a non-empty path"
            else () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        else () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        if Int
stemLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
validStemLen -- "x/x>y"
        then PathException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PathException -> m ()) -> PathException -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath
            ([Char] -> PathException) -> [Char] -> PathException
forall a b. (a -> b) -> a -> b
$ [Char]
"Disallowed char found after "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
rootLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
validStemLen)
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" characters. The invalid char is: "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char -> [Char]
forall a. Show a => a -> [Char]
show (Int -> Char
chr (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
invalidVal))
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" [" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word16 -> [Char]
forall a. Show a => a -> [Char]
show Word16
invalidVal [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"
        else if Bool
invalidComponent -- "x/prn/y"
        -- XXX print the invalid component name
        then PathException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (PathException -> m ()) -> PathException -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath [Char]
"Disallowed Windows filename in path"
        else () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    where

    postDrive :: Array a
postDrive = (Array a, Array a) -> Array a
forall a b. (a, b) -> b
snd ((Array a, Array a) -> Array a) -> (Array a, Array a) -> Array a
forall a b. (a -> b) -> a -> b
$ Int -> Array a -> (Array a, Array a)
forall a. Unbox a => Int -> Array a -> (Array a, Array a)
Array.unsafeBreakAt Int
2 Array a
path
    postDriveSep :: Int
postDriveSep = (a -> Bool) -> Array a -> Int
forall a. Unbox a => (a -> Bool) -> Array a -> Int
countLeadingBy (OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
Windows) Array a
postDrive

    -- XXX check invalid chars in the path root as well - except . and '?'?
    (Array a
root, Array a
stem) = OS -> Array a -> (Array a, Array a)
forall a.
(Unbox a, Integral a) =>
OS -> Array a -> (Array a, Array a)
splitRoot OS
Windows Array a
path
    rootLen :: Int
rootLen = Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
root
    stemLen :: Int
stemLen = Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
stem
    validStemLen :: Int
validStemLen = OS -> Array a -> Int
forall a. (Unbox a, Integral a) => OS -> Array a -> Int
countLeadingValid OS
Windows Array a
stem
    invalidVal :: Word16
invalidVal = a -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndex Int
validStemLen Array a
stem) :: Word16

    rootEndSeps :: Int
rootEndSeps  = (a -> Bool) -> Array a -> Int
forall a. Unbox a => (a -> Bool) -> Array a -> Int
countTrailingBy (OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
Windows) Array a
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 :: a -> a
toUp a
w16 =
        if a
w16 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
256
        then Char -> a
forall a. Integral a => Char -> a
charToWord (Char -> a) -> Char -> a
forall a b. (a -> b) -> a -> b
$ Char -> Char
toUpper (a -> Char
forall a. Integral a => a -> Char
wordToChar a
w16)
        else a
w16

    -- Should we strip all space chars as in Data.Char.isSpace?
    isSpace :: a -> Bool
isSpace a
x = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> a
forall a. Integral a => Char -> a
charToWord Char
' '

    -- 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 :: Array a -> [a]
getBaseName Array a
x =
          Identity [a] -> [a]
forall a. Identity a -> a
runIdentity
        (Identity [a] -> [a]) -> Identity [a] -> [a]
forall a b. (a -> b) -> a -> b
$ Stream Identity a -> Identity [a]
forall (m :: * -> *) a. Monad m => Stream m a -> m [a]
Stream.toList
        (Stream Identity a -> Identity [a])
-> Stream Identity a -> Identity [a]
forall a b. (a -> b) -> a -> b
$ (a -> a) -> Stream Identity a -> Stream Identity a
forall a b. (a -> b) -> Stream Identity a -> Stream Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Integral a => a -> a
toUp
        (Stream Identity a -> Stream Identity a)
-> Stream Identity a -> Stream Identity a
forall a b. (a -> b) -> a -> b
$ Array a -> Stream Identity a
forall (m :: * -> *) a. (Monad m, Unbox a) => Array a -> Stream m a
Array.read
        (Array a -> Stream Identity a) -> Array a -> Stream Identity a
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> Array a -> Array a
forall a. Unbox a => (a -> Bool) -> Array a -> Array a
Array.dropAround a -> Bool
forall {a}. Integral a => a -> Bool
isSpace
        (Array a -> Array a) -> Array a -> Array a
forall a b. (a -> b) -> a -> b
$ (Array a, Array a) -> Array a
forall a b. (a, b) -> a
fst ((Array a, Array a) -> Array a) -> (Array a, Array a) -> Array a
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> Array a -> (Array a, Array a)
forall a. Unbox a => (a -> Bool) -> Array a -> (Array a, Array a)
Array.breakEndBy_ (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Integral a => a
extensionWord) Array a
x

    components :: Array a -> [[a]]
components =
          Identity [[a]] -> [[a]]
forall a. Identity a -> a
runIdentity
        (Identity [[a]] -> [[a]])
-> (Array a -> Identity [[a]]) -> Array a -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream Identity [a] -> Identity [[a]]
forall (m :: * -> *) a. Monad m => Stream m a -> m [a]
Stream.toList
        (Stream Identity [a] -> Identity [[a]])
-> (Array a -> Stream Identity [a]) -> Array a -> Identity [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Array a -> [a])
-> Stream Identity (Array a) -> Stream Identity [a]
forall a b. (a -> b) -> Stream Identity a -> Stream Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Array a -> [a]
forall {a}. (Integral a, Unbox a) => Array a -> [a]
getBaseName
        (Stream Identity (Array a) -> Stream Identity [a])
-> (Array a -> Stream Identity (Array a))
-> Array a
-> Stream Identity [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> OS -> Array a -> Stream Identity (Array a)
forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
Bool -> OS -> Array a -> Stream m (Array a)
splitCompact Bool
False OS
Windows

    invalidRootComponent :: Bool
invalidRootComponent =
        ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
List.any ([a] -> [[a]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.elem` [[a]]
forall a. Integral a => [[a]]
isInvalidPathComponent) (Array a -> [[a]]
components Array a
root)
    invalidComponent :: Bool
invalidComponent =
        ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
List.any ([a] -> [[a]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.elem` [[a]]
forall a. Integral a => [[a]]
isInvalidPathComponent) (Array a -> [[a]]
components Array a
stem)

-- | A valid root, share root or a valid path.
{-# INLINE validatePath #-}
validatePath :: (MonadThrow m, Integral a, Unbox a) => OS -> Array a -> m ()
validatePath :: forall (m :: * -> *) a.
(MonadThrow m, Integral a, Unbox a) =>
OS -> Array a -> m ()
validatePath = Bool -> OS -> Array a -> m ()
forall (m :: * -> *) a.
(MonadThrow m, Integral a, Unbox a) =>
Bool -> OS -> Array a -> m ()
validatePathWith Bool
True

-- | Like validatePath but on Windows only full paths are allowed, path roots
-- only are not allowed. Thus "//x/" is not valid.
{-# INLINE validatePath' #-}
validatePath' :: (MonadThrow m, Integral a, Unbox a) => OS -> Array a -> m ()
validatePath' :: forall (m :: * -> *) a.
(MonadThrow m, Integral a, Unbox a) =>
OS -> Array a -> m ()
validatePath' = Bool -> OS -> Array a -> m ()
forall (m :: * -> *) a.
(MonadThrow m, Integral a, Unbox a) =>
Bool -> OS -> Array a -> m ()
validatePathWith Bool
False

-- Note: We can use powershell for testing path validity.
-- "//share/x" works in powershell.
-- But mixed forward and backward slashes do not work, it is treated as a path
-- relative to current drive e.g. "\\/share/x" is treated as "C:/share/x".
--
-- XXX Note: Windows may have case sensitive behavior depending on the file
-- system being used. Does it impact any of the case insensitive validations
-- below?

-- | Check if the filepath is valid i.e. does the operating system or the file
-- system allow such a path in listing or creating files?
--
-- >>> isValidPosix = Common.isValidPath Common.Posix . packPosix
-- >>> isValidWin = Common.isValidPath Common.Windows . packWindows
--
-- Posix and Windows:
--
-- >>> isValidPosix ""
-- False
-- >>> isValidPosix "\0"
-- False
-- >>> isValidWin ""
-- False
-- >>> isValidWin "\0"
-- False
--
-- Windows invalid characters:
--
-- >>> isValidWin "c::"
-- False
-- >>> isValidWin "c:\\x:y"
-- False
-- >>> isValidWin "x*"
-- False
-- >>> isValidWin "x\ty"
-- False
--
-- Windows invalid path components:
--
-- >>> isValidWin "pRn.txt"
-- False
-- >>> isValidWin " pRn .txt"
-- False
-- >>> isValidWin "c:\\x\\pRn"
-- False
-- >>> isValidWin "c:\\x\\pRn.txt"
-- False
-- >>> isValidWin "c:\\pRn\\x"
-- False
-- >>> isValidWin "c:\\ pRn \\x"
-- False
-- >>> isValidWin "pRn.x.txt"
-- False
--
-- Windows drive root validations:
--
-- isValidWin "c:"
-- True
-- isValidWin "c:a\\b"
-- True
-- isValidWin "c:\\"
-- True
-- >>> isValidWin "c:\\\\"
-- False
-- >>> isValidWin "c:\\/"
-- False
-- >>> isValidWin "c:\\\\x"
-- False
-- >>> isValidWin "c:\\/x"
-- False
-- >>> isValidWin "\\/x/y"
-- True
--
-- Windows share path validations:
--
-- >>> isValidWin "\\"
-- True
-- >>> isValidWin "\\\\"
-- False
-- >>> isValidWin "\\\\\\"
-- False
-- >>> isValidWin "\\\\x"
-- False
-- >>> isValidWin "\\\\x\\"
-- True
-- >>> isValidWin "\\\\x\\y"
-- True
-- >>> isValidWin "//x/y"
-- True
-- >>> isValidWin "\\\\prn\\y"
-- False
-- >>> isValidWin "\\\\x\\\\"
-- False
-- >>> isValidWin "\\\\x\\\\x"
-- False
-- >>> isValidWin "\\\\\\x"
-- False

-- Windows short UNC path validations:
--
-- >>> isValidWin "\\\\?\\c:"
-- False
-- >>> isValidWin "\\\\?\\c:\\"
-- True
-- >>> isValidWin "\\\\?\\c:x"
-- False
-- >>> isValidWin "\\\\?\\c:\\\\" -- XXX validate this
-- False
-- >>> isValidWin "\\\\?\\c:\\x"
-- True
-- >>> isValidWin "\\\\?\\c:\\\\\\"
-- False
-- >>> isValidWin "\\\\?\\c:\\\\x"
-- False
--
-- Windows long UNC path validations:
--
-- >>> isValidWin "\\\\?\\UnC\\x" -- UnC treated as share name
-- True
-- >>> isValidWin "\\\\?\\UNC\\x"
-- True
-- >>> isValidWin "\\\\?\\UNC\\c:\\x"
-- True
--
-- DOS local/global device namespace
--
-- >>> isValidWin "\\\\.\\x"
-- True
-- >>> isValidWin "\\\\??\\x"
-- True
{-# INLINE isValidPath #-}
isValidPath :: (Integral a, Unbox a) => OS -> Array a -> Bool
isValidPath :: forall a. (Integral a, Unbox a) => OS -> Array a -> Bool
isValidPath OS
os Array a
path =
    case OS -> Array a -> Maybe ()
forall (m :: * -> *) a.
(MonadThrow m, Integral a, Unbox a) =>
OS -> Array a -> m ()
validatePath OS
os Array a
path of
        Maybe ()
Nothing -> Bool
False
        Just ()
_ -> Bool
True

-- |
-- >>> isValidWin = Common.isValidPath' Common.Windows . packWindows
--
-- The following roots allowed by isValidPath are not allowed:
--
-- >>> isValidWin "\\\\x\\"
-- False
-- >>> isValidWin "\\\\?\\UNC\\x"
-- False
{-# INLINE isValidPath' #-}
isValidPath' :: (Integral a, Unbox a) => OS -> Array a -> Bool
isValidPath' :: forall a. (Integral a, Unbox a) => OS -> Array a -> Bool
isValidPath' OS
os Array a
path =
    case OS -> Array a -> Maybe ()
forall (m :: * -> *) a.
(MonadThrow m, Integral a, Unbox a) =>
OS -> Array a -> m ()
validatePath' OS
os Array a
path of
        Maybe ()
Nothing -> Bool
False
        Just ()
_ -> Bool
True

-- A chunk is essentially an untyped Array i.e. Array Word8.  We can either use
-- the term ByteArray for that or just Chunk. The latter is shorter and we have
-- been using it consistently in streamly. We use "bytes" for a stream of
-- bytes.

-- | /Unsafe/: The user is responsible to maintain the invariants mentioned in
-- the definition of the 'Path' type. On Windows, the array passed must be a
-- multiple of 2 bytes as the underlying representation uses 'Word16'.
{-# INLINE unsafeFromChunk #-}
unsafeFromChunk :: Array Word8 -> Array a
unsafeFromChunk :: forall a. Array Word8 -> Array a
unsafeFromChunk = Array Word8 -> Array a
forall a b. Array a -> Array b
Array.unsafeCast

-- | On Posix it may fail if the byte array contains null characters. On
-- Windows the array passed must be a multiple of 2 bytes as the underlying
-- representation uses 'Word16'.
--
-- Throws 'InvalidPath'.
{-# INLINE fromChunk #-}
fromChunk :: forall m a. (MonadThrow m, Unbox a, Integral a) =>
    OS -> Array Word8 -> m (Array a)
fromChunk :: forall (m :: * -> *) a.
(MonadThrow m, Unbox a, Integral a) =>
OS -> Array Word8 -> m (Array a)
fromChunk OS
Posix Array Word8
arr =
    let arr1 :: Array a
arr1 = Array Word8 -> Array a
forall a b. Array a -> Array b
Array.unsafeCast Array Word8
arr :: Array a
     in OS -> Array a -> m ()
forall (m :: * -> *) a.
(MonadThrow m, Integral a, Unbox a) =>
OS -> Array a -> m ()
validatePath OS
Posix Array a
arr1 m () -> m (Array a) -> m (Array a)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Array a -> m (Array a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Array a
arr1
fromChunk OS
Windows Array Word8
arr =
    case Array Word8 -> Maybe (Array a)
forall a b. Unbox b => Array a -> Maybe (Array b)
Array.cast Array Word8
arr of
        Maybe (Array a)
Nothing ->
            PathException -> m (Array a)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
                (PathException -> m (Array a)) -> PathException -> m (Array a)
forall a b. (a -> b) -> a -> b
$ [Char] -> PathException
InvalidPath
                ([Char] -> PathException) -> [Char] -> PathException
forall a b. (a -> b) -> a -> b
$ [Char]
"Encoded path length " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Array Word8 -> Int
forall a. Array a -> Int
Array.byteLength Array Word8
arr)
                    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not a multiple of 16-bit."
        Just Array a
x -> OS -> Array a -> m ()
forall (m :: * -> *) a.
(MonadThrow m, Integral a, Unbox a) =>
OS -> Array a -> m ()
validatePath OS
Windows Array a
x m () -> m (Array a) -> m (Array a)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Array a -> m (Array a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Array a
x

-- | Convert 'Path' to an array of bytes.
{-# INLINE toChunk #-}
toChunk :: Array a -> Array Word8
toChunk :: forall a. Array a -> Array Word8
toChunk = Array a -> Array Word8
forall a. Array a -> Array Word8
Array.asBytes

{-# INLINE unsafeFromChars #-}
unsafeFromChars :: (Unbox a) =>
       (Stream Identity Char -> Stream Identity a)
    -> Stream Identity Char
    -> Array a
unsafeFromChars :: forall a.
Unbox a =>
(Stream Identity Char -> Stream Identity a)
-> Stream Identity Char -> Array a
unsafeFromChars Stream Identity Char -> Stream Identity a
encode Stream Identity Char
s =
    let n :: Int
n = Identity Int -> Int
forall a. Identity a -> a
runIdentity (Identity Int -> Int) -> Identity Int -> Int
forall a b. (a -> b) -> a -> b
$ Fold Identity Char Int -> Stream Identity Char -> Identity Int
forall (m :: * -> *) a b.
Monad m =>
Fold m a b -> Stream m a -> m b
Stream.fold Fold Identity Char Int
forall (m :: * -> *) a. Monad m => Fold m a Int
Fold.length Stream Identity Char
s
     in Int -> Stream Identity a -> Array a
forall a. Unbox a => Int -> Stream Identity a -> Array a
Array.fromPureStreamN Int
n (Stream Identity Char -> Stream Identity a
encode Stream Identity Char
s)

-- | Note: We do not sanitize the path i.e. remove duplicate separators, .
-- segments, trailing separator etc because that would require unnecessary
-- checks and modifications to the path which may not be used ever for any
-- useful purpose, it is only needed for path equality and can be done during
-- the equality check. If normalization is desired users can do it explicitly.
--
-- fromChars should accept both - just root or path. Otherwise we will need a
-- separate type for Root.
--
-- 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 :: forall (m :: * -> *) a.
(MonadThrow m, Unbox a, Integral a) =>
OS
-> (Stream Identity Char -> Stream Identity a)
-> Stream Identity Char
-> m (Array a)
fromChars OS
os Stream Identity Char -> Stream Identity a
encode Stream Identity Char
s =
    let arr :: Array a
arr = (Stream Identity Char -> Stream Identity a)
-> Stream Identity Char -> Array a
forall a.
Unbox a =>
(Stream Identity Char -> Stream Identity a)
-> Stream Identity Char -> Array a
unsafeFromChars Stream Identity Char -> Stream Identity a
encode Stream Identity Char
s
     in OS -> Array Word8 -> m (Array a)
forall (m :: * -> *) a.
(MonadThrow m, Unbox a, Integral a) =>
OS -> Array Word8 -> m (Array a)
fromChunk OS
os (Array a -> Array Word8
forall a b. Array a -> Array b
Array.unsafeCast Array a
arr)

{-# INLINE toChars #-}
toChars :: (Monad m, Unbox a) =>
    (Stream m a -> Stream m Char) -> Array a -> Stream m Char
toChars :: forall (m :: * -> *) a.
(Monad m, Unbox a) =>
(Stream m a -> Stream m Char) -> Array a -> Stream m Char
toChars Stream m a -> Stream m Char
decode Array a
arr = Stream m a -> Stream m Char
decode (Stream m a -> Stream m Char) -> Stream m a -> Stream m Char
forall a b. (a -> b) -> a -> b
$ Array a -> Stream m a
forall (m :: * -> *) a. (Monad m, Unbox a) => Array a -> Stream m a
Array.read Array a
arr

{-# INLINE toString #-}
toString :: Unbox a =>
    (Stream Identity a -> Stream Identity Char) -> Array a -> [Char]
toString :: forall a.
Unbox a =>
(Stream Identity a -> Stream Identity Char) -> Array a -> [Char]
toString Stream Identity a -> Stream Identity Char
decode = Identity [Char] -> [Char]
forall a. Identity a -> a
runIdentity (Identity [Char] -> [Char])
-> (Array a -> Identity [Char]) -> Array a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream Identity Char -> Identity [Char]
forall (m :: * -> *) a. Monad m => Stream m a -> m [a]
Stream.toList (Stream Identity Char -> Identity [Char])
-> (Array a -> Stream Identity Char) -> Array a -> Identity [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stream Identity a -> Stream Identity Char)
-> Array a -> Stream Identity Char
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
(Stream m a -> Stream m Char) -> Array a -> Stream m Char
toChars Stream Identity a -> Stream Identity Char
decode

------------------------------------------------------------------------------
-- Statically Verified Literals
------------------------------------------------------------------------------

-- XXX pass the quote name for errors?
mkQ :: (String -> Q Exp) -> QuasiQuoter
mkQ :: ([Char] -> Q Exp) -> QuasiQuoter
mkQ [Char] -> Q Exp
f =
  QuasiQuoter
  { quoteExp :: [Char] -> Q Exp
quoteExp  = [Char] -> Q Exp
f
  , quotePat :: [Char] -> Q Pat
quotePat  = [Char] -> [Char] -> Q Pat
forall {m :: * -> *} {p} {a}. MonadFail m => [Char] -> p -> m a
err [Char]
"pattern"
  , quoteType :: [Char] -> Q Type
quoteType = [Char] -> [Char] -> Q Type
forall {m :: * -> *} {p} {a}. MonadFail m => [Char] -> p -> m a
err [Char]
"type"
  , quoteDec :: [Char] -> Q [Dec]
quoteDec  = [Char] -> [Char] -> Q [Dec]
forall {m :: * -> *} {p} {a}. MonadFail m => [Char] -> p -> m a
err [Char]
"declaration"
  }

  where

  err :: [Char] -> p -> m a
err [Char]
x p
_ = [Char] -> m a
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m a) -> [Char] -> m a
forall a b. (a -> b) -> a -> b
$ [Char]
"QuasiQuote used as a " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", 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

-- | Append a separator and a CString to the Array.
--
{-# INLINE appendCStringWith #-}
appendCStringWith ::
       (Int -> IO (MutArray Word8))
    -> OS
    -> Array Word8
    -> CString
    -> IO (Array Word8)
appendCStringWith :: (Int -> IO (MutArray Word8))
-> OS -> Array Word8 -> CString -> IO (Array Word8)
appendCStringWith Int -> IO (MutArray Word8)
create OS
os Array Word8
a b :: CString
b@(Ptr Addr#
addrB#) = do
    let lenA :: Int
lenA = Array Word8 -> Int
forall a. Unbox a => Array a -> Int
Array.length Array Word8
a
    Int
lenB <- (CSize -> Int) -> IO CSize -> IO Int
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO CSize -> IO Int) -> IO CSize -> IO Int
forall a b. (a -> b) -> a -> b
$ Addr# -> IO CSize
c_strlen_pinned Addr#
addrB#
    assertM(Int
lenA Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
&& Int
lenB Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0)
    let len :: Int
len = Int
lenA Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lenB
    MutArray Word8
arr <- Int -> IO (MutArray Word8)
create Int
len
    MutArray Word8
arr1 <- MutArray Word8 -> MutArray Word8 -> IO (MutArray Word8)
forall (m :: * -> *) a.
MonadIO m =>
MutArray a -> MutArray a -> m (MutArray a)
MutArray.unsafeSplice MutArray Word8
arr (Array Word8 -> MutArray Word8
forall a. Array a -> MutArray a
Array.unsafeThaw Array Word8
a)
    MutArray Word8
arr2 <- MutArray Word8 -> Word8 -> IO (MutArray Word8)
forall (m :: * -> *) a.
(MonadIO m, Unbox a) =>
MutArray a -> a -> m (MutArray a)
MutArray.unsafeSnoc MutArray Word8
arr1 (Char -> Word8
forall a. Integral a => Char -> a
charToWord (OS -> Char
primarySeparator OS
os))
    MutArray Word8
arr3 :: MutArray.MutArray Word8 <-
        MutArray Word8 -> Ptr Word8 -> Int -> IO (MutArray Word8)
forall (m :: * -> *).
MonadIO m =>
MutArray Word8 -> Ptr Word8 -> Int -> m (MutArray Word8)
MutArray.unsafeAppendPtrN MutArray Word8
arr2 (CString -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr CString
b) Int
lenB
    Array Word8 -> IO (Array Word8)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MutArray Word8 -> Array Word8
forall a. MutArray a -> Array a
Array.unsafeFreeze MutArray Word8
arr3)

-- | Append a separator and a CString to the Array.
--
{-# INLINE appendCString #-}
appendCString :: OS -> Array Word8 -> CString -> IO (Array Word8)
appendCString :: OS -> Array Word8 -> CString -> IO (Array Word8)
appendCString = (Int -> IO (MutArray Word8))
-> OS -> Array Word8 -> CString -> IO (Array Word8)
appendCStringWith Int -> IO (MutArray Word8)
forall (m :: * -> *) a.
(MonadIO m, Unbox a) =>
Int -> m (MutArray a)
MutArray.emptyOf

-- | Like 'appendCString' but create a pinned Array.
--
{-# INLINE appendCString' #-}
appendCString' :: OS -> Array Word8 -> CString -> IO (Array Word8)
appendCString' :: OS -> Array Word8 -> CString -> IO (Array Word8)
appendCString' = (Int -> IO (MutArray Word8))
-> OS -> Array Word8 -> CString -> IO (Array Word8)
appendCStringWith Int -> IO (MutArray Word8)
forall (m :: * -> *) a.
(MonadIO m, Unbox a) =>
Int -> m (MutArray a)
MutArray.emptyOf'

{-# INLINE doAppend #-}
doAppend :: (Unbox a, Integral a) => OS -> Array a -> Array a -> Array a
doAppend :: forall a.
(Unbox a, Integral a) =>
OS -> Array a -> Array a -> Array a
doAppend OS
os Array a
a Array a
b = IO (Array a) -> Array a
forall a. IO a -> a
unsafePerformIO (IO (Array a) -> Array a) -> IO (Array a) -> Array a
forall a b. (a -> b) -> a -> b
$ do
    let lenA :: Int
lenA = Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
a
        lenB :: Int
lenB = Array a -> Int
forall a. Unbox a => Array a -> Int
Array.length Array a
b
    assertM(Int
lenA Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
&& Int
lenB Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0)
    let lastA :: a
lastA = Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndexRev Int
0 Array a
a
        sepA :: Bool
sepA = OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
os a
lastA
        sepB :: Bool
sepB = OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
os (Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndex Int
0 Array a
b)
    let len :: Int
len = Int
lenA Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lenB
    MutArray a
arr <- Int -> IO (MutArray a)
forall (m :: * -> *) a.
(MonadIO m, Unbox a) =>
Int -> m (MutArray a)
MutArray.emptyOf Int
len
    MutArray a
arr1 <- MutArray a -> MutArray a -> IO (MutArray a)
forall (m :: * -> *) a.
MonadIO m =>
MutArray a -> MutArray a -> m (MutArray a)
MutArray.unsafeSplice MutArray a
arr (Array a -> MutArray a
forall a. Array a -> MutArray a
Array.unsafeThaw Array a
a)
    MutArray a
arr2 <-
            if     Int
lenA Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
                Bool -> Bool -> Bool
&& Int
lenB Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
                Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
sepA
                Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
sepB
                Bool -> Bool -> Bool
&& Bool -> Bool
not (OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
Windows Bool -> Bool -> Bool
&& a
lastA a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> a
forall a. Integral a => Char -> a
charToWord Char
':')
            then MutArray a -> a -> IO (MutArray a)
forall (m :: * -> *) a.
(MonadIO m, Unbox a) =>
MutArray a -> a -> m (MutArray a)
MutArray.unsafeSnoc MutArray a
arr1 (Char -> a
forall a. Integral a => Char -> a
charToWord (OS -> Char
primarySeparator OS
os))
            else MutArray a -> IO (MutArray a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MutArray a
arr1
    let arrB :: Array a
arrB =
            if Bool
sepA Bool -> Bool -> Bool
&& Bool
sepB
            then (Array a, Array a) -> Array a
forall a b. (a, b) -> b
snd ((Array a, Array a) -> Array a) -> (Array a, Array a) -> Array a
forall a b. (a -> b) -> a -> b
$ Int -> Array a -> (Array a, Array a)
forall a. Unbox a => Int -> Array a -> (Array a, Array a)
Array.unsafeBreakAt Int
1 Array a
b
            else Array a
b
    MutArray a
arr3 <- MutArray a -> MutArray a -> IO (MutArray a)
forall (m :: * -> *) a.
MonadIO m =>
MutArray a -> MutArray a -> m (MutArray a)
MutArray.unsafeSplice MutArray a
arr2 (Array a -> MutArray a
forall a. Array a -> MutArray a
Array.unsafeThaw Array a
arrB)
    Array a -> IO (Array a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MutArray a -> Array a
forall a. MutArray a -> Array a
Array.unsafeFreeze MutArray a
arr3)

{-# INLINE withAppendCheck #-}
withAppendCheck :: (Unbox b, Integral b) =>
    OS -> (Array b -> String) -> Array b -> a -> a
withAppendCheck :: forall b a.
(Unbox b, Integral b) =>
OS -> (Array b -> [Char]) -> Array b -> a -> a
withAppendCheck OS
os Array b -> [Char]
toStr Array b
arr a
f =
    if OS -> Array b -> Bool
forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
isRooted OS
os Array b
arr
    then [Char] -> a
forall a. (?callStack::CallStack) => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"append: cannot append a rooted path " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Array b -> [Char]
toStr Array b
arr
    else a
f

-- | Does not check if any of the path is empty or if the second path is
-- absolute.
--
-- >>> appendPosix a b = unpackPosix $ Common.unsafeAppend Common.Posix (Common.toString Unicode.decodeUtf8) (packPosix a) (packPosix b)
-- >>> appendWin a b = unpackWindows $ Common.unsafeAppend Common.Windows (Common.toString Unicode.decodeUtf16le') (packWindows a) (packWindows b)
--
-- >>> appendPosix "x" "y"
-- "x/y"
-- >>> appendPosix "x/" "y"
-- "x/y"
-- >>> appendPosix "x" "/y"
-- "x/y"
-- >>> appendPosix "x/" "/y"
-- "x/y"
--
{-# INLINE unsafeAppend #-}
unsafeAppend :: (Unbox a, Integral a) =>
    OS -> (Array a -> String) -> Array a -> Array a -> Array a
unsafeAppend :: forall a.
(Unbox a, Integral a) =>
OS -> (Array a -> [Char]) -> Array a -> Array a -> Array a
unsafeAppend OS
os Array a -> [Char]
_toStr = OS -> Array a -> Array a -> Array a
forall a.
(Unbox a, Integral a) =>
OS -> Array a -> Array a -> Array a
doAppend OS
os

-- | Note that append joins two paths using a separator between the paths.
--
-- On Windows, joining a drive "c:" with "x" does not add a separator between
-- the two because "c:x" is different from "c:/x". Note "c:" and "/x" are both
-- rooted paths, therefore, append cannot be used to join them. You will need
-- to use dropRoot on the second path before joining them. Similarly for
-- joining "//x/" and "/y".
--
-- >>> import Data.Either (Either, isLeft)
-- >>> import Control.Exception (SomeException, evaluate, try)
--
-- >>> appendPosix a b = unpackPosix $ Common.append Common.Posix (Common.toString Unicode.decodeUtf8) (packPosix a) (packPosix b)
-- >>> appendWin a b = unpackWindows $ Common.append Common.Windows (Common.toString Unicode.decodeUtf16le') (packWindows a) (packWindows b)
-- >>> failPosix a b = (try (evaluate (appendPosix a b)) :: IO (Either SomeException String)) >>= return . isLeft
-- >>> failWin a b = (try (evaluate (appendWin a b)) :: IO (Either SomeException String)) >>= return . isLeft
--
-- >>> appendPosix "x" "y"
-- "x/y"
-- >>> appendPosix "x/" "y"
-- "x/y"
-- >>> failPosix "x" "/"
-- True
--
-- >>> appendWin "x" "y"
-- "x\\y"
-- >>> appendWin "x/" "y"
-- "x/y"
-- >>> appendWin "c:" "x"
-- "c:x"
-- >>> appendWin "c:/" "x"
-- "c:/x"
-- >>> appendWin "//x" "y"
-- "//x\\y"
-- >>> appendWin "//x/" "y"
-- "//x/y"
--
-- >>> failWin "c:" "/"
-- True
-- >>> failWin "c:" "/x"
-- True
-- >>> failWin "c:/" "/x"
-- True
-- >>> failWin "//x/" "/y"
-- True
{-# INLINE append #-}
append :: (Unbox a, Integral a) =>
    OS -> (Array a -> String) -> Array a -> Array a -> Array a
append :: forall a.
(Unbox a, Integral a) =>
OS -> (Array a -> [Char]) -> Array a -> Array a -> Array a
append OS
os Array a -> [Char]
toStr Array a
a Array a
b = OS -> (Array a -> [Char]) -> Array a -> Array a -> Array a
forall b a.
(Unbox b, Integral b) =>
OS -> (Array b -> [Char]) -> Array b -> a -> a
withAppendCheck OS
os Array a -> [Char]
toStr Array a
b (OS -> Array a -> Array a -> Array a
forall a.
(Unbox a, Integral a) =>
OS -> Array a -> Array a -> Array a
doAppend OS
os Array a
a Array a
b)

-- | A stricter version of append which requires the first path to be a
-- directory like path i.e. with a trailing separator.
--
-- >>> import Data.Either (Either, isLeft)
-- >>> import Control.Exception (SomeException, evaluate, try)
--
-- >>> appendPosix a b = unpackPosix $ Common.append' Common.Posix (Common.toString Unicode.decodeUtf8) (packPosix a) (packPosix b)
-- >>> appendWin a b = unpackWindows $ Common.append' Common.Windows (Common.toString Unicode.decodeUtf16le') (packWindows a) (packWindows b)
-- >>> failPosix a b = (try (evaluate (appendPosix a b)) :: IO (Either SomeException String)) >>= return . isLeft
-- >>> failWin a b = (try (evaluate (appendWin a b)) :: IO (Either SomeException String)) >>= return . isLeft
--
-- >>> failPosix "x" "y"
-- True
-- >>> appendPosix "x/" "y"
-- "x/y"
-- >>> failPosix "x" "/"
-- True
--
-- >>> failWin "x" "y"
-- True
-- >>> appendWin "x/" "y"
-- "x/y"
-- >>> appendWin "c:" "x"
-- "c:x"
-- >>> appendWin "c:/" "x"
-- "c:/x"
-- >>> failWin "//x" "y"
-- True
-- >>> appendWin "//x/" "y"
-- "//x/y"
--
-- >>> failWin "c:" "/"
-- True
-- >>> failWin "c:" "/x"
-- True
-- >>> failWin "c:/" "/x"
-- True
-- >>> failWin "//x/" "/y"
-- True
{-# INLINE append' #-}
append' :: (Unbox a, Integral a) =>
    OS -> (Array a -> String) -> Array a -> Array a -> Array a
append' :: forall a.
(Unbox a, Integral a) =>
OS -> (Array a -> [Char]) -> Array a -> Array a -> Array a
append' OS
os Array a -> [Char]
toStr Array a
a Array a
b =
    let hasSep :: Bool
hasSep = (a -> Bool) -> Array a -> Int
forall a. Unbox a => (a -> Bool) -> Array a -> Int
countTrailingBy (OS -> a -> Bool
forall a. Integral a => OS -> a -> Bool
isSeparatorWord OS
os) Array a
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
        hasColon :: Bool
hasColon =
               OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
Windows
            Bool -> Bool -> Bool
&& Int -> Array a -> Maybe a
forall a. Unbox a => Int -> Array a -> Maybe a
Array.getIndexRev Int
0 Array a
a Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Maybe a
forall a. a -> Maybe a
Just (Char -> a
forall a. Integral a => Char -> a
charToWord Char
':')
     in if Bool
hasSep Bool -> Bool -> Bool
|| Bool
hasColon
        then OS -> (Array a -> [Char]) -> Array a -> Array a -> Array a
forall b a.
(Unbox b, Integral b) =>
OS -> (Array b -> [Char]) -> Array b -> a -> a
withAppendCheck OS
os Array a -> [Char]
toStr Array a
b (OS -> Array a -> Array a -> Array a
forall a.
(Unbox a, Integral a) =>
OS -> Array a -> Array a -> Array a
doAppend OS
os Array a
a Array a
b)
        else [Char] -> Array a
forall a. (?callStack::CallStack) => [Char] -> a
error
                ([Char] -> Array a) -> [Char] -> Array a
forall a b. (a -> b) -> a -> b
$ [Char]
"append': first path must be dir like i.e. must have a "
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"trailing separator or colon on windows: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Array a -> [Char]
toStr Array a
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 :: forall a (m :: * -> *).
(Unbox a, Integral a, MonadIO m) =>
OS -> Stream m (Array a) -> m (Array a)
unsafeJoinPaths OS
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.
    Stream m a -> m (Array a)
forall (m :: * -> *) a.
(MonadIO m, Unbox a) =>
Stream m a -> m (Array a)
Array.fromStream (Stream m a -> m (Array a))
-> (Stream m (Array a) -> Stream m a)
-> Stream m (Array a)
-> m (Array a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Stream m (Array a) -> Stream m a
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
a -> Stream m (Array a) -> Stream m a
Array.concatSepBy (Char -> a
forall a. Integral a => Char -> a
charToWord (Char -> a) -> Char -> a
forall a b. (a -> b) -> a -> b
$ OS -> Char
primarySeparator OS
os)

------------------------------------------------------------------------------
-- Equality
------------------------------------------------------------------------------

-- | Check two paths for byte level equality. This is the most strict path
-- equality check.
--
-- >>> :{
--  eqPath a b = Common.eqPathBytes (packPosix a) (packPosix b)
-- :}
--
-- >>> eqPath "x//y"  "x//y"
-- True
--
-- >>> eqPath "x//y"  "x/y"
-- False
--
-- >>> eqPath "x/./y"  "x/y"
-- False
--
-- >>> eqPath "x\\y" "x/y"
-- False
--
-- >>> eqPath "./file"  "file"
-- False
--
-- >>> eqPath "file/"  "file"
-- False
--
eqPathBytes :: Array a -> Array a -> Bool
eqPathBytes :: forall a. Array a -> Array a -> Bool
eqPathBytes = Array a -> Array a -> Bool
forall a. Array a -> Array a -> Bool
Array.byteEq

-- On posix even 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.
data EqCfg =
    EqCfg
    { EqCfg -> Bool
ignoreTrailingSeparators :: Bool -- ^ Allows "x/" == "x"
    , EqCfg -> Bool
ignoreCase :: Bool               -- ^ Allows "x" == "X"
    , EqCfg -> Bool
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"
    }

eqCfg :: EqCfg
eqCfg :: EqCfg
eqCfg = EqCfg
    { ignoreTrailingSeparators :: Bool
ignoreTrailingSeparators = Bool
False
    , ignoreCase :: Bool
ignoreCase = Bool
False
    , allowRelativeEquality :: Bool
allowRelativeEquality = Bool
False
    }

data PosixRoot = PosixRootAbs | PosixRootRel deriving PosixRoot -> PosixRoot -> Bool
(PosixRoot -> PosixRoot -> Bool)
-> (PosixRoot -> PosixRoot -> Bool) -> Eq PosixRoot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PosixRoot -> PosixRoot -> Bool
== :: PosixRoot -> PosixRoot -> Bool
$c/= :: PosixRoot -> PosixRoot -> Bool
/= :: PosixRoot -> PosixRoot -> Bool
Eq

data WindowsRoot =
      WindowsRootPosix -- /x or ./x
    | WindowsRootNonPosix -- C:... or \\...
    deriving WindowsRoot -> WindowsRoot -> Bool
(WindowsRoot -> WindowsRoot -> Bool)
-> (WindowsRoot -> WindowsRoot -> Bool) -> Eq WindowsRoot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WindowsRoot -> WindowsRoot -> Bool
== :: WindowsRoot -> WindowsRoot -> Bool
$c/= :: WindowsRoot -> WindowsRoot -> Bool
/= :: WindowsRoot -> WindowsRoot -> Bool
Eq

-- | Change to upper case and replace separators by primary separator
{-# INLINE normalizeCaseAndSeparators #-}
normalizeCaseAndSeparators :: Monad m => Array Word16 -> Stream m Char
normalizeCaseAndSeparators :: forall (m :: * -> *). Monad m => Array Word16 -> Stream m Char
normalizeCaseAndSeparators =
      (Char -> Char) -> Stream m Char -> Stream m Char
forall a b. (a -> b) -> Stream m a -> Stream m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toUpper
    (Stream m Char -> Stream m Char)
-> (Array Word16 -> Stream m Char) -> Array Word16 -> Stream m Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream m Word16 -> Stream m Char
forall (m :: * -> *). Monad m => Stream m Word16 -> Stream m Char
Unicode.decodeUtf16le'
    (Stream m Word16 -> Stream m Char)
-> (Array Word16 -> Stream m Word16)
-> Array Word16
-> Stream m Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word16 -> Word16) -> Stream m Word16 -> Stream m Word16
forall a b. (a -> b) -> Stream m a -> Stream m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word16 -> Word16
forall a. Integral a => a -> a
toDefaultSeparator
    (Stream m Word16 -> Stream m Word16)
-> (Array Word16 -> Stream m Word16)
-> Array Word16
-> Stream m Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array Word16 -> Stream m Word16
forall (m :: * -> *) a. (Monad m, Unbox a) => Array a -> Stream m a
Array.read

{-# INLINE normalizeCaseWith #-}
normalizeCaseWith :: (Monad m, Unbox a) =>
    (Stream m a -> Stream m Char) -> Array a -> Stream m Char
normalizeCaseWith :: forall (m :: * -> *) a.
(Monad m, Unbox a) =>
(Stream m a -> Stream m Char) -> Array a -> Stream m Char
normalizeCaseWith Stream m a -> Stream m Char
decoder =
      (Char -> Char) -> Stream m Char -> Stream m Char
forall a b. (a -> b) -> Stream m a -> Stream m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toUpper
    (Stream m Char -> Stream m Char)
-> (Array a -> Stream m Char) -> Array a -> Stream m Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream m a -> Stream m Char
decoder
    (Stream m a -> Stream m Char)
-> (Array a -> Stream m a) -> Array a -> Stream m Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array a -> Stream m a
forall (m :: * -> *) a. (Monad m, Unbox a) => Array a -> Stream m a
Array.read

eqWindowsRootStrict :: (Unbox a, Integral a) =>
    Bool -> Array a -> Array a -> Bool
eqWindowsRootStrict :: forall a.
(Unbox a, Integral a) =>
Bool -> Array a -> Array a -> Bool
eqWindowsRootStrict Bool
ignCase Array a
a Array a
b =
    let f :: Array Word16 -> Stream Identity Char
f = Array Word16 -> Stream Identity Char
forall (m :: * -> *). Monad m => Array Word16 -> Stream m Char
normalizeCaseAndSeparators
     in if Bool
ignCase
        then
            -- XXX We probably do not want to equate UNC with UnC etc.
            Identity Bool -> Bool
forall a. Identity a -> a
runIdentity
                (Identity Bool -> Bool) -> Identity Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Char -> Bool)
-> Stream Identity Char -> Stream Identity Char -> Identity Bool
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> Bool) -> Stream m a -> Stream m b -> m Bool
Stream.eqBy Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==)
                    (Array Word16 -> Stream Identity Char
f (Array Word16 -> Stream Identity Char)
-> Array Word16 -> Stream Identity Char
forall a b. (a -> b) -> a -> b
$ Array a -> Array Word16
forall a b. Array a -> Array b
Array.unsafeCast Array a
a) (Array Word16 -> Stream Identity Char
f (Array Word16 -> Stream Identity Char)
-> Array Word16 -> Stream Identity Char
forall a b. (a -> b) -> a -> b
$ Array a -> Array Word16
forall a b. Array a -> Array b
Array.unsafeCast Array a
b)
        else
            Identity Bool -> Bool
forall a. Identity a -> a
runIdentity
                (Identity Bool -> Bool) -> Identity Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (a -> a -> Bool)
-> Stream Identity a -> Stream Identity a -> Identity Bool
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> Bool) -> Stream m a -> Stream m b -> m Bool
Stream.eqBy a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==)
                    ((a -> a) -> Stream Identity a -> Stream Identity a
forall a b. (a -> b) -> Stream Identity a -> Stream Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Integral a => a -> a
toDefaultSeparator (Stream Identity a -> Stream Identity a)
-> Stream Identity a -> Stream Identity a
forall a b. (a -> b) -> a -> b
$ Array a -> Stream Identity a
forall (m :: * -> *) a. (Monad m, Unbox a) => Array a -> Stream m a
Array.read Array a
a)
                    ((a -> a) -> Stream Identity a -> Stream Identity a
forall a b. (a -> b) -> Stream Identity a -> Stream Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. Integral a => a -> a
toDefaultSeparator (Stream Identity a -> Stream Identity a)
-> Stream Identity a -> Stream Identity a
forall a b. (a -> b) -> a -> b
$ Array a -> Stream Identity a
forall (m :: * -> *) a. (Monad m, Unbox a) => Array a -> Stream m a
Array.read Array a
b)

{-# INLINE eqRootStrict #-}
eqRootStrict :: (Unbox a, Integral a) =>
    Bool -> OS -> Array a -> Array a -> Bool
eqRootStrict :: forall a.
(Unbox a, Integral a) =>
Bool -> OS -> Array a -> Array a -> Bool
eqRootStrict Bool
_ OS
Posix Array a
a Array a
b =
    -- a can be "/" and b can be "//"
    -- We call this only when the roots are either absolute or null.
    Array a -> Bool
forall a. Array a -> Bool
Array.null Array a
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Array a -> Bool
forall a. Array a -> Bool
Array.null Array a
b
eqRootStrict Bool
ignCase OS
Windows Array a
a Array a
b = Bool -> Array a -> Array a -> Bool
forall a.
(Unbox a, Integral a) =>
Bool -> Array a -> Array a -> Bool
eqWindowsRootStrict Bool
ignCase Array a
a Array 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 :: forall a. (Unbox a, Integral a) => Array a -> Array a -> Bool
eqPosixRootLax Array a
a Array a
b = Array a -> PosixRoot
forall {a}. (Unbox a, Integral a) => Array a -> PosixRoot
getRoot Array a
a PosixRoot -> PosixRoot -> Bool
forall a. Eq a => a -> a -> Bool
== Array a -> PosixRoot
forall {a}. (Unbox a, Integral a) => Array a -> PosixRoot
getRoot Array a
b

    where

    -- Can only be either "", '.', './' or '/' (or Windows separators)
    getRoot :: Array a -> PosixRoot
getRoot Array a
arr =
        if Array a -> Bool
forall a. Array a -> Bool
Array.null Array a
arr Bool -> Bool -> Bool
|| Int -> Array a -> Char
forall a. (Unbox a, Integral a) => Int -> Array a -> Char
unsafeIndexChar Int
0 Array a
arr Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.'
        then PosixRoot
PosixRootRel
        else PosixRoot
PosixRootAbs

{-# INLINABLE eqRootLax #-}
eqRootLax :: (Unbox a, Integral a) => Bool -> OS -> Array a -> Array a -> Bool
eqRootLax :: forall a.
(Unbox a, Integral a) =>
Bool -> OS -> Array a -> Array a -> Bool
eqRootLax Bool
_ OS
Posix Array a
a Array a
b = Array a -> Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Array a -> Bool
eqPosixRootLax Array a
a Array a
b
eqRootLax Bool
ignCase OS
Windows Array a
a Array a
b =
    let aType :: WindowsRoot
aType = Array a -> WindowsRoot
forall {a}. (Unbox a, Integral a) => Array a -> WindowsRoot
getRootType Array a
a
        bType :: WindowsRoot
bType = Array a -> WindowsRoot
forall {a}. (Unbox a, Integral a) => Array a -> WindowsRoot
getRootType Array a
b
     in WindowsRoot
aType WindowsRoot -> WindowsRoot -> Bool
forall a. Eq a => a -> a -> Bool
== WindowsRoot
bType
        Bool -> Bool -> Bool
&& (
            (WindowsRoot
aType WindowsRoot -> WindowsRoot -> Bool
forall a. Eq a => a -> a -> Bool
== WindowsRoot
WindowsRootPosix Bool -> Bool -> Bool
&& Array a -> Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Array a -> Bool
eqPosixRootLax Array a
a Array a
b)
            Bool -> Bool -> Bool
|| Bool -> Array a -> Array a -> Bool
forall a.
(Unbox a, Integral a) =>
Bool -> Array a -> Array a -> Bool
eqWindowsRootStrict Bool
ignCase Array a
a Array a
b
           )

    where

    getRootType :: Array a -> WindowsRoot
getRootType Array a
arr =
        if Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
isAbsoluteUNC Array a
arr Bool -> Bool -> Bool
|| Array a -> Bool
forall a. (Unbox a, Integral a) => Array a -> Bool
hasDrive Array a
arr
        then WindowsRoot
WindowsRootNonPosix
        else WindowsRoot
WindowsRootPosix

{-# INLINE eqComponentsWith #-}
eqComponentsWith :: (Unbox a, Integral a) =>
       Bool
    -> (Stream Identity a -> Stream Identity Char)
    -> OS
    -> Array a
    -> Array a
    -> Bool
eqComponentsWith :: forall a.
(Unbox a, Integral a) =>
Bool
-> (Stream Identity a -> Stream Identity Char)
-> OS
-> Array a
-> Array a
-> Bool
eqComponentsWith Bool
ignCase Stream Identity a -> Stream Identity Char
decoder OS
os Array a
a Array a
b =
    if Bool
ignCase
    then
        let streamEq :: Stream Identity b -> Stream Identity b -> Bool
streamEq Stream Identity b
x Stream Identity b
y = Identity Bool -> Bool
forall a. Identity a -> a
runIdentity (Identity Bool -> Bool) -> Identity Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (b -> b -> Bool)
-> Stream Identity b -> Stream Identity b -> Identity Bool
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> Bool) -> Stream m a -> Stream m b -> m Bool
Stream.eqBy b -> b -> Bool
forall a. Eq a => a -> a -> Bool
(==) Stream Identity b
x Stream Identity b
y
            toComponents :: Array a -> Stream Identity (Stream Identity Char)
toComponents = (Array a -> Stream Identity Char)
-> Stream Identity (Array a)
-> Stream Identity (Stream Identity Char)
forall a b. (a -> b) -> Stream Identity a -> Stream Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Stream Identity a -> Stream Identity Char)
-> Array a -> Stream Identity Char
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
(Stream m a -> Stream m Char) -> Array a -> Stream m Char
normalizeCaseWith Stream Identity a -> Stream Identity Char
decoder) (Stream Identity (Array a)
 -> Stream Identity (Stream Identity Char))
-> (Array a -> Stream Identity (Array a))
-> Array a
-> Stream Identity (Stream Identity Char)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OS -> Array a -> Stream Identity (Array a)
forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
OS -> Array a -> Stream m (Array a)
splitPath_ OS
os
        -- XXX check perf/fusion
         in Identity Bool -> Bool
forall a. Identity a -> a
runIdentity
                (Identity Bool -> Bool) -> Identity Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Stream Identity Char -> Stream Identity Char -> Bool)
-> Stream Identity (Stream Identity Char)
-> Stream Identity (Stream Identity Char)
-> Identity Bool
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> Bool) -> Stream m a -> Stream m b -> m Bool
Stream.eqBy Stream Identity Char -> Stream Identity Char -> Bool
forall {b}. Eq b => Stream Identity b -> Stream Identity b -> Bool
streamEq (Array a -> Stream Identity (Stream Identity Char)
toComponents Array a
a) (Array a -> Stream Identity (Stream Identity Char)
toComponents Array a
b)
    else
        Identity Bool -> Bool
forall a. Identity a -> a
runIdentity
            (Identity Bool -> Bool) -> Identity Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Array a -> Array a -> Bool)
-> Stream Identity (Array a)
-> Stream Identity (Array a)
-> Identity Bool
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> Bool) -> Stream m a -> Stream m b -> m Bool
Stream.eqBy
                Array a -> Array a -> Bool
forall a. Array a -> Array a -> Bool
Array.byteEq (OS -> Array a -> Stream Identity (Array a)
forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
OS -> Array a -> Stream m (Array a)
splitPath_ OS
os Array a
a) (OS -> Array a -> Stream Identity (Array a)
forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
OS -> Array a -> Stream m (Array a)
splitPath_ OS
os Array a
b)

-- 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.

-- | Like eqPath but we can control the equality options.
--
-- >>> :{
--  cfg = Common.eqCfg {Common.ignoreTrailingSeparators = True, Common.allowRelativeEquality = True}
--  eq a b = Common.eqPathWith Unicode.decodeUtf8' Common.Posix cfg (packPosix a) (packPosix b)
-- :}
--
-- >>> eq "."  "."
-- True
--
-- >>> eq "./"  ".//"
-- True
--
-- >>> eq "./x"  "./x"
-- True
--
-- >>> eq "./x"  "x"
-- True
--
-- >>> eq "x/"  "x"
-- True
--
-- >>> eq "x/"  "X"
-- False
--
-- >>> eq "x//y"  "x/y"
-- True
--
-- >>> eq "x/./y"  "x/y"
-- True
--
-- >>> eq "x"  "x"
-- True
--
-- >>> :{
--  cfg = Common.eqCfg {Common.ignoreTrailingSeparators = True, Common.ignoreCase = True, Common.allowRelativeEquality = True}
--  eq a b = Common.eqPathWith Unicode.decodeUtf16le' Common.Windows cfg (packWindows a) (packWindows b)
-- :}
--
-- >>> eq "./x"  "x"
-- True
--
-- >>> eq "X/"  "x"
-- True
--
-- >>> eq "C:x"  "c:X"
-- True
--
-- >>> eq ".\\x"  "./X"
-- True
--
-- >>> eq "x//y"  "x/y"
-- True
--
-- >>> eq "x/./y"  "x/y"
-- True
--
-- >>> eq "x"  "x"
-- True
--
{-# INLINE eqPathWith #-}
eqPathWith :: (Unbox a, Integral a) =>
    (Stream Identity a -> Stream Identity Char)
    -> OS -> EqCfg -> Array a -> Array a -> Bool
eqPathWith :: forall a.
(Unbox a, Integral a) =>
(Stream Identity a -> Stream Identity Char)
-> OS -> EqCfg -> Array a -> Array a -> Bool
eqPathWith Stream Identity a -> Stream Identity Char
decoder OS
os EqCfg{Bool
ignoreTrailingSeparators :: EqCfg -> Bool
ignoreCase :: EqCfg -> Bool
allowRelativeEquality :: EqCfg -> Bool
ignoreTrailingSeparators :: Bool
ignoreCase :: Bool
allowRelativeEquality :: Bool
..} Array a
a Array a
b =
    let (Array a
rootA, Array a
stemA) = OS -> Array a -> (Array a, Array a)
forall a.
(Unbox a, Integral a) =>
OS -> Array a -> (Array a, Array a)
splitRoot OS
os Array a
a
        (Array a
rootB, Array a
stemB) = OS -> Array a -> (Array a, Array a)
forall a.
(Unbox a, Integral a) =>
OS -> Array a -> (Array a, Array a)
splitRoot OS
os Array a
b

        eqRelative :: Bool
eqRelative =
               if Bool
allowRelativeEquality
               then Bool -> OS -> Array a -> Array a -> Bool
forall a.
(Unbox a, Integral a) =>
Bool -> OS -> Array a -> Array a -> Bool
eqRootLax Bool
ignoreCase OS
os Array a
rootA Array a
rootB
               else (Bool -> Bool
not (OS -> Array a -> Bool
forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
isRootRelative OS
os Array a
rootA)
                    Bool -> Bool -> Bool
&& Bool -> Bool
not (OS -> Array a -> Bool
forall a. (Unbox a, Integral a) => OS -> Array a -> Bool
isRootRelative OS
os Array a
rootB))
                    Bool -> Bool -> Bool
&& Bool -> OS -> Array a -> Array a -> Bool
forall a.
(Unbox a, Integral a) =>
Bool -> OS -> Array a -> Array a -> Bool
eqRootStrict Bool
ignoreCase OS
os Array a
rootA Array a
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 :: Bool
eqTrailingSep =
            Bool
ignoreTrailingSeparators
                Bool -> Bool -> Bool
|| OS -> Array a -> Bool
forall a. (Integral a, Unbox a) => OS -> Array a -> Bool
hasTrailingSeparator OS
os Array a
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== OS -> Array a -> Bool
forall a. (Integral a, Unbox a) => OS -> Array a -> Bool
hasTrailingSeparator OS
os Array a
b

     in
           Bool
eqRelative
        Bool -> Bool -> Bool
&& Bool
eqTrailingSep
        Bool -> Bool -> Bool
&& Bool
-> (Stream Identity a -> Stream Identity Char)
-> OS
-> Array a
-> Array a
-> Bool
forall a.
(Unbox a, Integral a) =>
Bool
-> (Stream Identity a -> Stream Identity Char)
-> OS
-> Array a
-> Array a
-> Bool
eqComponentsWith Bool
ignoreCase Stream Identity a -> Stream Identity Char
decoder OS
os Array a
stemA Array a
stemB

-- | Checks two paths for logical equality. It performs some normalizations on
-- the paths before comparing them, specifically it drops redundant path
-- separators between path segments and redundant "/./" components between
-- segments. On Windows it replaces forward slash path separators by
-- backslashes.
--
-- Equality semantics followed by this routine are listed below. If it returns
-- equal then the paths are definitely equal, if it returns unequal then the
-- paths may still be equal using some relaxed equality criterion.
--
-- * paths with a leading "." and without a leading "." e.g. "./x/y"
-- and "x/y" are treated as unequal. The first one is a dynamically rooted path
-- and the second one is a free path segment.
--
-- * An absolute path and a path relative to "." may be equal depending on the
-- meaning of ".", however this routine treats them as unequal.
--
-- * Two paths starting with a leading "." may not actually be equal even if
-- they are literally equal. We return unequal even though they may be equal
-- sometimes.
--
-- * Two paths having ".." components may be equal after processing the ".."
-- components even if we determined them to be unequal. However, if we
-- determined them to be equal then they must be equal.
--
-- * A path with a trailing slash and a path without are treated as unequal
-- e.g. "x" is not the same as "x/". The latter is a directory.
--
-- * On Windows comparison is case sensitive.
--
-- In short, for strict equality both the paths must be absolute or both must
-- be path segments without a leading root component (e.g. x/y). Also, both
-- must be files or both must be directories.
--
-- >>> :{
--  eqPosix a b = Common.eqPath Unicode.decodeUtf8' Common.Posix (packPosix a) (packPosix b)
--  eqWindows a b = Common.eqPath Unicode.decodeUtf16le' Common.Windows (packWindows a) (packWindows b)
-- :}
--
-- >>> eqPosix "/x"  "//x"
-- True
--
-- >>> eqPosix "x//y"  "x/y"
-- True
--
-- >>> eqPosix "x/./y"  "x/y"
-- True
--
-- >>> eqWindows "x\\y" "x/y"
-- True
--
-- >>> eqPosix "./x"  "x"
-- False
--
-- >>> eqPosix "x/"  "x"
-- False
--
-- >>> eqPosix "x"  "x"
-- True
--
-- >>> eqPosix "x"  "X"
-- False
--
-- >>> eqWindows "x"  "X"
-- False
--
-- >>> eqWindows "c:"  "C:"
-- False
--
-- >>> eqPosix ".."  ".."
-- True
--
-- >>> eqPosix "."  "."
-- False
--
-- >>> eqWindows "c:"  "c:"
-- False
--
-- >>> eqPosix "./x"  "./x"
-- False
--
-- >>> eqWindows "c:x"  "c:x"
-- False
--
{-# INLINE eqPath #-}
eqPath :: (Unbox a, Integral a) =>
    (Stream Identity a -> Stream Identity Char)
        -> OS -> Array a -> Array a -> Bool
eqPath :: forall a.
(Unbox a, Integral a) =>
(Stream Identity a -> Stream Identity Char)
-> OS -> Array a -> Array a -> Bool
eqPath Stream Identity a -> Stream Identity Char
decoder OS
os = (Stream Identity a -> Stream Identity Char)
-> OS -> EqCfg -> Array a -> Array a -> Bool
forall a.
(Unbox a, Integral a) =>
(Stream Identity a -> Stream Identity Char)
-> OS -> EqCfg -> Array a -> Array a -> Bool
eqPathWith Stream Identity a -> Stream Identity Char
decoder OS
os EqCfg
eqCfg