{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Provides types.
module Charon.Data.PathType
  ( PathTypeW (..),
    deleteFn,
    existsFn,
    renameFn,
    copyPath,
  )
where

-- import Charon.Class.Serial (Serial (DecodeExtra, decode, encode))
import Charon.Prelude
import Codec.Serialise (Serialise (encode))
import Codec.Serialise qualified as Serialise
import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON))
import Data.Aeson qualified as Asn
import Data.Text qualified as T
import Effects.FileSystem.PathWriter
  ( CopyDirConfig (MkCopyDirConfig),
    MonadPathWriter (removeFile),
    Overwrite (OverwriteDirectories),
    TargetName (TargetNameSrc),
  )
import Effects.FileSystem.PathWriter qualified as PW

-- | Wrapper for PathType, so that we can give a Hashable instance.
newtype PathTypeW = MkPathTypeW {PathTypeW -> PathType
unPathTypeW :: PathType}
  deriving stock (PathTypeW -> PathTypeW -> Bool
(PathTypeW -> PathTypeW -> Bool)
-> (PathTypeW -> PathTypeW -> Bool) -> Eq PathTypeW
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PathTypeW -> PathTypeW -> Bool
== :: PathTypeW -> PathTypeW -> Bool
$c/= :: PathTypeW -> PathTypeW -> Bool
/= :: PathTypeW -> PathTypeW -> Bool
Eq, (forall x. PathTypeW -> Rep PathTypeW x)
-> (forall x. Rep PathTypeW x -> PathTypeW) -> Generic PathTypeW
forall x. Rep PathTypeW x -> PathTypeW
forall x. PathTypeW -> Rep PathTypeW x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PathTypeW -> Rep PathTypeW x
from :: forall x. PathTypeW -> Rep PathTypeW x
$cto :: forall x. Rep PathTypeW x -> PathTypeW
to :: forall x. Rep PathTypeW x -> PathTypeW
Generic, Int -> PathTypeW -> ShowS
[PathTypeW] -> ShowS
PathTypeW -> String
(Int -> PathTypeW -> ShowS)
-> (PathTypeW -> String)
-> ([PathTypeW] -> ShowS)
-> Show PathTypeW
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PathTypeW -> ShowS
showsPrec :: Int -> PathTypeW -> ShowS
$cshow :: PathTypeW -> String
show :: PathTypeW -> String
$cshowList :: [PathTypeW] -> ShowS
showList :: [PathTypeW] -> ShowS
Show)
  deriving anyclass (PathTypeW -> ()
(PathTypeW -> ()) -> NFData PathTypeW
forall a. (a -> ()) -> NFData a
$crnf :: PathTypeW -> ()
rnf :: PathTypeW -> ()
NFData)

makeFieldLabelsNoPrefix ''PathTypeW

instance Hashable PathTypeW where
  hashWithSalt :: Int -> PathTypeW -> Int
hashWithSalt Int
int (MkPathTypeW PathType
PathTypeFile) = forall a. Hashable a => Int -> a -> Int
hashWithSalt @Int Int
int Int
1
  hashWithSalt Int
int (MkPathTypeW PathType
PathTypeDirectory) = forall a. Hashable a => Int -> a -> Int
hashWithSalt @Int Int
int Int
2
  hashWithSalt Int
int (MkPathTypeW PathType
PathTypeSymbolicLink) = forall a. Hashable a => Int -> a -> Int
hashWithSalt @Int Int
int Int
3
  hashWithSalt Int
int (MkPathTypeW PathType
PathTypeOther) = forall a. Hashable a => Int -> a -> Int
hashWithSalt @Int Int
int Int
4

instance Pretty PathTypeW where
  pretty :: forall ann. PathTypeW -> Doc ann
