-- Copyright 2018 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | This module tries to avoid confusing relative, absolute, and canonical
-- paths at the type level.  This is different from the hackage @paths@
-- package, because I have Relative to AppDir, and I distinguish Canonical.
--
-- I used to have a separate Absolute path, but the conversions get awkward.
module App.Path (
    AppDir(..), get_app_dir
    , Relative, relative, (</>)
    , to_absolute
    -- * Canonical
    , Canonical, make_canonical, canonical, to_path
    , drop_prefix
) where
import qualified Data.List as List
import qualified Data.String as String
import qualified GHC.Stack as Stack
import qualified System.Directory as Directory
import qualified System.FilePath as FilePath

import qualified Util.Seq as Seq


-- | All paths should be relative to this one.
-- I may later change this to an env var, a flag, or just leave it hardcoded.
get_app_dir :: IO AppDir
get_app_dir :: IO AppDir
get_app_dir = FilePath -> AppDir
AppDir (FilePath -> AppDir) -> IO FilePath -> IO AppDir
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
Directory.getCurrentDirectory

newtype AppDir = AppDir FilePath
    deriving (AppDir -> AppDir -> Bool
(AppDir -> AppDir -> Bool)
-> (AppDir -> AppDir -> Bool) -> Eq AppDir
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AppDir -> AppDir -> Bool
$c/= :: AppDir -> AppDir -> Bool
== :: AppDir -> AppDir -> Bool
$c== :: AppDir -> AppDir -> Bool
Eq, Int -> AppDir -> ShowS
[AppDir] -> ShowS
AppDir -> FilePath
(Int -> AppDir -> ShowS)
-> (AppDir -> FilePath) -> ([AppDir] -> ShowS) -> Show AppDir
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [AppDir] -> ShowS
$cshowList :: [AppDir] -> ShowS
show :: AppDir -> FilePath
$cshow :: AppDir -> FilePath
showsPrec :: Int -> AppDir -> ShowS
$cshowsPrec :: Int -> AppDir -> ShowS
Show)

-- | Paths which are intended to be relative to the app dir get this type,
-- so it's harder to accidentally use them directly.
newtype Relative = Relative FilePath
    deriving (Relative -> Relative -> Bool
(Relative -> Relative -> Bool)
-> (Relative -> Relative -> Bool) -> Eq Relative
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Relative -> Relative -> Bool
$c/= :: Relative -> Relative -> Bool
== :: Relative -> Relative -> Bool
$c== :: Relative -> Relative -> Bool
Eq, Int -> Relative -> ShowS
[Relative] -> ShowS
Relative -> FilePath
(Int -> Relative -> ShowS)
-> (Relative -> FilePath) -> ([Relative] -> ShowS) -> Show Relative
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Relative] -> ShowS
$cshowList :: [Relative] -> ShowS
show :: Relative -> FilePath
$cshow :: Relative -> FilePath
showsPrec :: Int -> Relative -> ShowS
$cshowsPrec :: Int -> Relative -> ShowS
Show, FilePath -> Relative
(FilePath -> Relative) -> IsString Relative
forall a. (FilePath -> a) -> IsString a
fromString :: FilePath -> Relative
$cfromString :: FilePath -> Relative
String.IsString)

relative :: Stack.HasCallStack => FilePath -> Relative
relative :: HasCallStack => FilePath -> Relative
relative FilePath
path
    | FilePath
"/" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isPrefixOf` FilePath
path =
        FilePath -> Relative
forall a. HasCallStack => FilePath -> a
error (FilePath -> Relative) -> FilePath -> Relative
forall a b. (a -> b) -> a -> b
$ FilePath
"so-called relative path no so relative: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
path
    | Bool
otherwise = FilePath -> Relative
Relative FilePath
path

(</>) :: Relative -> Relative -> Relative
Relative FilePath
a </> :: Relative -> Relative -> Relative
</> Relative FilePath
b = FilePath -> Relative
Relative (FilePath
a FilePath -> ShowS
FilePath.</> FilePath
b)

to_absolute :: AppDir -> Relative -> FilePath
to_absolute :: AppDir -> Relative -> FilePath
to_absolute (AppDir FilePath
app_dir) (Relative FilePath
path) = FilePath
app_dir FilePath -> ShowS
FilePath.</> FilePath
path

-- * Canonical

-- | This is a path that is absolute and has had all the symlinks squeezed out.
-- The only reason I have this is that I want to strip the global save dir
-- prefix to get a shorter save file name.  Save filenames come from the user
-- and likely involve symlinks.
newtype Canonical = Canonical FilePath
    deriving (Canonical -> Canonical -> Bool
(Canonical -> Canonical -> Bool)
-> (Canonical -> Canonical -> Bool) -> Eq Canonical
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Canonical -> Canonical -> Bool
$c/= :: Canonical -> Canonical -> Bool
== :: Canonical -> Canonical -> Bool
$c== :: Canonical -> Canonical -> Bool
Eq, Int -> Canonical -> ShowS
[Canonical] -> ShowS
Canonical -> FilePath
(Int -> Canonical -> ShowS)
-> (Canonical -> FilePath)
-> ([Canonical] -> ShowS)
-> Show Canonical
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Canonical] -> ShowS
$cshowList :: [Canonical] -> ShowS
show :: Canonical -> FilePath
$cshow :: Canonical -> FilePath
showsPrec :: Int -> Canonical -> ShowS
$cshowsPrec :: Int -> Canonical -> ShowS
Show)

-- | For tests.
make_canonical :: FilePath -> Canonical
make_canonical :: FilePath -> Canonical
make_canonical = FilePath -> Canonical
Canonical

canonical :: FilePath -> IO Canonical
canonical :: FilePath -> IO Canonical
canonical = (FilePath -> Canonical) -> IO FilePath -> IO Canonical
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Canonical
Canonical (IO FilePath -> IO Canonical)
-> (FilePath -> IO FilePath) -> FilePath -> IO Canonical
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO FilePath
Directory.canonicalizePath

to_path :: Canonical -> FilePath
to_path :: Canonical -> FilePath
to_path (Canonical FilePath
path) = FilePath
path

drop_prefix :: Canonical -> Canonical -> FilePath
drop_prefix :: Canonical -> Canonical -> FilePath
drop_prefix (Canonical FilePath
prefix) (Canonical FilePath
path) =
    (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (FilePath, Bool) -> FilePath
forall a b. (a, b) -> a
fst ((FilePath, Bool) -> FilePath) -> (FilePath, Bool) -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> (FilePath, Bool)
forall a. Eq a => [a] -> [a] -> ([a], Bool)
Seq.drop_prefix FilePath
prefix FilePath
path