{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE UndecidableInstances #-}

module BuildEnv.Path
  ( SymbolicPath, RelativePath, AbsolutePath
  , FileOrDir(..)
  , CWD, Pkg, PkgDb, Project
  , Tmp, Logs, Fetch, Prefix, Install

  , sameDirectory
  , mkSymbolicPath
  , mkRelativePath
  , mkAbsolutePath

  , interpretSymbolicPath
  , getSymbolicPath
  , getAbsolutePath
  , absoluteSymbolicPath
  , makeAbsolute

  , (<.>), (</>)
  )
  where

-- base

import Data.Kind
  ( Type )

-- directory

import qualified System.Directory as Directory

-- filepath

import qualified System.FilePath as FilePath

--------------------------------------------------------------------------------


-- | A type-level symbolic name, to an abstract file or directory

-- (e.g. the Cabal package directory).

data FileOrDir
  = -- | A file (with no further information).

    File
  | -- | The abstract name of a directory or category of directories,

    -- e.g. the package directory or a source directory.

    Dir Type

-- | Is this symbolic path allowed to be absolute, or must it be relative?

data AllowAbsolute
  = -- | The path may be absolute, or it may be relative.

    AllowAbsolute
  | -- | The path must be relative.

    OnlyRelative

-- | A symbolic path, possibly relative to an abstract location specified

-- by the @from@ type parameter.

--

-- They are *symbolic*, which means we cannot perform any 'IO'

-- until we interpret them (using e.g. 'interpretSymbolicPath').

type SymbolicPathX :: AllowAbsolute -> Type -> FileOrDir -> Type
newtype SymbolicPathX allowAbsolute from to = SymbolicPath FilePath
  deriving newtype Int -> SymbolicPathX allowAbsolute from to -> ShowS
[SymbolicPathX allowAbsolute from to] -> ShowS
SymbolicPathX allowAbsolute from to -> String
(Int -> SymbolicPathX allowAbsolute from to -> ShowS)
-> (SymbolicPathX allowAbsolute from to -> String)
-> ([SymbolicPathX allowAbsolute from to] -> ShowS)
-> Show (SymbolicPathX allowAbsolute from to)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
Int -> SymbolicPathX allowAbsolute from to -> ShowS
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
[SymbolicPathX allowAbsolute from to] -> ShowS
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
$cshowsPrec :: forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
Int -> SymbolicPathX allowAbsolute from to -> ShowS
showsPrec :: Int -> SymbolicPathX allowAbsolute from to -> ShowS
$cshow :: forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
show :: SymbolicPathX allowAbsolute from to -> String
$cshowList :: forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
[SymbolicPathX allowAbsolute from to] -> ShowS
showList :: [SymbolicPathX allowAbsolute from to] -> ShowS
Show
type role SymbolicPathX nominal nominal nominal

-- | A symbolic relative path, relative to an abstract location specified

-- by the @from@ type parameter.

--

-- They are *symbolic*, which means we cannot perform any 'IO'

-- until we interpret them (using e.g. 'interpretSymbolicPath').

type RelativePath = SymbolicPathX 'OnlyRelative

-- | A path which is either absolute or relative to the given abstract*

-- location specified by the @from@ type parameter.

--

-- They are *symbolic*, which means we cannot perform any 'IO'

-- until we interpret them (using e.g. 'interpretSymbolicPath').

type SymbolicPath = SymbolicPathX 'AllowAbsolute

-- | An absolute path, or a reference to a path from the PATH environment variable.

type AbsolutePath :: FileOrDir -> Type
newtype AbsolutePath to = AbsolutePath ( forall from. SymbolicPath from to )
instance Show ( AbsolutePath to ) where
  show :: AbsolutePath to -> String
show ( AbsolutePath forall from. SymbolicPath from to
fp ) = SymbolicPath Any to -> String
forall a. Show a => a -> String
show SymbolicPath Any to
forall from. SymbolicPath from to
fp

--------------------------------------------------------------------------------


-- | Abstract directory: current working directory.

data CWD

-- | Abstract directory: project root for 'build-env' commands.

data Project

-- | Abstract directory: package directory (e.g. a directory containing the @.cabal@ file).

data Pkg

-- | Abstract directory: package database directory (e.g. a directory containing a @package.conf@ file).

data PkgDb

-- | Abstract temporary directory.

data Tmp

-- | Abstract directory for logs.

data Logs

-- | Abstract directory: fetched sources directory.

data Fetch

-- | Abstract directory: prefix.

data Prefix

-- | Abstract directory: installation directory.

data Install

--------------------------------------------------------------------------------


mkSymbolicPath :: FilePath -> SymbolicPath from to
mkSymbolicPath :: forall from (to :: FileOrDir). String -> SymbolicPath from to
mkSymbolicPath = String -> SymbolicPathX 'AllowAbsolute from to
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
String -> SymbolicPathX allowAbsolute from to
SymbolicPath

mkRelativePath :: FilePath -> RelativePath from to
mkRelativePath :: forall from (to :: FileOrDir). String -> RelativePath from to
mkRelativePath = String -> SymbolicPathX 'OnlyRelative from to
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
String -> SymbolicPathX allowAbsolute from to
SymbolicPath

mkAbsolutePath :: FilePath -> AbsolutePath to
mkAbsolutePath :: forall (to :: FileOrDir). String -> AbsolutePath to
mkAbsolutePath String
fp = (forall from. SymbolicPath from to) -> AbsolutePath to
forall (to :: FileOrDir).
(forall from. SymbolicPath from to) -> AbsolutePath to
AbsolutePath ( String -> SymbolicPath from to
forall from (to :: FileOrDir). String -> SymbolicPath from to
mkSymbolicPath String
fp )

sameDirectory :: SymbolicPathX allowAbsolute from to
sameDirectory :: forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to
sameDirectory = String -> SymbolicPathX allowAbsolute from to
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
String -> SymbolicPathX allowAbsolute from to
SymbolicPath String
"."

getSymbolicPath :: SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath :: forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath ( SymbolicPath String
p ) = String
p

getAbsolutePath :: AbsolutePath to -> FilePath
getAbsolutePath :: forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath ( AbsolutePath forall from. SymbolicPath from to
p ) = SymbolicPathX 'AllowAbsolute Any to -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPathX 'AllowAbsolute Any to
forall from. SymbolicPath from to
p

absoluteSymbolicPath :: AbsolutePath to -> SymbolicPath from to
absoluteSymbolicPath :: forall (to :: FileOrDir) from.
AbsolutePath to -> SymbolicPath from to
absoluteSymbolicPath ( AbsolutePath forall from. SymbolicPath from to
p ) = SymbolicPath from to
forall from. SymbolicPath from to
p

-- | Interpret a symbolic path with respect to the given directory.

--

-- Use this function before directly interacting with the file system in order

-- to take into account a working directory argument.

interpretSymbolicPath :: SymbolicPath CWD ( Dir dir ) -> SymbolicPathX allowAbsolute dir to -> FilePath
interpretSymbolicPath :: forall dir (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
SymbolicPath CWD ('Dir dir)
-> SymbolicPathX allowAbsolute dir to -> String
interpretSymbolicPath ( SymbolicPath String
workDir ) ( SymbolicPath String
p ) =
  if String
workDir String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"."
  then String
p -- NB: this just avoids creating paths of the form "./././blah".

  else String
workDir String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
p
          -- Note that this properly handles an absolute symbolic path,

          -- because if @q@ is absolute, then @p </> q = q@.


-- | Make the given 'SymbolicPath' absolute.

makeAbsolute :: SymbolicPath CWD ( Dir dir ) -> SymbolicPath dir to -> IO ( AbsolutePath to )
makeAbsolute :: forall dir (to :: FileOrDir).
SymbolicPath CWD ('Dir dir)
-> SymbolicPath dir to -> IO (AbsolutePath to)
makeAbsolute SymbolicPath CWD ('Dir dir)
workDir SymbolicPath dir to
path =
  String -> AbsolutePath to
forall (to :: FileOrDir). String -> AbsolutePath to
mkAbsolutePath (String -> AbsolutePath to) -> IO String -> IO (AbsolutePath to)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
Directory.makeAbsolute ( SymbolicPath CWD ('Dir dir) -> SymbolicPath dir to -> String
forall dir (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
SymbolicPath CWD ('Dir dir)
-> SymbolicPathX allowAbsolute dir to -> String
interpretSymbolicPath SymbolicPath CWD ('Dir dir)
workDir SymbolicPath dir to
path )

-------------------------------------------------------------------------------


-- * Composition


-------------------------------------------------------------------------------


infixr 7 <.>

-- | Types that support 'System.FilePath.<.>'.

class FileLike p where
  -- | Like 'System.FilePath.<.>', but also supporting symbolic paths.

  (<.>) :: p -> String -> p

instance FileLike FilePath where
  <.> :: String -> ShowS
(<.>) = String -> ShowS
(FilePath.<.>)

instance p ~ File => FileLike ( SymbolicPathX allowAbsolute dir p ) where
  SymbolicPath String
p <.> :: SymbolicPathX allowAbsolute dir p
-> String -> SymbolicPathX allowAbsolute dir p
<.> String
ext = String -> SymbolicPathX allowAbsolute dir p
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
String -> SymbolicPathX allowAbsolute from to
SymbolicPath ( String
p String -> ShowS
forall p. FileLike p => p -> String -> p
<.> String
ext )

instance p ~ File => FileLike ( AbsolutePath p ) where
  AbsolutePath p
p <.> :: AbsolutePath p -> String -> AbsolutePath p
<.> String
ext = String -> AbsolutePath p
forall (to :: FileOrDir). String -> AbsolutePath to
mkAbsolutePath ( AbsolutePath p -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath AbsolutePath p
p String -> ShowS
forall p. FileLike p => p -> String -> p
<.> String
ext )

infixr 5 </>

-- | Types that support 'System.FilePath.</>'.

class PathLike p q r | q r -> p, p q -> r where
  -- | Like 'System.FilePath.</>', but also supporting symbolic paths.

  (</>) :: p -> q -> r

instance ( q ~ FilePath ) => PathLike FilePath q FilePath where
  </> :: String -> q -> String
(</>) = String -> q -> String
String -> ShowS
(FilePath.</>)

-- | This instance ensures we don't accidentally discard a symbolic path

-- in a 'System.FilePath.</>' operation due to the second path being absolute.

--

-- (Recall that @a </> b = b@ whenever @b@ is absolute.)

instance
  (b1 ~ 'Dir b2, a3 ~ a1, c2 ~ c3)
  => PathLike
      ( SymbolicPathX allowAbsolute a1 b1 )
      ( SymbolicPathX midAbsolute   b2 c2 )
      ( SymbolicPathX allowAbsolute a3 c3 )
  where
  SymbolicPath String
p1 </> :: SymbolicPathX allowAbsolute a1 b1
-> SymbolicPathX midAbsolute b2 c2
-> SymbolicPathX allowAbsolute a3 c3
</> SymbolicPath String
p2 =
    if String
p1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"."
    then String -> SymbolicPathX allowAbsolute a3 c3
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
String -> SymbolicPathX allowAbsolute from to
SymbolicPath String
p2 -- NB: this just avoids creating paths of the form "./././blah".

    else String -> SymbolicPathX allowAbsolute a3 c3
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
String -> SymbolicPathX allowAbsolute from to
SymbolicPath (String
p1 String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
p2)

instance
  ( b1 ~ 'Dir b2, c2 ~ c3, midAbsolute ~ OnlyRelative )
  => PathLike
      ( AbsolutePath                 b1 )
      ( SymbolicPathX midAbsolute b2 c2 )
      ( AbsolutePath                 c3 )
  where
  AbsolutePath (SymbolicPath String
p1) </> :: AbsolutePath b1
-> SymbolicPathX midAbsolute b2 c2 -> AbsolutePath c3
</> SymbolicPath String
p2 =
    String -> AbsolutePath c3
forall (to :: FileOrDir). String -> AbsolutePath to
mkAbsolutePath (String
p1 String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
p2)