{-# LANGUAGE TemplateHaskell #-}

module Drasil.Build.Artifacts.FilePath
  ( -- * File Path Segments
    PathSegment,

    -- ** Construction
    ps,
    (</>),

    -- ** Unpacking
    toPath,
  )
where

import Language.Haskell.TH (Exp, Q, listE, mkName, stringE, varE)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import System.FilePath (pathSeparator)
import System.OsPath (OsPath, encodeUtf)
import System.OsPath qualified as FP ((</>))
import Prelude hiding (writeFile)

-- | Represents a single valid segment of a path (e.g., a file or directory
-- /name/, usually the terminal basename of a path). Does not allow path
-- segments to be any of: `..`, `.`, nor `~`. Assumes case-sensitive equality.
newtype PathSegment = PS {PathSegment -> OsPath
unPS :: OsPath}
  deriving (PathSegment -> PathSegment -> Bool
(PathSegment -> PathSegment -> Bool)
-> (PathSegment -> PathSegment -> Bool) -> Eq PathSegment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PathSegment -> PathSegment -> Bool
== :: PathSegment -> PathSegment -> Bool
$c/= :: PathSegment -> PathSegment -> Bool
/= :: PathSegment -> PathSegment -> Bool
Eq, Eq PathSegment
Eq PathSegment =>
(PathSegment -> PathSegment -> Ordering)
-> (PathSegment -> PathSegment -> Bool)
-> (PathSegment -> PathSegment -> Bool)
-> (PathSegment -> PathSegment -> Bool)
-> (PathSegment -> PathSegment -> Bool)
-> (PathSegment -> PathSegment -> PathSegment)
-> (PathSegment -> PathSegment -> PathSegment)
-> Ord PathSegment
PathSegment -> PathSegment -> Bool
PathSegment -> PathSegment -> Ordering
PathSegment -> PathSegment -> PathSegment
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PathSegment -> PathSegment -> Ordering
compare :: PathSegment -> PathSegment -> Ordering
$c< :: PathSegment -> PathSegment -> Bool
< :: PathSegment -> PathSegment -> Bool
$c<= :: PathSegment -> PathSegment -> Bool
<= :: PathSegment -> PathSegment -> Bool
$c> :: PathSegment -> PathSegment -> Bool
> :: PathSegment -> PathSegment -> Bool
$c>= :: PathSegment -> PathSegment -> Bool
>= :: PathSegment -> PathSegment -> Bool
$cmax :: PathSegment -> PathSegment -> PathSegment
max :: PathSegment -> PathSegment -> PathSegment
$cmin :: PathSegment -> PathSegment -> PathSegment
min :: PathSegment -> PathSegment -> PathSegment
Ord)

-- | Retrieve 'OsPath' representation of a 'PathSegment'.
toPath :: PathSegment -> OsPath
toPath :: PathSegment -> OsPath
toPath = PathSegment -> OsPath
unPS
-- NOTE: 'toPath' is exported (& exists) so that 'PathSegment's internal
-- 'OsPath' can be read, but a 'PathSegment' can never be updated via normal
-- accessor update.
{-# INLINE toPath #-}

-- | Append a terminal 'PathSegment' onto a 'OsPath' to form a new 'OsPath'.
(</>) :: OsPath -> PathSegment -> OsPath
OsPath
a </> :: OsPath -> PathSegment -> OsPath
</> (PS OsPath
b) = OsPath
a OsPath -> OsPath -> OsPath
FP.</> OsPath
b
{-# INLINE (</>) #-}

-- | 'QuasiQuoter' for building 'PathSegment's.
--
-- Syntax:
--   ps ::= comp+
--   comp ::= '{' hsVar '}'
--         |  <any string excl. '.', '..', '~', not
--             including the system-local path sep.>
--   hsVar ::= <any string>
ps :: QuasiQuoter
ps :: QuasiQuoter
ps =
  QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
qPathSeg,
      quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall {m :: * -> *} {p} {a}. MonadFail m => p -> m a
unpermitted,
      quoteType :: String -> Q Type
quoteType = String -> Q Type
forall {m :: * -> *} {p} {a}. MonadFail m => p -> m a
unpermitted,
      quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
forall {m :: * -> *} {p} {a}. MonadFail m => p -> m a
unpermitted
    }
  where
    unpermitted :: p -> m a
unpermitted p
_ = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"quasiquoting paths only permitted for Haskell expressions"

-- | Internal: Quote a 'String' into a 'PathSegment'.
qPathSeg :: String -> Q Exp
qPathSeg :: String -> Q Exp
qPathSeg [] = String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty path"
qPathSeg String
s = do
  [PathSegmentComponent]
comps <- String -> Q [PathSegmentComponent]
forall (m :: * -> *).
MonadFail m =>
String -> m [PathSegmentComponent]
pathSegComps String
s
  case [PathSegmentComponent]
comps of
    [Str String
s'] -> do
      OsPath
p <- (String -> Q OsPath)
-> (OsPath -> Q OsPath) -> Either String OsPath -> Q OsPath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Q OsPath
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail OsPath -> Q OsPath
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String OsPath
validatePathSegStr String
s')
      [|PS p|]
    [PathSegmentComponent]
_ ->
      [|mkPathSegOrErr $ concat $([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (PathSegmentComponent -> Q Exp)
-> [PathSegmentComponent] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map PathSegmentComponent -> Q Exp
pathSegCompToQExp [PathSegmentComponent]
comps)|]

-- | Internal: Constructor for dynamic path splices.
mkPathSegOrErr :: String -> PathSegment
mkPathSegOrErr :: String -> PathSegment
mkPathSegOrErr = (String -> PathSegment)
-> (OsPath -> PathSegment) -> Either String OsPath -> PathSegment
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> PathSegment
forall a. HasCallStack => String -> a
error OsPath -> PathSegment
PS (Either String OsPath -> PathSegment)
-> (String -> Either String OsPath) -> String -> PathSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String OsPath
validatePathSegStr

-- | Internal: Check if a path segment (i.e., text before/between/after path
-- separators) is a valid segment. Here, validity being defined by being
-- non-empty, not containing the system-local path separator, nor being any of:
-- ., .., or ~.
validatePathSegStr :: String -> Either String OsPath
validatePathSegStr :: String -> Either String OsPath
validatePathSegStr [] = String -> Either String OsPath
forall a b. a -> Either a b
Left String
"empty path"
validatePathSegStr String
s
  | String
s String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".", String
"..", String
"~"] = String -> Either String OsPath
forall a b. a -> Either a b
Left (String -> Either String OsPath) -> String -> Either String OsPath
forall a b. (a -> b) -> a -> b
$ String
"invalid path segment: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
  | Char
pathSeparator Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
s = String -> Either String OsPath
forall a b. a -> Either a b
Left (String -> Either String OsPath) -> String -> Either String OsPath
forall a b. (a -> b) -> a -> b
$ String
"cannot create path segment with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
pathSeparator String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in the name."
  | Bool
otherwise = (SomeException -> Either String OsPath)
-> (OsPath -> Either String OsPath)
-> Either SomeException OsPath
-> Either String OsPath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String OsPath
forall a b. a -> Either a b
Left (String -> Either String OsPath)
-> (SomeException -> String)
-> SomeException
-> Either String OsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"invalid os path: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (SomeException -> String) -> SomeException -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) OsPath -> Either String OsPath
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either SomeException OsPath
forall (m :: * -> *). MonadThrow m => String -> m OsPath
encodeUtf String
s)

-- | Internal: A Haskell variable is just a string. We will make no effort to
-- audit them because Haskell supports unicode variable names.
type HaskellVar = String

-- | Internal: A path segment component is either a static 'String' or an
-- arbitrary Haskell expression.
data PathSegmentComponent
  = Str String
  | HsVar HaskellVar
  deriving (PathSegmentComponent -> PathSegmentComponent -> Bool
(PathSegmentComponent -> PathSegmentComponent -> Bool)
-> (PathSegmentComponent -> PathSegmentComponent -> Bool)
-> Eq PathSegmentComponent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PathSegmentComponent -> PathSegmentComponent -> Bool
== :: PathSegmentComponent -> PathSegmentComponent -> Bool
$c/= :: PathSegmentComponent -> PathSegmentComponent -> Bool
/= :: PathSegmentComponent -> PathSegmentComponent -> Bool
Eq, Int -> PathSegmentComponent -> String -> String
[PathSegmentComponent] -> String -> String
PathSegmentComponent -> String
(Int -> PathSegmentComponent -> String -> String)
-> (PathSegmentComponent -> String)
-> ([PathSegmentComponent] -> String -> String)
-> Show PathSegmentComponent
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> PathSegmentComponent -> String -> String
showsPrec :: Int -> PathSegmentComponent -> String -> String
$cshow :: PathSegmentComponent -> String
show :: PathSegmentComponent -> String
$cshowList :: [PathSegmentComponent] -> String -> String
showList :: [PathSegmentComponent] -> String -> String
Show)

-- | Internal: Lift a 'PathSegmentComponent' into a Template Haskell expression.
pathSegCompToQExp :: PathSegmentComponent -> Q Exp
pathSegCompToQExp :: PathSegmentComponent -> Q Exp
pathSegCompToQExp (Str String
s) = String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE String
s
pathSegCompToQExp (HsVar String
v) = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
v)

-- | Internal: Parse 'PathSegmentComponent's from a 'String' using sub-'String's
-- of the form `{x}` to indicate Haskell-level variables.
pathSegComps :: (MonadFail m) => String -> m [PathSegmentComponent]
pathSegComps :: forall (m :: * -> *).
MonadFail m =>
String -> m [PathSegmentComponent]
pathSegComps = String -> String -> m [PathSegmentComponent]
forall {f :: * -> *}.
MonadFail f =>
String -> String -> f [PathSegmentComponent]
go []
  where
    go :: String -> String -> f [PathSegmentComponent]
go String
acc [] = String -> f [PathSegmentComponent]
forall {f :: * -> *}.
Applicative f =>
String -> f [PathSegmentComponent]
finAcc String
acc
    go String
acc (Char
'\\' : Char
'{' : String
xs) = String -> String -> f [PathSegmentComponent]
go (Char
'{' Char -> String -> String
forall a. a -> [a] -> [a]
: String
acc) String
xs
    go String
acc (Char
'{' : String
xs) =
      case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'}') String