pretty (MkPathTypeW PathType
PathTypeFile) = Doc ann
"File"
  pretty (MkPathTypeW PathType
PathTypeDirectory) = Doc ann
"Directory"
  pretty (MkPathTypeW PathType
PathTypeSymbolicLink) = Doc ann
"Symlink"
  pretty (MkPathTypeW PathType
PathTypeOther) = Doc ann
"Other"

instance ToJSON PathTypeW where
  toJSON :: PathTypeW -> Value
toJSON (MkPathTypeW PathType
PathTypeFile) = Value
"f"
  toJSON (MkPathTypeW PathType
PathTypeDirectory) = Value
"d"
  toJSON (MkPathTypeW PathType
PathTypeSymbolicLink) = Value
"l"
  toJSON (MkPathTypeW PathType
PathTypeOther) = Value
"o"

instance FromJSON PathTypeW where
  parseJSON :: Value -> Parser PathTypeW
parseJSON = String -> (Text -> Parser PathTypeW) -> Value -> Parser PathTypeW
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Asn.withText String
"PathType" ((Text -> Parser PathTypeW) -> Value -> Parser PathTypeW)
-> (Text -> Parser PathTypeW) -> Value -> Parser PathTypeW
forall a b. (a -> b) -> a -> b
$ \case
    Text
"f" -> PathTypeW -> Parser PathTypeW
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathTypeW -> Parser PathTypeW) -> PathTypeW -> Parser PathTypeW
forall a b. (a -> b) -> a -> b
$ PathType -> PathTypeW
MkPathTypeW PathType
PathTypeFile
    Text
"d" -> PathTypeW -> Parser PathTypeW
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathTypeW -> Parser PathTypeW) -> PathTypeW -> Parser PathTypeW
forall a b. (a -> b) -> a -> b
$ PathType -> PathTypeW
MkPathTypeW PathType
PathTypeDirectory
    Text
"l" -> PathTypeW -> Parser PathTypeW
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathTypeW -> Parser PathTypeW) -> PathTypeW -> Parser PathTypeW
forall a b. (a -> b) -> a -> b
$ PathType -> PathTypeW
MkPathTypeW PathType
PathTypeSymbolicLink
    Text
"o" -> PathTypeW -> Parser PathTypeW
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathTypeW -> Parser PathTypeW) -> PathTypeW -> Parser PathTypeW
forall a b. (a -> b) -> a -> b
$ PathType -> PathTypeW
MkPathTypeW PathType
PathTypeOther
    Text
other -> String -> Parser PathTypeW
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser PathTypeW) -> String -> Parser PathTypeW
forall a b. (a -> b) -> a -> b
$ String
"Expected one of (f|d|l|o), received: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
other

instance Serialise PathTypeW where
  encode :: PathTypeW -> Encoding
encode (MkPathTypeW PathType
PathTypeFile) = forall a. Serialise a => a -> Encoding
Serialise.encode @Char Char
'f'
  encode (MkPathTypeW PathType
PathTypeDirectory) = forall a. Serialise a => a -> Encoding
Serialise.encode @Char Char
'd'
  encode (MkPathTypeW PathType
PathTypeSymbolicLink) = forall a. Serialise a => a -> Encoding
Serialise.encode @Char Char
'l'
  encode (MkPathTypeW PathType
PathTypeOther) = forall a. Serialise a => a -> Encoding
Serialise.encode @Char Char
'o'

  decode :: forall s. Decoder s PathTypeW
decode = do
    Char
c <- forall a s. Serialise a => Decoder s a
Serialise.decode @Char
    case Char
c of
      Char
'f' -> PathTypeW -> Decoder s PathTypeW
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathTypeW -> Decoder s PathTypeW)
-> PathTypeW -> Decoder s PathTypeW
forall a b. (a -> b) -> a -> b
$ PathType -> PathTypeW
MkPathTypeW PathType
PathTypeFile
      Char
