{-# LANGUAGE UnliftedFFITypes #-}
-- |
-- Module      : Streamly.Internal.FileSystem.Path.Common
-- Copyright   : (c) 2023 Composewell Technologies
-- License     : BSD3
-- Maintainer  : streamly@composewell.com
-- Portability : GHC
--
module Streamly.Internal.FileSystem.Path.Common
    (
    -- * Types
      OS (..)

    -- * Validation
    , validatePath
    , validatePath'
    , validateFile

    -- * Construction
    , fromArray
    , unsafeFromArray
    , fromChars
    , unsafeFromChars

    -- * Quasiquoters
    , mkQ

    -- * Elimination
    , toString
    , toChars

    -- * Separators
    , primarySeparator
    , isSeparator
    , isSeparatorWord
    , dropTrailingSeparators
    , dropTrailingBy
    , hasTrailingSeparator
    , hasLeadingSeparator

    -- * Tests
    , isBranch
    , isRooted
    , isAbsolute
 -- , isRelative -- not isAbsolute
    , isRootRelative -- XXX hasRelativeRoot
    , isRelativeWithDrive -- XXX hasRelativeDriveRoot
    , hasDrive

    -- * Joining
    , append
    , append'
    , unsafeAppend
    , appendCString
    , appendCString'
    , unsafeJoinPaths
 -- , joinRoot -- XXX append should be enough

    -- * Splitting

    -- Note: splitting the search path does not belong here, it is shell aware
    -- operation. search path is separated by : and : is allowed in paths on
    -- posix. Shell would escape it which needs to be handled.

    , splitRoot
 -- , dropRoot
 -- , dropRelRoot -- if relative then dropRoot
    , splitHead
    , splitTail
    , splitPath
    , splitPath_

    -- * Dir and File
    , splitFile
    , splitDir

    -- * Extensions
    , extensionWord
    , splitExtension
    , splitExtensionBy
 -- , addExtension

    -- * Equality
 -- , processParentRefs
    , normalizeSeparators
 -- , normalize -- separators and /./ components (split/combine)
    , eqPathBytes
    , EqCfg(..)
    , eqPath
 -- , commonPrefix -- common prefix of two paths
 -- , eqPrefix -- common prefix is equal to first path
 -- , dropPrefix

    -- * Utilities
    , wordToChar
    , charToWord
    , unsafeIndexChar

    -- * Internal
    , unsafeSplitTopLevel
    , unsafeSplitDrive
    , unsafeSplitUNC
    , splitCompact
    , splitWithFilter
    )
where

#include "assert.hs"

import Control.Monad (when)
import Control.Monad.Catch (MonadThrow(..))
import Control.Monad.IO.Class (MonadIO(..))
import Data.Char (chr, ord, isAlpha, toUpper)
import Data.Function ((&))
import Data.Functor.Identity (Identity(..))
import Data.Word (Word8, Word16)
import Foreign (castPtr)
import Foreign.C (CString, CSize(..))
import GHC.Base (unsafeChr, Addr#)
import GHC.Ptr (Ptr(..))
import Language.Haskell.TH (Q, Exp)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Streamly.Internal.Data.Array (Array(..))
import Streamly.Internal.Data.MutArray (MutArray)
import Streamly.Internal.Data.MutByteArray (Unbox(..))
import Streamly.Internal.Data.Path (PathException(..))
import Streamly.Internal.Data.Stream (Stream)
import System.IO.Unsafe (unsafePerformIO)

import qualified Data.List as List
import qualified Streamly.Internal.Data.Array as Array
import qualified Streamly.Internal.Data.Fold as Fold
import qualified Streamly.Internal.Data.MutArray as MutArray
import qualified Streamly.Internal.Data.Stream as Stream
import qualified Streamly.Internal.Unicode.Stream as Unicode

{- $setup
>>> :m

>>> import Data.Functor.Identity (runIdentity)
>>> import System.IO.Unsafe (unsafePerformIO)
>>> import qualified Streamly.Data.Stream as Stream
>>> import qualified Streamly.Unicode.Stream as Unicode
>>> import qualified Streamly.Internal.Data.Array as Array
>>> import qualified Streamly.Internal.FileSystem.Path.Common as Common
>>> import qualified Streamly.Internal.Unicode.Stream as Unicode
>>> import Streamly.Internal.FileSystem.Path (ignoreTrailingSeparators, allowRelativeEquality, ignoreCase)

>>> packPosix = unsafePerformIO . Stream.fold Array.create . Unicode.encodeUtf8' . Stream.fromList
>>> unpackPosix = runIdentity . Stream.toList . Unicode.decodeUtf8' . Array.read

>>> packWindows = unsafePerformIO . Stream.fold Array.create . Unicode.encodeUtf16le' . Stream.fromList
>>> unpackWindows = runIdentity . Stream.toList . Unicode.decodeUtf16le' . Array.read
-}

data OS = Windows | Posix deriving 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.

-- XXX Windows is supported only on little endian machines so generally we do
-- not need covnersion from LE to BE format unless we want to manipulate
-- windows paths on big-endian machines.

-- | Unsafe, may tructate to shorter word types, can only be used safely for
-- characters that fit in the given word size.
charToWord :: Integral a => Char -> a
charToWord :: 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 ':'.
--
-- Can't use any arbitrary predicate "p", the logic in this depends on assuming
-- that it is a path separator.
{-# INLINE dropTrailingBy #-}
dropTrailingBy :: (Unbox a, Integral a) =>
    OS -> (a -> Bool) -> Array a -> Array a
dropTrailingBy :: 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
            -- Even though "//" is not allowed as a valid path.
            -- We still handle that case in this low level function.
            if OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
Windows
                Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
                Bool -> Bool -> Bool
&& Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndex Int
0 Array a
arr a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Array a -> a
forall a. Unbox a => Int -> Array a -> a
Array.unsafeGetIndex Int
1 Array a
arr
            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
2 Array a
arr -- make it "//" share name
            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
1 Array a
arr
        -- "c:////" - keep one "/" after colon in ".*:///" otherwise it will
        -- change the meaning. "c:/" may also appear, in the middle e.g.
        -- in UNC paths.
        else if (OS
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

-- XXX we cannot compact "//" to "/" on windows
{-# 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

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

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?

{-# 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))

-- Split a path into its components.
--
-- Usage:
-- @
-- splitPathUsing withSep ignoreLeading os arr
-- @
--
-- if withSep == True then keep the trailing separators.
--
-- if ignoreLeading == True we drop all leading separators and relative paths.
-- Example behaviour (psuedo-code):
-- @
-- > f = splitPathUsing (withSep = False) (ignoreLeading = True)
-- > f "./a/b/c" == ["a","b","c"]
-- > f "./a/./b/c" == ["a","b","c"]
-- > f "/a/./b/c" == ["a","b","c"]
-- > f "/./a/./b/c" == ["a","b","c"]
-- > f "././a/./b/c" == ["a","b","c"]
-- > f "a/./b/c" == ["a","b","c"]
-- @
--
-- We can safely set @ignoreLeading = True@ if we splitRoot prior and only pass
-- the stem of the path to this function.
{-# INLINE splitPathUsing #-}
splitPathUsing
    :: (Unbox a, Integral a, Monad m)
    => Bool
    -> Bool
    -> OS
    -> Array a
    -> Stream m (Array a)
splitPathUsing :: forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
Bool -> Bool -> OS -> Array a -> Stream m (Array a)
splitPathUsing Bool
withSep Bool
ignoreLeading 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 Bool
ignoreLeading Bool -> Bool -> Bool
|| 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

{-# 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 -> Bool -> OS -> Array a -> Stream m (Array a)
forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
Bool -> Bool -> OS -> Array a -> Stream m (Array a)
splitPathUsing Bool
False Bool
False

{-# 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 -> Bool -> OS -> Array a -> Stream m (Array a)
forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
Bool -> Bool -> OS -> Array a -> Stream m (Array a)
splitPathUsing Bool
True Bool
False

-- | Split the first non-empty path component.
--
-- /Unimplemented/
{-# INLINE splitHead #-}
splitHead :: -- (Unbox a, Integral a) =>
    OS -> Array a -> (Array a, Maybe (Array a))
splitHead :: forall a. OS -> Array a -> (Array a, Maybe (Array a))
splitHead OS
_os Array a
_arr = (Array a, Maybe (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 -> (Maybe (Array a), Array a)
splitTail :: forall a. OS -> Array a -> (Maybe (Array a), Array a)
splitTail OS
_os Array a
_arr = (Maybe (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. (?callStack::CallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, 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. (?callStack::CallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, 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. (?callStack::CallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, 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. (?callStack::CallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, 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 ()

{-# INLINE splitFile #-}
splitFile :: (Unbox a, Integral a) =>
    OS -> Array a -> Maybe (Maybe (Array a), Array a)
splitFile :: forall a.
(Unbox a, Integral a) =>
OS -> Array a -> Maybe (Maybe (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 (Maybe (Array a), Array a) -> Maybe (Maybe (Array a), Array a)
forall a. a -> Maybe a
Just (Maybe (Array a)
forall a. Maybe a
Nothing, Array a
arr)
            else (Maybe (Array a), Array a) -> Maybe (Maybe (Array a), Array a)
forall a. a -> Maybe a
Just (Array a -> Maybe (Array a)
forall a. a -> Maybe a
Just (Array a -> Maybe (Array a)) -> Array a -> Maybe (Array a)
forall a b. (a -> b) -> a -> b
$ 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 Maybe (Maybe (Array a), Array a)
forall a. Maybe a
Nothing

-- | Split a multi-component path into (dir, last component). If the path has a
-- single component and it is a root then return (path, "") otherwise return
-- ("", path).
--
-- Split a single component into (dir, "") if it can be a dir i.e. it is either
-- a path root, "." or ".." or has a trailing separator.
--
-- The only difference between splitFile and splitDir:
--
-- >> splitFile "a/b/"
-- ("a/b/", "")
-- >> splitDir "a/b/"
-- ("a/", "b/")
--
-- This is equivalent to splitPath and keeping the last component but is usually
-- faster.
--
-- >>> toList (a,b) = (unpackPosix a, unpackPosix b)
-- >>> splitPosix = toList . Common.splitDir Common.Posix . packPosix
--
-- >> splitPosix "/"
-- ("/","")
--
-- >> splitPosix "."
-- (".","")
--
-- >> splitPosix "/."
-- ("/.","")
--
-- >> splitPosix "/x"
-- ("/","x")
--
-- >> splitPosix "/x/"
-- ("/","x/")
--
-- >> splitPosix "//"
-- ("//","")
--
-- >> splitPosix "./x"
-- ("./","x")
--
-- >> splitPosix "x"
-- ("","x")
--
-- >> splitPosix "x/"
-- ("x/","")
--
-- >> splitPosix "x/y"
-- ("x/","y")
--
-- >> splitPosix "x/y/"
-- ("x/","y/")
--
-- >> splitPosix "x/y//"
-- ("x/","y//")
--
-- >> splitPosix "x//y"
-- ("x//","y")
--
-- >> splitPosix "x/./y"
-- ("x/./","y")
--
-- /Unimplemented/
{-# INLINE splitDir #-}
splitDir :: -- (Unbox a, Integral a) =>
    OS -> Array a -> (Array a, Array a)
splitDir :: 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 -> Maybe (Array a, Array a)
splitExtensionBy :: forall a.
(Unbox a, Integral a) =>
a -> OS -> Array a -> Maybe (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) -> Maybe (Array a, Array a)
forall a. a -> Maybe a
Just (Array a, Array a)
res
        else Maybe (Array a, Array a)
forall a. Maybe a
Nothing

{-# INLINE splitExtension #-}
splitExtension :: (Unbox a, Integral a) => OS -> Array a -> Maybe (Array a, Array a)
splitExtension :: forall a.
(Unbox a, Integral a) =>
OS -> Array a -> Maybe (Array a, Array a)
splitExtension = a -> OS -> Array a -> Maybe (Array a, Array a)
forall a.
(Unbox a, Integral a) =>
a -> OS -> Array a -> Maybe (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. (?callStack::CallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, 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. (?callStack::CallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, 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. (?callStack::CallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, 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. (?callStack::CallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, 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. (?callStack::CallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, 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. (?callStack::CallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, 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. (?callStack::CallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, 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. (?callStack::CallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, 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. (?callStack::CallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, 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. (?callStack::CallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, 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

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

{-# INLINE unsafeFromArray #-}
unsafeFromArray :: Array a -> Array a
unsafeFromArray :: forall a. Array a -> Array a
unsafeFromArray = Array a -> Array a
forall a. a -> a
id

{-# INLINE fromArray #-}
fromArray :: forall m a. (MonadThrow m, Unbox a, Integral a) =>
    OS -> Array a -> m (Array a)
fromArray :: forall (m :: * -> *) a.
(MonadThrow m, Unbox a, Integral a) =>
OS -> Array a -> m (Array a)
fromArray OS
os Array a
arr = OS -> Array a -> m ()
forall (m :: * -> *) a.
(MonadThrow m, Integral a, Unbox a) =>
OS -> Array a -> m ()
validatePath OS
os Array a
arr 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
arr
{-
    let arr1 = Array.unsafeCast arr :: Array a
     in validatePath os arr1 >> pure arr1
fromArray Windows arr =
    case Array.cast arr of
        Nothing ->
            throwM
                $ InvalidPath
                $ "Encoded path length " ++ show (Array.byteLength arr)
                    ++ " is not a multiple of 16-bit."
        Just x -> validatePath Windows x >> pure x
-}

{-# INLINE unsafeFromChars #-}
unsafeFromChars :: (Unbox a) =>
       (Stream Identity Char -> Stream Identity a)
    -> Stream Identity Char
    -> Array a
unsafeFromChars :: 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)

-- 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 a -> m (Array a)
forall (m :: * -> *) a.
(MonadThrow m, Unbox a, Integral a) =>
OS -> Array a -> m (Array a)
fromArray OS
os (Array a -> Array a
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

{-# 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)

{-# 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 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
    -- Note: if the last char on the first array is ":" and first char on the
    -- second array is "/" then we cannot drop the "/". We drop only if both
    -- are separators excluding ":".
    let arrB :: 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

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

{-# 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)

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

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 macOs can have case insensitive comparison. On Windows also
-- case sensitive behavior may depend on the file system being used.

-- Use eq prefix?

-- | Options for path comparison operation. By default path comparison uses a
-- strict criteria for equality. The following options are provided to
-- control the strictness.
--
-- The default configuration is as follows:
--
-- >>> :{
-- defaultMod = ignoreTrailingSeparators False
--            . ignoreCase False
--            . allowRelativeEquality False
-- :}
--
data EqCfg =
    EqCfg
    { 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"
    }

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) =>
       EqCfg
    -> (Stream Identity a -> Stream Identity Char)
    -> OS
    -> Array a
    -> Array a
    -> Bool
eqComponentsWith :: forall a.
(Unbox a, Integral a) =>
EqCfg
-> (Stream Identity a -> Stream Identity Char)
-> OS
-> Array a
-> Array a
-> Bool
eqComponentsWith EqCfg{Bool
_ignoreTrailingSeparators :: EqCfg -> Bool
_ignoreCase :: EqCfg -> Bool
_allowRelativeEquality :: EqCfg -> Bool
_ignoreTrailingSeparators :: Bool
_ignoreCase :: Bool
_allowRelativeEquality :: Bool
..} Stream Identity a -> Stream Identity Char
decoder OS
os Array a
a Array a
b =
    if Bool
_ignoreCase
    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)
splitter 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)
splitter OS
os Array a
a) (OS -> Array a -> Stream Identity (Array a)
splitter OS
os Array a
b)
    where
    splitter :: OS -> Array a -> Stream Identity (Array a)
splitter = Bool -> Bool -> OS -> Array a -> Stream Identity (Array a)
forall a (m :: * -> *).
(Unbox a, Integral a, Monad m) =>
Bool -> Bool -> OS -> Array a -> Stream m (Array a)
splitPathUsing Bool
False Bool
_allowRelativeEquality

-- XXX can we do something like SpecConstr for such functions e.g. without
-- inlining the function we can use two copies one for _allowRelativeEquality
-- True and other for False and so on for other values of PathEq.

{-# INLINE eqPath #-}
eqPath :: (Unbox a, Integral a) =>
    (Stream Identity a -> Stream Identity Char)
    -> OS -> EqCfg -> Array a -> Array a -> Bool
eqPath :: forall a.
(Unbox a, Integral a) =>
(Stream Identity a -> Stream Identity Char)
-> OS -> EqCfg -> Array a -> Array a -> Bool
eqPath Stream Identity a -> Stream Identity Char
decoder OS
os eqCfg :: EqCfg
eqCfg@(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
&& EqCfg
-> (Stream Identity a -> Stream Identity Char)
-> OS
-> Array a
-> Array a
-> Bool
forall a.
(Unbox a, Integral a) =>
EqCfg
-> (Stream Identity a -> Stream Identity Char)
-> OS
-> Array a
-> Array a
-> Bool
eqComponentsWith EqCfg
eqCfg Stream Identity a -> Stream Identity Char
decoder OS
os Array a
stemA Array a
stemB