xs of
        (String
_, []) -> String -> f [PathSegmentComponent]
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"missing closing } in Haskell variable reference"
        (String
var, Char
_ : String
rest) -> do
          [PathSegmentComponent]
prefix <- String -> f [PathSegmentComponent]
forall {f :: * -> *}.
Applicative f =>
String -> f [PathSegmentComponent]
finAcc String
acc
          [PathSegmentComponent]
next <- String -> String -> f [PathSegmentComponent]
go [] String
rest
          [PathSegmentComponent] -> f [PathSegmentComponent]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PathSegmentComponent] -> f [PathSegmentComponent])
-> [PathSegmentComponent] -> f [PathSegmentComponent]
forall a b. (a -> b) -> a -> b
$ [PathSegmentComponent]
prefix [PathSegmentComponent]
-> [PathSegmentComponent] -> [PathSegmentComponent]
forall a. [a] -> [a] -> [a]
++ String -> PathSegmentComponent
HsVar String
var PathSegmentComponent
-> [PathSegmentComponent] -> [PathSegmentComponent]
forall a. a -> [a] -> [a]
: [PathSegmentComponent]
next
    go String
acc (Char
x : String
xs) = String -> String -> f [PathSegmentComponent]
go (Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
acc) String
xs

    finAcc :: String -> f [PathSegmentComponent]
finAcc [] = [PathSegmentComponent] -> f [PathSegmentComponent]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    finAcc String
as = [PathSegmentComponent] -> f [PathSegmentComponent]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String -> PathSegmentComponent
Str (String -> String
forall a. [a] -> [a]
reverse String
as)]