'd' -> PathTypeW -> Decoder s PathTypeW
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathTypeW -> Decoder s PathTypeW)
-> PathTypeW -> Decoder s PathTypeW
forall a b. (a -> b) -> a -> b
$ PathType -> PathTypeW
MkPathTypeW PathType
PathTypeDirectory
      Char
'l' -> PathTypeW -> Decoder s PathTypeW
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathTypeW -> Decoder s PathTypeW)
-> PathTypeW -> Decoder s PathTypeW
forall a b. (a -> b) -> a -> b
$ PathType -> PathTypeW
MkPathTypeW PathType
PathTypeSymbolicLink
      Char
'o' -> PathTypeW -> Decoder s PathTypeW
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathTypeW -> Decoder s PathTypeW)
-> PathTypeW -> Decoder s PathTypeW
forall a b. (a -> b) -> a -> b
$ PathType -> PathTypeW
MkPathTypeW PathType
PathTypeOther
      Char
other -> String -> Decoder s PathTypeW
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s PathTypeW) -> String -> Decoder s PathTypeW
forall a b. (a -> b) -> a -> b
$ String
"Expected (f|d|l|o), received: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
other]

-- | This function tests both existence __and__ that the the path is of the
-- specified type.
existsFn ::
  ( HasCallStack,
    MonadCatch m,
    MonadPathReader m
  ) =>
  PathTypeW ->
  OsPath ->
  m Bool
existsFn :: forall (m :: * -> *).
(HasCallStack, MonadCatch m, MonadPathReader m) =>
PathTypeW -> OsPath -> m Bool
existsFn (MkPathTypeW PathType
PathTypeFile) = OsPath -> m Bool
forall (m :: * -> *).
(MonadPathReader m, HasCallStack) =>
OsPath -> m Bool
doesFileExist
existsFn (MkPathTypeW PathType
PathTypeDirectory) = OsPath -> m Bool
forall (m :: * -> *).
(MonadPathReader m, HasCallStack) =>
OsPath -> m Bool
doesDirectoryExist
existsFn (MkPathTypeW PathType
PathTypeSymbolicLink) = OsPath -> m Bool
forall (m :: * -> *).
(HasCallStack, MonadCatch m, MonadPathReader m) =>
OsPath -> m Bool
doesSymbolicLinkExist
existsFn (MkPathTypeW PathType
PathTypeOther) = OsPath -> m Bool
forall (m :: * -> *).
(MonadPathReader m, HasCallStack) =>
OsPath -> m Bool
doesFileExist

renameFn ::
  ( HasCallStack,
    MonadPathWriter m
  ) =>
  PathTypeW ->
  OsPath ->
  OsPath ->
  m ()
renameFn :: forall (m :: * -> *).
(HasCallStack, MonadPathWriter m) =>
PathTypeW -> OsPath -> OsPath -> m ()
renameFn (MkPathTypeW PathType
PathTypeFile) = OsPath -> OsPath -> m ()
forall (m :: * -> *).
(MonadPathWriter m, HasCallStack) =>
OsPath -> OsPath -> m ()
renameFile
renameFn (MkPathTypeW PathType
PathTypeDirectory) = OsPath -> OsPath -> m ()
forall (m :: * -> *).
(MonadPathWriter m, HasCallStack) =>
OsPath -> OsPath -> m ()
renameDirectory
renameFn (MkPathTypeW PathType
PathTypeSymbolicLink) = OsPath -> OsPath -> m ()
forall (m :: * -> *).
(MonadPathWriter m, HasCallStack) =>
OsPath -> OsPath -> m ()
PW.renamePath
renameFn (MkPathTypeW PathType
PathTypeOther) = OsPath -> OsPath -> m ()
forall (m :: * -> *).
(MonadPathWriter m, HasCallStack) =>
OsPath -> OsPath -> m ()
renameFile

deleteFn ::
  ( HasCallStack,
    MonadCatch m,
    MonadPathReader m,
    MonadPathWriter m
  ) =>
  PathTypeW ->
  OsPath ->
  m ()
