{-# LANGUAGE TemplateHaskell #-}

module Drasil.Build.Artifacts.FileLayout
  ( -- * File Layout
    FileLayout,

    -- ** Constructors
    file,
    directory,

    -- ** Writing
    writeFiles,
  )
where

import Data.Foldable qualified as F
import Data.Map.Strict qualified as M
import Data.Maybe (fromMaybe)
import Drasil.Build.Artifacts.FilePath (PathSegment, toPath, (</>))
import Drasil.Build.Artifacts.Render (Renderable (..))
import System.Directory.OsPath (createDirectory, 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 'Renderable'.
--     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 doc = FileLayout
  { -- | The /name/ of the file or directory.
    forall doc. FileLayout doc -> PathSegment
pathSeg :: PathSegment,
    -- | The /contents/ of the file or directory.
    forall doc. FileLayout doc -> FileTree doc
fileTree :: FileTree doc
  }
  deriving ((forall a b. (a -> b) -> FileLayout a -> FileLayout b)
-> (forall a b. a -> FileLayout b -> FileLayout a)
-> Functor FileLayout
forall a b. a -> FileLayout b -> FileLayout a
forall a b. (a -> b) -> FileLayout a -> FileLayout b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> FileLayout a -> FileLayout b
fmap :: forall a b. (a -> b) -> FileLayout a -> FileLayout b
$c<$ :: forall a b. a -> FileLayout b -> FileLayout a
<$ :: forall a b. a -> FileLayout b -> FileLayout a
Functor)

-- | Internal: File layout tree.
data FileTree doc
  = -- | A directory with optionally many nested artifacts.
    Directory (M.Map PathSegment (FileTree doc))
  | -- | A file with content (of an unspecific type).
    File doc
  deriving ((forall a b. (a -> b) -> FileTree a -> FileTree b)
-> (forall a b. a -> FileTree b -> FileTree a) -> Functor FileTree
forall a b. a -> FileTree b -> FileTree a
forall a b. (a -> b) -> FileTree a -> FileTree b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> FileTree a -> FileTree b
fmap :: forall a b. (a -> b) -> FileTree a -> FileTree b
$c<$ :: forall a b. a -> FileTree b -> FileTree a
<$ :: forall a b. a -> FileTree b -> FileTree a
Functor)

-- | Create a file 'FileLayout'.
file :: PathSegment -> doc -> FileLayout doc
file :: forall doc. PathSegment -> doc -> FileLayout doc
file PathSegment
fp = PathSegment -> FileTree doc -> FileLayout doc
forall doc. PathSegment -> FileTree doc -> FileLayout doc
FileLayout PathSegment
fp (FileTree doc -> FileLayout doc)
-> (doc -> FileTree doc) -> doc -> FileLayout doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. doc -> FileTree doc
forall doc. doc -> FileTree doc
File
{-# INLINE file #-}

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

-- | Internal: Insert a 'FileLayout' into a 'Directory''s map.
insert :: FileLayout d -> M.Map PathSegment (FileTree d) -> M.Map PathSegment (FileTree d)
insert :: forall d.
FileLayout d
-> Map PathSegment (FileTree d) -> Map PathSegment (FileTree d)
insert FileLayout d
v =
  (PathSegment -> FileTree d -> FileTree d -> FileTree d)
-> PathSegment
-> FileTree d
-> Map PathSegment (FileTree d)
-> Map PathSegment (FileTree d)
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWithKey
    (\PathSegment
dup FileTree d
_ -> [Char] -> FileTree d -> FileTree d
forall a. HasCallStack => [Char] -> a
error ([Char] -> FileTree d -> FileTree d)
-> [Char] -> FileTree d -> FileTree d
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 d -> PathSegment
forall doc. FileLayout doc -> PathSegment
pathSeg FileLayout d
v)
    (FileLayout d -> FileTree d
forall doc. FileLayout doc -> FileTree doc
fileTree FileLayout d
v)
{-# INLINE insert #-}

-- | Write a 'FileLayout' to disk about a base path.
--
-- Disclaimer: Fails if files/directories already exist. This is problematic for
-- case-insensitive file systems where different paths reference the same.
writeFiles :: (Renderable doc) => OsPath -> FileLayout doc -> IO ()
writeFiles :: forall doc. Renderable doc => OsPath -> FileLayout doc -> IO ()
writeFiles OsPath
basePath FileLayout doc
layout = do
  let targetPath :: OsPath
targetPath = OsPath
basePath OsPath -> PathSegment -> OsPath
</> FileLayout doc -> PathSegment
forall doc. FileLayout doc -> PathSegment
pathSeg FileLayout doc
layout
  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 doc -> IO ()
forall doc. Renderable doc => OsPath -> FileLayout doc -> IO ()
go OsPath
basePath FileLayout doc
layout
  where
    go :: OsPath -> FileLayout doc -> IO ()
go OsPath
currentPath (FileLayout PathSegment
fname (File doc
content)) =
      OsPath -> doc -> IO ()
forall doc. Renderable doc => OsPath -> doc -> IO ()
renderToFile (OsPath
currentPath OsPath -> PathSegment -> OsPath
</> PathSegment
fname) doc
content
    go OsPath
currentPath (FileLayout PathSegment
dname (Directory Map PathSegment (FileTree doc)
children)) = do
      let nextPath :: OsPath
nextPath = OsPath
currentPath OsPath -> PathSegment -> OsPath
</> PathSegment
dname
      OsPath -> IO ()
createDirectory OsPath
nextPath
      ((PathSegment, FileTree doc) -> IO ())
-> [(PathSegment, FileTree doc)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
F.traverse_ (\(PathSegment
n, FileTree doc
c) -> OsPath -> FileLayout doc -> IO ()
go OsPath
nextPath (PathSegment -> FileTree doc -> FileLayout doc
forall doc. PathSegment -> FileTree doc -> FileLayout doc
FileLayout PathSegment
n FileTree doc
c)) (Map PathSegment (FileTree doc) -> [(PathSegment, FileTree doc)]
forall k a. Map k a -> [(k, a)]
M.toList Map PathSegment (FileTree doc)
children)