mirror of
https://github.com/composewell/streamly.git
synced 2024-09-11 19:47:10 +03:00
Implement fromPath in IsPath instances
This commit is contained in:
Harendra Kumar
parent
e3bdda3bef
commit
ae41ed3a25
@ -34,6 +34,7 @@ instance Exception PathException
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- XXX Swap the order of IsPath arguments?
|
||||
-- XXX rename to fromBase, fromBasePath, fromOsPath?
|
||||
|
||||
-- | If the type @a b@ is a member of 'IsPath' it means we know how to convert
|
||||
-- the type @b@ to and from the base type @a@.
|
||||
|
||||
@ -11,6 +11,7 @@ module Streamly.Internal.FileSystem.Path.Common
|
||||
(
|
||||
-- * Types
|
||||
OS (..)
|
||||
|
||||
-- * Construction
|
||||
, fromChunk
|
||||
, unsafeFromChunk
|
||||
@ -33,6 +34,11 @@ module Streamly.Internal.FileSystem.Path.Common
|
||||
|
||||
, append
|
||||
, unsafeAppend
|
||||
|
||||
-- * Utilities
|
||||
, wordToChar
|
||||
, charToWord
|
||||
, unsafeIndexChar
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
@ -169,6 +169,8 @@ instance IsPath OS_PATH OS_PATH where
|
||||
-- should not verify it again e.g. if we adapt (Loc path) as (Loc (Dir path))
|
||||
-- then we should not verify it to be Loc again.
|
||||
|
||||
-- XXX castPath?
|
||||
|
||||
-- | Convert a path type to another path type. This operation may fail with a
|
||||
-- 'PathException' when converting a less restrictive path type to a more
|
||||
-- restrictive one. This can be used to upgrade or downgrade type safety.
|
||||
@ -200,13 +202,15 @@ dropTrailingSeparators (OS_PATH arr) =
|
||||
-- | /Unsafe/: The user is responsible to make sure that the cases mentioned in
|
||||
-- OS_PATH are satisfied.
|
||||
{-# INLINE unsafeFromChunk #-}
|
||||
unsafeFromChunk :: Array Word8 -> OS_PATH
|
||||
unsafeFromChunk = OS_PATH . Common.unsafeFromChunk
|
||||
unsafeFromChunk :: IsPath OS_PATH a => Array Word8 -> a
|
||||
unsafeFromChunk = unsafeFromPath . OS_PATH . Common.unsafeFromChunk
|
||||
|
||||
-- XXX mkPath?
|
||||
|
||||
-- | See 'fromChars' for failure cases.
|
||||
--
|
||||
fromChunk :: MonadThrow m => Array Word8 -> m OS_PATH
|
||||
fromChunk = fmap OS_PATH . Common.fromChunk
|
||||
fromChunk :: (MonadThrow m, IsPath OS_PATH a) => Array Word8 -> m a
|
||||
fromChunk arr = fmap OS_PATH (Common.fromChunk arr) >>= fromPath
|
||||
|
||||
-- XXX Should be a Fold instead?
|
||||
|
||||
@ -222,13 +226,15 @@ fromChunk = fmap OS_PATH . Common.fromChunk
|
||||
--
|
||||
-- Unicode normalization is not done. If normalization is needed the user can
|
||||
-- normalize it and use the fromChunk API.
|
||||
fromChars :: MonadThrow m => Stream Identity Char -> m OS_PATH
|
||||
fromChars =
|
||||
fmap OS_PATH . Common.fromChars (== '\0') Unicode.UNICODE_ENCODER
|
||||
fromChars :: (MonadThrow m, IsPath OS_PATH a) => Stream Identity Char -> m a
|
||||
fromChars s =
|
||||
fmap OS_PATH (Common.fromChars (== '\0') Unicode.UNICODE_ENCODER s)
|
||||
>>= fromPath
|
||||
|
||||
unsafeFromString :: [Char] -> OS_PATH
|
||||
unsafeFromString :: IsPath OS_PATH a => [Char] -> a
|
||||
unsafeFromString =
|
||||
OS_PATH
|
||||
unsafeFromPath
|
||||
. OS_PATH
|
||||
. Common.unsafeFromChars (== '\0') Unicode.UNICODE_ENCODER
|
||||
. Stream.fromList
|
||||
|
||||
@ -236,7 +242,7 @@ unsafeFromString =
|
||||
--
|
||||
-- >>> fromString = Path.fromChars . Stream.fromList
|
||||
--
|
||||
fromString :: MonadThrow m => [Char] -> m OS_PATH
|
||||
fromString :: (MonadThrow m, IsPath OS_PATH a) => [Char] -> m a
|
||||
fromString = fromChars . Stream.fromList
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -245,10 +251,12 @@ fromString = fromChars . Stream.fromList
|
||||
|
||||
-- XXX We can lift the array directly, ByteArray has a lift instance. Does that
|
||||
-- work better?
|
||||
--
|
||||
-- XXX Make this polymorphic and reusable in other modules.
|
||||
|
||||
liftPath :: OS_PATH -> Q Exp
|
||||
liftPath p =
|
||||
[| unsafeFromString $(lift $ toString p) |]
|
||||
[| unsafeFromString $(lift $ toString p) :: OS_PATH |]
|
||||
|
||||
-- | Generates a Haskell expression of type OS_PATH from a String.
|
||||
--
|
||||
@ -276,12 +284,14 @@ path = mkQ pathExp
|
||||
-- Eimination
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- XXX unPath?
|
||||
|
||||
-- | Convert the path to an array of bytes.
|
||||
toChunk :: OS_PATH -> Array Word8
|
||||
toChunk (OS_PATH arr) = Common.toChunk arr
|
||||
toChunk :: IsPath OS_PATH a => a -> Array Word8
|
||||
toChunk p = let OS_PATH arr = toPath p in Common.toChunk arr
|
||||
|
||||
-- | Decode the path to a stream of Unicode chars using strict CODEC_NAME decoding.
|
||||
toChars :: (Monad m, IsPath OS_PATH p) => p -> Stream m Char
|
||||
toChars :: (Monad m, IsPath OS_PATH a) => a -> Stream m Char
|
||||
toChars p =
|
||||
let (OS_PATH arr) =
|
||||
toPath p in Common.toChars Unicode.UNICODE_DECODER arr
|
||||
@ -330,6 +340,7 @@ isSegment :: OS_PATH -> Bool
|
||||
isSegment = not . isLocation
|
||||
|
||||
-- XXX This can be generalized to an Array intersperse operation
|
||||
-- XXX This can work on a polymorphic IsPath type.
|
||||
|
||||
{-# INLINE unsafeAppend #-}
|
||||
unsafeAppend :: OS_PATH -> OS_PATH -> OS_PATH
|
||||
|
||||
@ -31,16 +31,12 @@ module Streamly.Internal.FileSystem.OS_PATH.FileDir
|
||||
, Dir (..)
|
||||
, IsFileDir
|
||||
|
||||
-- * Construction
|
||||
, dirFromString -- dirString?
|
||||
, fileFromString
|
||||
|
||||
-- ** Statically Verified String Literals
|
||||
-- * Statically Verified Path Literals
|
||||
-- | Quasiquoters.
|
||||
, dir
|
||||
, file
|
||||
|
||||
-- ** Statically Verified Strings
|
||||
-- * Statically Verified Path Strings
|
||||
-- | Template Haskell expression splices.
|
||||
, dirExp
|
||||
, fileExp
|
||||
@ -51,17 +47,18 @@ module Streamly.Internal.FileSystem.OS_PATH.FileDir
|
||||
where
|
||||
|
||||
import Control.Monad.Catch (MonadThrow(..))
|
||||
import Language.Haskell.TH (Q, Exp)
|
||||
import Language.Haskell.TH.Syntax (lift)
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter)
|
||||
import Streamly.Internal.Data.Path (IsPath(..), PathException(..))
|
||||
import Streamly.Internal.FileSystem.Path.Common (OS(..), mkQ)
|
||||
import Streamly.Internal.FileSystem.OS_PATH (OS_PATH(..))
|
||||
|
||||
import qualified Streamly.Internal.Data.Array as Array
|
||||
import qualified Streamly.Internal.Data.Stream as Stream
|
||||
import qualified Streamly.Internal.FileSystem.Path.Common as Common
|
||||
import qualified Streamly.Internal.FileSystem.OS_PATH as OsPath
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Quote
|
||||
import Streamly.Internal.Data.Path
|
||||
|
||||
{- $setup
|
||||
>>> :m
|
||||
>>> :set -XQuasiQuotes
|
||||
@ -86,7 +83,25 @@ instance IsFileDir (Dir a)
|
||||
|
||||
instance IsPath OS_PATH (File OS_PATH) where
|
||||
unsafeFromPath = File
|
||||
fromPath p = pure (File p)
|
||||
|
||||
-- Cannot have "." or ".." as last component.
|
||||
fromPath p@(OS_PATH arr) = do
|
||||
s1 <-
|
||||
Stream.toList
|
||||
$ Stream.take 3
|
||||
$ Stream.takeWhile (not . Common.isSeparator OS_NAME)
|
||||
$ fmap Common.wordToChar
|
||||
$ Array.readRev arr
|
||||
-- XXX On posix we just need to check last 3 bytes of the array
|
||||
case s1 of
|
||||
'.' : xs ->
|
||||
case xs of
|
||||
[] -> throwM $ InvalidPath "A file name cannot be \".\""
|
||||
'.' : [] ->
|
||||
throwM $ InvalidPath "A file name cannot be \"..\""
|
||||
_ -> pure $ File p
|
||||
_ -> pure $ File p
|
||||
|
||||
toPath (File p) = p
|
||||
|
||||
instance IsPath OS_PATH (Dir OS_PATH) where
|
||||
@ -94,26 +109,6 @@ instance IsPath OS_PATH (Dir OS_PATH) where
|
||||
fromPath p = pure (Dir p)
|
||||
toPath (Dir p) = p
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
--
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- | Any valid path could be a directory.
|
||||
dirFromString :: MonadThrow m => String -> m (Dir OS_PATH)
|
||||
dirFromString s = Dir <$> OsPath.fromString s
|
||||
|
||||
-- | Cannot have "." or ".." as last component.
|
||||
fileFromString :: MonadThrow m => String -> m (File OS_PATH)
|
||||
fileFromString s = do
|
||||
r@(OS_PATH _arr) <- OsPath.fromString s
|
||||
-- XXX take it from the array
|
||||
let s1 = reverse $ takeWhile (not . Common.isSeparator Posix) (reverse s)
|
||||
in if s1 == "."
|
||||
then throwM $ InvalidPath "A file name cannot be \".\""
|
||||
else if s1 == ".."
|
||||
then throwM $ InvalidPath "A file name cannot be \"..\""
|
||||
else (pure . File) r
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Statically Verified Strings
|
||||
------------------------------------------------------------------------------
|
||||
@ -123,21 +118,21 @@ fileFromString s = do
|
||||
|
||||
liftDir :: Dir OS_PATH -> Q Exp
|
||||
liftDir (Dir p) =
|
||||
[| Dir (OsPath.unsafeFromString $(lift $ OsPath.toString p)) |]
|
||||
[| OsPath.unsafeFromString $(lift $ OsPath.toString p) :: Dir OS_PATH |]
|
||||
|
||||
liftFile :: File OS_PATH -> Q Exp
|
||||
liftFile (File p) =
|
||||
[| File (OsPath.unsafeFromString $(lift $ OsPath.toString p)) |]
|
||||
[| OsPath.unsafeFromString $(lift $ OsPath.toString p) :: File OS_PATH |]
|
||||
|
||||
-- | Generates a Haskell expression of type @Dir OS_PATH@.
|
||||
--
|
||||
dirExp :: String -> Q Exp
|
||||
dirExp = either (error . show) liftDir . dirFromString
|
||||
dirExp = either (error . show) liftDir . OsPath.fromString
|
||||
|
||||
-- | Generates a Haskell expression of type @File OS_PATH@.
|
||||
--
|
||||
fileExp :: String -> Q Exp
|
||||
fileExp = either (error . show) liftFile . fileFromString
|
||||
fileExp = either (error . show) liftFile . OsPath.fromString
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Statically Verified Literals
|
||||
|
||||
@ -36,17 +36,12 @@ module Streamly.Internal.FileSystem.OS_PATH.LocSeg
|
||||
, Seg (..)
|
||||
, IsLocSeg
|
||||
|
||||
-- * Construction
|
||||
-- ** From String
|
||||
, locFromString -- locString?
|
||||
, segFromString
|
||||
|
||||
-- ** Statically Verified String Literals
|
||||
-- * Statically Verified Path Literals
|
||||
-- | Quasiquoters.
|
||||
, loc
|
||||
, seg
|
||||
|
||||
-- ** Statically Verified Strings
|
||||
-- * Statically Verified Path Strings
|
||||
-- | Template Haskell expression splices.
|
||||
, locExp
|
||||
, segExp
|
||||
@ -57,20 +52,15 @@ module Streamly.Internal.FileSystem.OS_PATH.LocSeg
|
||||
where
|
||||
|
||||
import Control.Monad.Catch (MonadThrow(..))
|
||||
import Data.Word (Word8)
|
||||
import Language.Haskell.TH (Q, Exp)
|
||||
import Language.Haskell.TH.Syntax (lift)
|
||||
import Streamly.Internal.Data.Array (Array(..))
|
||||
import Streamly.Internal.FileSystem.Path.Common (OS(..), mkQ)
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter)
|
||||
import Streamly.Internal.Data.Path (IsPath(..), PathException(..))
|
||||
import Streamly.Internal.FileSystem.Path.Common (mkQ)
|
||||
import Streamly.Internal.FileSystem.OS_PATH (OS_PATH(..))
|
||||
|
||||
import qualified Streamly.Internal.Data.Array as Array
|
||||
import qualified Streamly.Internal.FileSystem.Path.Common as Common
|
||||
import qualified Streamly.Internal.FileSystem.OS_PATH as OsPath
|
||||
|
||||
import Language.Haskell.TH hiding (Loc)
|
||||
import Language.Haskell.TH.Quote
|
||||
import Streamly.Internal.Data.Path
|
||||
|
||||
{- $setup
|
||||
>>> :m
|
||||
>>> :set -XQuasiQuotes
|
||||
@ -88,12 +78,24 @@ newtype Seg a = Seg a
|
||||
|
||||
instance IsPath OS_PATH (Loc OS_PATH) where
|
||||
unsafeFromPath = Loc
|
||||
fromPath p = pure (Loc p)
|
||||
fromPath p =
|
||||
if OsPath.isLocation p
|
||||
then pure (Loc p)
|
||||
-- XXX Add more detailed error msg with all valid examples.
|
||||
else throwM $ InvalidPath
|
||||
$ "Must be a specific location, not a path segment: "
|
||||
++ OsPath.toString p
|
||||
toPath (Loc p) = p
|
||||
|
||||
instance IsPath OS_PATH (Seg OS_PATH) where
|
||||
unsafeFromPath = Seg
|
||||
fromPath p = pure (Seg p)
|
||||
fromPath p =
|
||||
if OsPath.isSegment p
|
||||
then pure (Seg p)
|
||||
-- XXX Add more detailed error msg with all valid examples.
|
||||
else throwM $ InvalidPath
|
||||
$ "Must be a path segment, not a specific location: "
|
||||
++ OsPath.toString p
|
||||
toPath (Seg p) = p
|
||||
|
||||
-- | Constraint to check if a type has Loc or Seg annotations.
|
||||
@ -102,55 +104,27 @@ class IsLocSeg a
|
||||
instance IsLocSeg (Loc a)
|
||||
instance IsLocSeg (Seg a)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
--
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
locFromChunk :: MonadThrow m => Array Word8 -> m (Loc OS_PATH)
|
||||
locFromChunk arr = do
|
||||
if Common.isLocation OS_NAME arr
|
||||
then fmap Loc (OsPath.fromChunk arr)
|
||||
-- XXX Add more detailed error msg with all valid examples.
|
||||
else throwM $ InvalidPath "Must be a specific location, not a path segment"
|
||||
|
||||
locFromString :: MonadThrow m => String -> m (Loc OS_PATH)
|
||||
locFromString s = do
|
||||
OS_PATH arr <- OsPath.fromString s
|
||||
locFromChunk (Array.castUnsafe arr)
|
||||
|
||||
segFromChunk :: MonadThrow m => Array Word8 -> m (Seg OS_PATH)
|
||||
segFromChunk arr = do
|
||||
if Common.isSegment OS_NAME arr
|
||||
then fmap Seg (OsPath.fromChunk arr)
|
||||
-- XXX Add more detailed error msg with all valid examples.
|
||||
else throwM $ InvalidPath "Must be a path segment, not a specific location"
|
||||
|
||||
segFromString :: MonadThrow m => String -> m (Seg OS_PATH)
|
||||
segFromString s = do
|
||||
OS_PATH arr <- OsPath.fromString s
|
||||
segFromChunk (Array.castUnsafe arr)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Statically Verified Strings
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
liftLoc :: Loc OS_PATH -> Q Exp
|
||||
liftLoc (Loc p) =
|
||||
[| Loc (OsPath.unsafeFromString $(lift $ OsPath.toString p)) |]
|
||||
[| OsPath.unsafeFromString $(lift $ OsPath.toString p) :: Loc OS_PATH |]
|
||||
|
||||
liftSeg :: Seg OS_PATH -> Q Exp
|
||||
liftSeg (Seg p) =
|
||||
[| Seg (OsPath.unsafeFromString $(lift $ OsPath.toString p)) |]
|
||||
[| OsPath.unsafeFromString $(lift $ OsPath.toString p) :: Seg OS_PATH |]
|
||||
|
||||
-- | Generates a Haskell expression of type @Loc OS_PATH@.
|
||||
--
|
||||
locExp :: String -> Q Exp
|
||||
locExp = either (error . show) liftLoc . locFromString
|
||||
locExp = either (error . show) liftLoc . OsPath.fromString
|
||||
|
||||
-- | Generates a Haskell expression of type @Seg OS_PATH@.
|
||||
--
|
||||
segExp :: String -> Q Exp
|
||||
segExp = either (error . show) liftSeg . segFromString
|
||||
segExp = either (error . show) liftSeg . OsPath.fromString
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Statically Verified Literals
|
||||
|
||||
@ -25,24 +25,14 @@
|
||||
|
||||
module Streamly.Internal.FileSystem.OS_PATH.Typed
|
||||
(
|
||||
-- * Types
|
||||
HasDir
|
||||
|
||||
-- * Construction
|
||||
-- ** From String
|
||||
, dirLocFromString -- dirLocString?
|
||||
, dirSegFromString
|
||||
, fileLocFromString
|
||||
, fileSegFromString
|
||||
|
||||
-- ** Statically Verified String Literals
|
||||
-- * Statically Verified Path Literals
|
||||
-- | Quasiquoters.
|
||||
, dirloc
|
||||
dirloc
|
||||
, dirseg
|
||||
, fileloc
|
||||
, fileseg
|
||||
|
||||
-- ** Statically Verified Strings
|
||||
-- * Statically Verified Path Strings
|
||||
-- | Template Haskell expression splices.
|
||||
, dirLocExp
|
||||
, dirSegExp
|
||||
@ -54,15 +44,13 @@ module Streamly.Internal.FileSystem.OS_PATH.Typed
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Catch (MonadThrow(..))
|
||||
import Language.Haskell.TH.Syntax (lift)
|
||||
import Streamly.Internal.FileSystem.Path.Common (mkQ)
|
||||
import Streamly.Internal.FileSystem.OS_PATH (OS_PATH(..))
|
||||
import Streamly.Internal.FileSystem.OS_PATH.LocSeg (Loc(..), Seg(..))
|
||||
import Streamly.Internal.FileSystem.OS_PATH.FileDir (File(..), Dir(..))
|
||||
|
||||
import qualified Streamly.Internal.FileSystem.OS_PATH as OS_NAME
|
||||
import qualified Streamly.Internal.FileSystem.OS_PATH.LocSeg as LocSeg
|
||||
import qualified Streamly.Internal.FileSystem.OS_PATH as OsPath
|
||||
|
||||
import Language.Haskell.TH hiding (Loc)
|
||||
import Language.Haskell.TH.Quote
|
||||
@ -84,51 +72,86 @@ For APIs that have not been released yet.
|
||||
|
||||
-- Note that (Loc a) may also be a directory if "a" is (Dir b), but it can also
|
||||
-- be a file if "a" is (File b). Therefore, the constraints are put on a more
|
||||
-- spspecific type e.g. (Loc OS_PATH) may be a dir.
|
||||
-- specific type e.g. (Loc OS_PATH) may be a dir.
|
||||
|
||||
{-
|
||||
-- | Constraint to check if a type represents a directory.
|
||||
class HasDir a
|
||||
|
||||
instance HasDir (Dir a)
|
||||
instance HasDir (Loc (Dir a))
|
||||
instance HasDir (Seg (Dir a))
|
||||
-}
|
||||
|
||||
-- Design notes:
|
||||
--
|
||||
-- There are two ways in which we can lift or upgrade a lower level path to a
|
||||
-- higher level one. Lift each type directly from the base path e.g. Loc (Dir
|
||||
-- PosixPath) can be created directly from PosixPath. This allows us to do dir
|
||||
-- checks and loc checks at the same time in a monolithic manner. But this also
|
||||
-- makes us do the Dir checks again if we are lifting from Dir to Loc. This
|
||||
-- leads to less complicated constraints, more convenient type conversions.
|
||||
--
|
||||
-- Another alternative is to lift one segment at a time, so we lift PosixPath
|
||||
-- to Dir and then Dir to Loc. This way the checks are serialized, we perform
|
||||
-- the dir checks first and then Loc checks, we cannot combine them together.
|
||||
-- The advantage is that when lifting from Dir to Loc we do not need to do the
|
||||
-- Dir checks. The disadvantage is less convenient conversion because of
|
||||
-- stronger typing, we will need two steps - fromPath . fromPath and toPath .
|
||||
-- toPath to upgrade or downgrade instead of just adapt.
|
||||
--
|
||||
{-
|
||||
instance IsPath (File OS_PATH) (Loc (File OS_PATH)) where
|
||||
unsafeFromPath = Loc
|
||||
fromPath (File p) = do
|
||||
_ :: Loc OS_PATH <- fromPath p
|
||||
pure $ Loc (File p)
|
||||
toPath (Loc p) = p
|
||||
|
||||
instance IsPath (Loc OS_PATH) (Loc (File OS_PATH)) where
|
||||
unsafeFromPath = Loc
|
||||
fromPath (File p) = do
|
||||
_ :: File OS_PATH <- fromPath p
|
||||
pure $ Loc (File p)
|
||||
toPath (Loc p) = p
|
||||
-}
|
||||
|
||||
-- Assuming that lifting from Dir/File to Loc/Seg is not common and even if it
|
||||
-- is then the combined cost of doing Dir/Loc checks would be almost the same
|
||||
-- as individual checks, we take the first approach.
|
||||
|
||||
instance IsPath OS_PATH (Loc (File OS_PATH)) where
|
||||
unsafeFromPath p = Loc (File p)
|
||||
fromPath p = pure (Loc (File p))
|
||||
fromPath p = do
|
||||
_ :: File OS_PATH <- fromPath p
|
||||
_ :: Loc OS_PATH <- fromPath p
|
||||
pure $ Loc (File p)
|
||||
toPath (Loc (File p)) = p
|
||||
|
||||
instance IsPath OS_PATH (Loc (Dir OS_PATH)) where
|
||||
unsafeFromPath p = Loc (Dir p)
|
||||
fromPath p = pure (Loc (Dir p))
|
||||
fromPath p = do
|
||||
_ :: Dir OS_PATH <- fromPath p
|
||||
_ :: Loc OS_PATH <- fromPath p
|
||||
pure $ Loc (Dir p)
|
||||
toPath (Loc (Dir p)) = p
|
||||
|
||||
instance IsPath OS_PATH (Seg (File OS_PATH)) where
|
||||
unsafeFromPath p = Seg (File p)
|
||||
fromPath p = pure (Seg (File p))
|
||||
fromPath p = do
|
||||
_ :: File OS_PATH <- fromPath p
|
||||
_ :: Seg OS_PATH <- fromPath p
|
||||
pure $ Seg (File p)
|
||||
toPath (Seg (File p)) = p
|
||||
|
||||
instance IsPath OS_PATH (Seg (Dir OS_PATH)) where
|
||||
unsafeFromPath p = Seg (Dir p)
|
||||
fromPath p = pure (Seg (Dir p))
|
||||
fromPath p = do
|
||||
_ :: Dir OS_PATH <- fromPath p
|
||||
_ :: Seg OS_PATH <- fromPath p
|
||||
pure $ Seg (Dir p)
|
||||
toPath (Seg (Dir p)) = p
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
--
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
dirLocFromString :: MonadThrow m => String -> m (Loc (Dir OS_PATH))
|
||||
dirLocFromString s = LocSeg.locFromString s >>= OS_NAME.adapt
|
||||
|
||||
dirSegFromString :: MonadThrow m => String -> m (Seg (Dir OS_PATH))
|
||||
dirSegFromString s = LocSeg.segFromString s >>= OS_NAME.adapt
|
||||
|
||||
fileLocFromString :: MonadThrow m => String -> m (Loc (File OS_PATH))
|
||||
fileLocFromString s = OS_NAME.fromString s >>= OS_NAME.adapt
|
||||
|
||||
fileSegFromString :: MonadThrow m => String -> m (Seg (File OS_PATH))
|
||||
fileSegFromString s = OS_NAME.fromString s >>= OS_NAME.adapt
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Statically Verified Strings
|
||||
------------------------------------------------------------------------------
|
||||
@ -138,39 +161,39 @@ fileSegFromString s = OS_NAME.fromString s >>= OS_NAME.adapt
|
||||
|
||||
liftDirLoc :: Loc (Dir OS_PATH) -> Q Exp
|
||||
liftDirLoc (Loc (Dir p)) =
|
||||
[| Loc (Dir (OS_NAME.unsafeFromString $(lift $ OS_NAME.toString p))) |]
|
||||
[| OsPath.unsafeFromString $(lift $ OsPath.toString p) :: Loc (Dir OS_PATH)|]
|
||||
|
||||
liftDirSeg :: Seg (Dir OS_PATH) -> Q Exp
|
||||
liftDirSeg (Seg (Dir p)) =
|
||||
[| Seg (Dir (OS_NAME.unsafeFromString $(lift $ OS_NAME.toString p))) |]
|
||||
[| OsPath.unsafeFromString $(lift $ OsPath.toString p) :: Seg (Dir OS_PATH) |]
|
||||
|
||||
liftFileLoc :: Loc (File OS_PATH) -> Q Exp
|
||||
liftFileLoc (Loc (File p)) =
|
||||
[| Loc (File (OS_NAME.unsafeFromString $(lift $ OS_NAME.toString p))) |]
|
||||
[| OsPath.unsafeFromString $(lift $ OsPath.toString p) :: Loc (File OS_PATH)|]
|
||||
|
||||
liftFileSeg :: Seg (File OS_PATH) -> Q Exp
|
||||
liftFileSeg (Seg (File p)) =
|
||||
[| Seg (File (OS_NAME.unsafeFromString $(lift $ OS_NAME.toString p))) |]
|
||||
[| OsPath.unsafeFromString $(lift $ OsPath.toString p) :: Seg (File OS_PATH)|]
|
||||
|
||||
-- | Generates a Haskell expression of type @Loc (Dir OS_PATH)@.
|
||||
--
|
||||
dirLocExp :: String -> Q Exp
|
||||
dirLocExp = either (error . show) liftDirLoc . dirLocFromString
|
||||
dirLocExp = either (error . show) liftDirLoc . OsPath.fromString
|
||||
|
||||
-- | Generates a Haskell expression of type @Seg (Dir OS_PATH)@.
|
||||
--
|
||||
dirSegExp :: String -> Q Exp
|
||||
dirSegExp = either (error . show) liftDirSeg . dirSegFromString
|
||||
dirSegExp = either (error . show) liftDirSeg . OsPath.fromString
|
||||
|
||||
-- | Generates a Haskell expression of type @Loc (File OS_PATH)@.
|
||||
--
|
||||
fileLocExp :: String -> Q Exp
|
||||
fileLocExp = either (error . show) liftFileLoc . fileLocFromString
|
||||
fileLocExp = either (error . show) liftFileLoc . OsPath.fromString
|
||||
|
||||
-- | Generates a Haskell expression of type @Seg (File OS_PATH)@.
|
||||
--
|
||||
fileSegExp :: String -> Q Exp
|
||||
fileSegExp = either (error . show) liftFileSeg . fileSegFromString
|
||||
fileSegExp = either (error . show) liftFileSeg . OsPath.fromString
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Statically Verified Literals
|
||||
@ -287,4 +310,5 @@ append ::
|
||||
, IsPath OS_PATH (b OS_PATH)
|
||||
, IsPath OS_PATH (a (b OS_PATH))
|
||||
) => a (Dir OS_PATH) -> Seg (b OS_PATH) -> a (b OS_PATH)
|
||||
append a (Seg c) = unsafeFromPath $ OS_NAME.unsafeAppend (toPath a) (toPath c)
|
||||
append p1 (Seg p2) =
|
||||
unsafeFromPath $ OsPath.unsafeAppend (toPath p1) (toPath p2)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user