uniform-fileio-0.1.5.2: Uniform/FilenamePath.hs

-------------------------------------------------------------------
--
-- Module      :  FilenamePath
-- Copyright   :  andrew u frank -
--
----------------------------------------------------------------------
-- {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-- {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
-- {-# LANGUAGE TypeSynonymInstances #-}
-- {-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
-- {-# OPTIONS_GHC -Wno-deprecations #-}

-- | the operations on filenames and extensions
--  uses the Path library,  
module Uniform.FilenamePath
  ( module Uniform.FilenamePath,
    module Uniform.Error,
    -- -- module Path.Internal,
    -- -- module Uniform.PathShowCase,
    Abs,
    Rel,
    File,
    Dir,
    Path.Path,
    toFilePath,
  )
where


import Path (File, Dir, Abs, Rel, Path, toFilePath)
import qualified Path ((</>), stripProperPrefix, filename, setFileExtension)
import qualified Path as Path (parseRelFile, parseRelDir, parseAbsFile, parseAbsDir)
import qualified Path as P
-- -- import  Path.Internal (Path(..))
import qualified Path.IO as PathIO

import Uniform.Error(ErrIO, callIO)
-- import Uniform.Zero(Zeros(..))
import Uniform.Strings
-- (Text, fromJustNote, t2s)
-- import Uniform.PathShowCase ()
import Uniform.FilenameAlgebra
import Uniform.Filenames
-- import qualified System.Directory as S
import qualified System.FilePath as S 

homeDir :: Path Abs Dir
homeDir = makeAbsDir "/home/frank/" :: Path Abs Dir

homeDir2 :: ErrIO (Path Abs Dir)
homeDir2 = callIO PathIO.getHomeDir :: ErrIO (Path Abs Dir)

-- replace homeDir with homeDir2 - is user independent but requires IO
currentDir :: ErrIO (Path Abs Dir)
currentDir = callIO PathIO.getCurrentDir

setCurrentDir :: Path Abs Dir -> ErrIO ()
setCurrentDir path = PathIO.setCurrentDir (unPath path)

stripProperPrefix' :: Path b Dir -> Path b t -> ErrIO (Path Rel t)
stripProperPrefix' dir fn = Path.stripProperPrefix (unPath dir) (unPath fn)

stripProperPrefixMaybe :: Path b Dir -> Path b t -> Maybe (Path Rel t)
stripProperPrefixMaybe dir fn = Path.stripProperPrefix (unPath dir) (unPath fn)

unPath :: a -> a  -- todo remove
unPath = id
    

makeRelFile :: FilePath -> Path Rel File
makeRelDir :: FilePath -> Path Rel Dir
makeAbsFile :: FilePath -> Path Abs File
makeAbsDir :: FilePath -> Path Abs Dir
makeRelFile fn = fromJustNote ("makeRelFile " ++ fn ++ "|") $ Path.parseRelFile fn

makeRelDir fn = fromJustNote ("makeRelDir " ++ fn ++ "|") $ Path.parseRelDir fn

makeAbsFile fn = fromJustNote ("makeAbsFile " ++ fn ++ "|") $ Path.parseAbsFile fn

makeAbsDir fn = fromJustNote ("makeAbsDir " ++ fn ++ "|") $ Path.parseAbsDir fn

makeRelFileT :: Text -> Path Rel File
makeRelDirT :: Text -> Path Rel Dir
makeAbsFileT :: Text -> Path Abs File
makeAbsDirT :: Text -> Path Abs Dir
makeRelFileT = makeRelFile . t2s

makeRelDirT = makeRelDir . t2s

makeAbsFileT = makeAbsFile . t2s

makeAbsDirT = makeAbsDir . t2s

toShortFilePath :: Path df ar -> FilePath
---- ^ get the filepath, but without the trailing separator
--    , necessary for systemcalls
toShortFilePath = S.dropTrailingPathSeparator . toFilePath

instance Zeros (Path Abs Dir) where
  zero = makeAbsDir "/"

instance Zeros (Path Abs File) where
  zero = makeAbsFile "/zero" 

instance Zeros (Path Rel Dir) where
  zero = makeRelDir "./"

instance Zeros (Path Rel File) where
  zero = makeRelFile "zero"

instance Filenames5 (Path b Dir) (Path b t) (Path Rel t) where
  stripPrefix d f = Path.stripProperPrefix (unPath d) (unPath f)

instance Filenames (Path ar File) (Path Rel File) where
  getFileName = Path.filename . unPath

-- instance Filenames2 (Path b Dir) (Path Rel t ) (Path b t)  where
--     (</>) = (P.</>)


-- instance Filenames3 (Path Rel Dir) FilePath where
--   type FileResultT (Path Rel Dir) FilePath = (Path Rel File)
--   addFileName p d =
--     if null' d
--       then error ("addFileName with empty file" ++ d)
--       else (Path.</>) (unPath p) (unPath d2)
--     where
--       d2 = makeRelFile d :: Path Rel File

-- instance Filenames3 (Path Abs Dir) FilePath where
--   type FileResultT (Path Abs Dir) FilePath = (Path Abs File)
--   addFileName p d =
--     if null' d
--       then error ("addFileName with empty file" ++ d)
--       else (Path.</>) (unPath p) (unPath d2)
--     where
--       d2 = makeRelFile d :: Path Rel File
      
instance Filenames3 (Path b Dir) (Path Rel File) where
  type FileResultT (Path b Dir) (Path Rel File) = (Path b File)
  addFileName p d = (Path.</>) (unPath p) (unPath d)


-- instance Filenames4 (Path Rel Dir) FilePath where
--   type FileResultT4 (Path Rel Dir) FilePath = (Path Rel Dir)
--   addDir p d =
--     if null' d
--       then p
--       else (Path.</>) p   d2
--     where
--       d2 = makeRelDir d :: Path Rel Dir

instance Filenames4 (Path b Dir) (Path Rel Dir) where
  type FileResultT4 (Path b Dir) (Path Rel Dir) = (Path b Dir)
  addDir p d = (Path.</>) (unPath p) (unPath d)



instance Filenames1 (Path ar File) where
  getNakedFileName = getNakedFileName . toFilePath
  getImmediateParentDir = getImmediateParentDir . toFilePath
  getParentDir = getParentDir . toFilePath
  getNakedDir = error "getNakedDir for Filenamse1 Path ar File) not existing"

instance Filenames1 (Path ar Dir) where
  getNakedFileName = error "getNakedFileName not from Dir"
  getImmediateParentDir = getImmediateParentDir . toFilePath
  getParentDir = getParentDir . toFilePath
  getNakedDir = getNakedDir . toFilePath

-- class (Eq (ExtensionType fp)) => Extensions fp where
--   -- extension do not include a leading '.'
--   type ExtensionType fp
--   getExtension :: fp -> ExtensionType fp
--   removeExtension :: fp -> fp
--   addExtension :: ExtensionType fp -> fp -> fp
-- --   setFileExtension :: ExtensionType fp -> fp -> fp 
-- -- to avoid name clash with Path

--   -- must not have an extension before
--   (<.>) :: fp -> ExtensionType fp -> fp -- eror when not legal?
--   (<.>) f e = addExtension e f
--   setExtension :: ExtensionType fp -> fp -> fp
--   setExtension ext   = addExtension ext . removeExtension 
--   hasExtension :: ExtensionType fp -> fp -> Bool
--   hasExtension e = (e ==) . getExtension

--   prop_add_has :: ExtensionType fp -> fp -> Bool
--   prop_add_has e f = hasExtension e (addExtension e f)
--   prop_add_add_has :: ExtensionType fp -> ExtensionType fp -> fp -> Bool
--   prop_add_add_has e1 e2 f =
--     hasExtension
--       e1
--       (setExtension e1 . setExtension e2 $ f)
--   prop_set_get :: ExtensionType fp -> fp -> Bool
--   prop_set_get e f = ((e ==) . getExtension) (setExtension e f)


instance Extensions (Path ar File) where
  type ExtensionType (Path ar File) = Extension

  getExtension f = Extension e
    where
      -- definition of extension in path is with leading '.'
      -- multiple extensions are gradually built and removed
      -- split gives only the last
      -- add allows only one to add
      -- empty extensions throw error

      e = getExtension . toFilePath $ f

  setExtension e f =
    fromJustNote "setExtension" $ Path.setFileExtension (unExtension e) f

  addExtension = setExtension
  removeExtension = setExtension (Extension "")

instance NiceStrings (Path a b) where
  showNice = s2t . toFilePath