deleteFn :: forall (m :: * -> *).
(HasCallStack, MonadCatch m, MonadPathReader m,
 MonadPathWriter m) =>
PathTypeW -> OsPath -> m ()
deleteFn (MkPathTypeW PathType
PathTypeFile) = OsPath -> m ()
forall (m :: * -> *).
(MonadPathWriter m, HasCallStack) =>
OsPath -> m ()
removeFile
deleteFn (MkPathTypeW PathType
PathTypeDirectory) = OsPath -> m ()
forall (m :: * -> *).
(MonadPathWriter m, HasCallStack) =>
OsPath -> m ()
removeDirectoryRecursive
deleteFn (MkPathTypeW PathType
PathTypeSymbolicLink) = OsPath -> m ()
forall (m :: * -> *).
(HasCallStack, MonadCatch m, MonadPathReader m,
 MonadPathWriter m) =>
OsPath -> m ()
PW.removeSymbolicLink
deleteFn (MkPathTypeW PathType
PathTypeOther) = OsPath -> m ()
forall (m :: * -> *).
(MonadPathWriter m, HasCallStack) =>
OsPath -> m ()
removeFile

copyPath ::
  ( HasCallStack,
    MonadIORef m,
    MonadMask m,
    MonadPathReader m,
    MonadPathWriter m
  ) =>
  PathTypeW ->
  -- | Old path to copy.
  OsPath ->
  -- | Fully qualified name for file copy.
  OsPath ->
  -- | The directory in which to copy, for a dir copy.
  OsPath ->
  m ()
copyPath :: forall (m :: * -> *).
(HasCallStack, MonadIORef m, MonadMask m, MonadPathReader m,
 MonadPathWriter m) =>
PathTypeW -> OsPath -> OsPath -> OsPath -> m ()
copyPath (MkPathTypeW PathType
PathTypeFile) OsPath
old OsPath
newName OsPath
_ = OsPath -> OsPath -> m ()
forall (m :: * -> *).
(MonadPathWriter m, HasCallStack) =>
OsPath -> OsPath -> m ()
PW.copyFileWithMetadata OsPath
old OsPath
newName
copyPath (MkPathTypeW PathType
PathTypeSymbolicLink) OsPath
old OsPath
newName OsPath
_ = OsPath -> OsPath -> m ()
forall (m :: * -> *).
(HasCallStack, MonadCatch m, MonadPathReader m,
 MonadPathWriter m) =>
OsPath -> OsPath -> m ()
PW.copySymbolicLink OsPath
old OsPath
newName
copyPath (MkPathTypeW PathType
PathTypeDirectory) OsPath
old OsPath
_ OsPath
newDir =
  CopyDirConfig -> OsPath -> OsPath -> m ()
forall (m :: * -> *).
(HasCallStack, MonadIORef m, MonadMask m, MonadPathReader m,
 MonadPathWriter m) =>
CopyDirConfig -> OsPath -> OsPath -> m ()
PW.copyDirectoryRecursiveConfig CopyDirConfig
copyConfig OsPath
old OsPath
newDir
  where
    copyConfig :: CopyDirConfig
copyConfig =
      MkCopyDirConfig
        { -- Need OverwriteDirectories because we may be performing multiple
          -- writes to the same dir (e.g. consider copying paths to a new
          -- trash dir during convert).
          overwrite :: Overwrite
overwrite = Overwrite
OverwriteDirectories,
          targetName :: TargetName
targetName = TargetName
TargetNameSrc
        }
copyPath (MkPathTypeW PathType
PathTypeOther) OsPath
old OsPath
newName OsPath
_ = OsPath -> OsPath -> m ()
forall (m :: * -> *).
(MonadPathWriter m, HasCallStack) =>
OsPath -> OsPath -> m ()
PW.copyFileWithMetadata OsPath
old OsPath
newName