{-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskell #-}

module Drasil.FileHandling.FileLayout
  ( -- * File Layout
    FileLayout,
    name,

    -- ** Constructors
    file,
    exactFile,
    directory,

    -- ** Writing
    OverwritePolicy (..),
    writeFiles,
  )
where

import Data.Foldable qualified as F
import Data.Map.Strict qualified as M
import Data.Maybe (fromMaybe)
import Drasil.FileHandling.FilePath (PathSegment, toPath, (</>))
import Drasil.FileHandling.WriteFiles (Writeable (..), WritePolicy (..))
import System.Directory.OsPath (createDirectoryIfMissing, doesPathExist)
import System.OsPath (OsPath, decodeUtf)

-- | Container for laying out files in a single container for writing to disk.
-- Notes:
--
--     1. Polymorphic over the representation of the file contents. For
--        rendering, writeFiles requires the file content representation
--        satisfy 'Writeable'.
--     2. Only permits writing files/directories relative to a base path
--        provided. Does not permit `..`, `.`, nor `~` as directory names.
--     3. System-local path separator is forbidden from use in directory names.
--     4. Assumes host file system is case-sensitive (i.e., recognizes `A.txt`
--        and `a.txt` as different paths).
data FileLayout = FileLayout
  { -- | The /name/ of the file or directory.
    FileLayout -> PathSegment
pathSeg :: PathSegment,
    -- | The /contents/ of the file or directory.
    FileLayout -> FileTree
fileTree :: FileTree
  }

-- | Get the top-level name (a 'PathSegment') of a 'FileLayout'.
name :: FileLayout -> PathSegment
name :: FileLayout -> PathSegment
name = FileLayout -> PathSegment
pathSeg
{-# INLINE name #-}

-- | Internal: File layout tree.
data FileTree where
  -- | A directory with optionally many nested artifacts with 'PathSegment'
  -- (base name).
  Directory :: M.Map PathSegment FileTree -> FileTree
  -- | A file with content (of an unspecific type) and a file writing policy.
  File :: (Writeable doc) => doc -> WritePolicy -> FileTree

-- | Create a file 'FileLayout'. When written, this file will have a /trailing
-- newline always added/. Use 'exactFile' for building raw files. This is
-- primarily for synthetic files/generated ones.
file :: (Writeable doc) => PathSegment -> doc -> FileLayout
file :: forall doc. Writeable doc => PathSegment -> doc -> FileLayout
file PathSegment
fp doc
doc = PathSegment -> FileTree -> FileLayout
FileLayout PathSegment
fp (FileTree -> FileLayout) -> FileTree -> FileLayout
forall a b. (a -> b) -> a -> b
$ doc -> WritePolicy -> FileTree
forall doc. Writeable doc => doc -> WritePolicy -> FileTree
File doc
doc WritePolicy
AppendNewline
{-# INLINE file #-}

-- | Create a file 'FileLayout' containing the /exact/ file contents.
exactFile :: (Writeable doc) => PathSegment -> doc -> FileLayout
exactFile :: forall doc. Writeable doc => PathSegment -> doc -> FileLayout
exactFile PathSegment
fp doc
doc = PathSegment -> FileTree -> FileLayout
FileLayout PathSegment
fp (FileTree -> FileLayout) -> FileTree -> FileLayout
forall a b. (a -> b) -> a -> b
$ doc -> WritePolicy -> FileTree
forall doc. Writeable doc => doc -> WritePolicy -> FileTree
File doc
doc WritePolicy
ExactBytes
{-# INLINE exactFile #-}

-- | Create a directory 'FileLayout', optionally containing any number of nested
-- files.
directory :: (Foldable f) => PathSegment -> f FileLayout -> FileLayout
directory :: forall (f :: * -> *).
Foldable f =>
PathSegment -> f FileLayout -> FileLayout
directory PathSegment
fp = PathSegment -> FileTree -> FileLayout
FileLayout PathSegment
fp (FileTree -> FileLayout)
-> (f FileLayout -> FileTree) -> f FileLayout -> FileLayout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PathSegment FileTree -> FileTree
Directory (Map PathSegment FileTree -> FileTree)
-> (f FileLayout -> Map PathSegment FileTree)
-> f FileLayout
-> FileTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileLayout
 -> Map PathSegment FileTree -> Map PathSegment FileTree)
-> Map PathSegment FileTree
-> f FileLayout
-> Map PathSegment FileTree
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr' FileLayout -> Map PathSegment FileTree -> Map PathSegment FileTree
insert Map PathSegment FileTree
forall a. Monoid a => a
mempty
-- NOTE: Inlining here and in 'directory' allows for the held @f FileLayout@s to
-- never actually build 'FileLayout's!
{-# INLINE directory #-}

-- | Internal: Insert a 'FileLayout' into a 'Directory''s map.
insert :: FileLayout -> M.Map PathSegment FileTree -> M.Map PathSegment FileTree
insert :: FileLayout -> Map PathSegment FileTree -> Map PathSegment FileTree
insert FileLayout
v =
  (PathSegment -> FileTree -> FileTree -> FileTree)
-> PathSegment
-> FileTree
-> Map PathSegment FileTree
-> Map PathSegment FileTree
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWithKey
    (\PathSegment
dup FileTree
_ -> [Char] -> FileTree -> FileTree
forall a. HasCallStack => [Char] -> a
error ([Char] -> FileTree -> FileTree) -> [Char] -> FileTree -> FileTree
forall a b. (a -> b) -> a -> b
$ [Char]
"duplicate path: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"cannot decode" $([|decodeUtf $ toPath dup :: Maybe String|]))
    (FileLayout -> PathSegment
pathSeg FileLayout
v)
    (FileLayout -> FileTree
fileTree FileLayout
v)
{-# INLINE insert #-}

-- | When writing files or creating directories, is overwriting allowed?
data OverwritePolicy = OverwriteAllowed | NeverOverwrite

-- | Write a 'FileLayout' to disk about a base path.
--
-- If the given 'OverwritePolicy' is 'NeverOverwrite', this will fail if the
-- /top-level/ target path already exists. If it is 'OverwriteAllowed', it will
-- overwrite existing files.
--
-- Disclaimer: For case-insensitive file systems where different paths in the
-- layout might reference the same on-disk path, this code will fail.
writeFiles :: OverwritePolicy -> OsPath -> FileLayout -> IO ()
writeFiles :: OverwritePolicy -> OsPath -> FileLayout -> IO ()
writeFiles OverwritePolicy
OverwriteAllowed OsPath
basePath FileLayout
layout = OsPath -> FileLayout -> IO ()
writeFiles0 OsPath
basePath FileLayout
layout
writeFiles OverwritePolicy
NeverOverwrite OsPath
basePath FileLayout
layout = do
  Bool
exists <- OsPath -> IO Bool
doesPathExist OsPath
targetPath
  if Bool
exists
    then [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Path already exists: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ OsPath -> [Char]
forall a. Show a => a -> [Char]
show OsPath
targetPath
    else OsPath -> FileLayout -> IO ()
writeFiles0 OsPath
basePath FileLayout
layout
  where
    targetPath :: OsPath
targetPath = OsPath
basePath OsPath -> PathSegment -> OsPath
</> FileLayout -> PathSegment
pathSeg FileLayout
layout

-- Internal: `writeFiles` internal. It will create directories as needed and
-- blindly overwrite any existing files as designated in the layout.
writeFiles0 :: OsPath -> FileLayout -> IO ()
writeFiles0 :: OsPath -> FileLayout -> IO ()
writeFiles0 OsPath
basePath (FileLayout PathSegment
fname (File doc
content WritePolicy
policy)) =
  OsPath -> WritePolicy -> doc -> IO ()
forall doc. Writeable doc => OsPath -> WritePolicy -> doc -> IO ()
writeToFile (OsPath
basePath OsPath -> PathSegment -> OsPath
</> PathSegment
fname) WritePolicy
policy doc
content
writeFiles0 OsPath
basePath (FileLayout PathSegment
dname (Directory Map PathSegment FileTree
children)) = do
  let nextPath :: OsPath
nextPath = OsPath
basePath OsPath -> PathSegment -> OsPath
</> PathSegment
dname
  Bool -> OsPath -> IO ()
createDirectoryIfMissing Bool
False OsPath
nextPath
  ((PathSegment, FileTree) -> IO ())
-> [(PathSegment, FileTree)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
F.traverse_ (\(PathSegment
n, FileTree
c) -> OsPath -> FileLayout -> IO ()
writeFiles0 OsPath
nextPath (PathSegment -> FileTree -> FileLayout
FileLayout PathSegment
n FileTree
c)) (Map PathSegment FileTree -> [(PathSegment, FileTree)]
forall k a. Map k a -> [(k, a)]
M.toList Map PathSegment FileTree
children)
{-# INLINE writeFiles0 #-}