{-# LANGUAGE QuasiQuotes     #-}

module NixFreezeTree (main) where

import           BuilderDirs (BuilderDirs(..))
import           Config (Config(..))
import qualified Config as C
import           Control.Exception (catch)
import           Control.Monad (when)
import           Control.Monad.IO.Class (MonadIO(..))
import           Control.Monad.Trans.Reader (ReaderT(..), asks, local)
import           Data.Bool (bool)
import           Data.Functor (void)
import           Data.Functor.Identity (Identity(..))
import           Data.List (isSuffixOf)
import           Data.Text (Text)
import qualified Data.Text.IO as T
import           Data.Text.Prettyprint.Doc (defaultLayoutOptions, layoutPretty)
import           Data.Text.Prettyprint.Doc.Render.Text (renderStrict)
import           Nix.Pretty (prettyNix)
import           NixBuilder (mkBuildExpr)
import           Options.Applicative (execParser)
import           Path (Abs, Dir, Path, Rel, (</>))
import qualified Path as P
import qualified System.Directory as D
import           System.Directory.Tree
  ( AnchoredDirTree(..)
  , DirTree(..)
  , FileName
  )
import qualified System.Directory.Tree as DT
import           System.Exit (exitFailure)
import           System.IO (hPutStrLn, stderr)

buildExprTree :: Path Abs Dir -> IO (DirTree Text)
buildExprTree :: Path Abs Dir -> IO (DirTree Text)
buildExprTree Path Abs Dir
p = (ReaderT BuilderDirs IO (DirTree Text)
 -> BuilderDirs -> IO (DirTree Text))
-> BuilderDirs
-> ReaderT BuilderDirs IO (DirTree Text)
-> IO (DirTree Text)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT BuilderDirs IO (DirTree Text)
-> BuilderDirs -> IO (DirTree Text)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Path Abs Dir -> Path Rel Dir -> BuilderDirs
BuilderDirs Path Abs Dir
p [P.reldir|.|]) (ReaderT BuilderDirs IO (DirTree Text) -> IO (DirTree Text))
-> ReaderT BuilderDirs IO (DirTree Text) -> IO (DirTree Text)
forall a b. (a -> b) -> a -> b
$ do
  ([Char]
_ :/ DirTree [Char]
inDirTree) <- Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
P.toFilePath (Path Abs Dir -> [Char])
-> ReaderT BuilderDirs IO (Path Abs Dir)
-> ReaderT BuilderDirs IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BuilderDirs -> Path Abs Dir)
-> ReaderT BuilderDirs IO (Path Abs Dir)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks BuilderDirs -> Path Abs Dir
_root ReaderT BuilderDirs IO [Char]
-> ([Char] -> ReaderT BuilderDirs IO (AnchoredDirTree [Char]))
-> ReaderT BuilderDirs IO (AnchoredDirTree [Char])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (AnchoredDirTree [Char])
-> ReaderT BuilderDirs IO (AnchoredDirTree [Char])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (AnchoredDirTree [Char])
 -> ReaderT BuilderDirs IO (AnchoredDirTree [Char]))
-> ([Char] -> IO (AnchoredDirTree [Char]))
-> [Char]
-> ReaderT BuilderDirs IO (AnchoredDirTree [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO (AnchoredDirTree [Char])
DT.build

  case DirTree [Char]
inDirTree of
    Dir [Char]
_ [DirTree [Char]]
fs -> ([Char], [DirTree [Char]]) -> ReaderT BuilderDirs IO (DirTree Text)
forall a.
([Char], [DirTree a]) -> ReaderT BuilderDirs IO (DirTree Text)
go ([Char]
".", [DirTree [Char]]
fs) -- Use "." to avoid the root in output paths
    DirTree [Char]
_ -> [Char] -> ReaderT BuilderDirs IO (DirTree Text)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Should never happen"

  where
    -- Walk the directory tree, building the @default.nix@ files, and
    -- keeping an absolute path to where we are in the ReaderT
    -- context.
    go :: (FileName, [DirTree a]) -> ReaderT BuilderDirs IO (DirTree Text)
    go :: ([Char], [DirTree a]) -> ReaderT BuilderDirs IO (DirTree Text)
go ([Char]
dirName, [DirTree a]
dirFiles) = do
      Path Rel Dir
relDirName <- [Char] -> ReaderT BuilderDirs IO (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
P.parseRelDir [Char]
dirName
      (BuilderDirs -> BuilderDirs)
-> ReaderT BuilderDirs IO (DirTree Text)
-> ReaderT BuilderDirs IO (DirTree Text)
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (\BuilderDirs
b -> BuilderDirs
b { _subdir :: Path Rel Dir
_subdir = BuilderDirs -> Path Rel Dir
_subdir BuilderDirs
b Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirName }) (ReaderT BuilderDirs IO (DirTree Text)
 -> ReaderT BuilderDirs IO (DirTree Text))
-> ReaderT BuilderDirs IO (DirTree Text)
-> ReaderT BuilderDirs IO (DirTree Text)
forall a b. (a -> b) -> a -> b
$ do
        [Path Rel File]
files <- ([Char] -> ReaderT BuilderDirs IO (Path Rel File))
-> [[Char]] -> ReaderT BuilderDirs IO [Path Rel File]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse [Char] -> ReaderT BuilderDirs IO (Path Rel File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
P.parseRelFile [ [Char]
f | File [Char]
f a
_ <- [DirTree a]
dirFiles ]
        [Path Rel Dir]
dirs <- ([Char] -> ReaderT BuilderDirs IO (Path Rel Dir))
-> [[Char]] -> ReaderT BuilderDirs IO [Path Rel Dir]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse [Char] -> ReaderT BuilderDirs IO (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
P.parseRelDir [ [Char]
d | Dir [Char]
d [DirTree a]
_ <- [DirTree a]
dirFiles ]

        Text
defaultNix <- NExpr -> Text
renderNix (NExpr -> Text)
-> ReaderT BuilderDirs IO NExpr -> ReaderT BuilderDirs IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Path Rel File] -> [Path Rel Dir] -> ReaderT BuilderDirs IO NExpr
mkBuildExpr [Path Rel File]
files [Path Rel Dir]
dirs
        [DirTree Text]
subdirs <- (([Char], [DirTree a]) -> ReaderT BuilderDirs IO (DirTree Text))
-> [([Char], [DirTree a])] -> ReaderT BuilderDirs IO [DirTree Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Char], [DirTree a]) -> ReaderT BuilderDirs IO (DirTree Text)
forall a.
([Char], [DirTree a]) -> ReaderT BuilderDirs IO (DirTree Text)
go [ ([Char]
d, [DirTree a]
fs) | Dir [Char]
d [DirTree a]
fs <- [DirTree a]
dirFiles ]
        DirTree Text -> ReaderT BuilderDirs IO (DirTree Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DirTree Text -> ReaderT BuilderDirs IO (DirTree Text))
-> ([DirTree Text] -> DirTree Text)
-> [DirTree Text]
-> ReaderT BuilderDirs IO (DirTree Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [DirTree Text] -> DirTree Text
forall a. [Char] -> [DirTree a] -> DirTree a
Dir [Char]
dirName ([DirTree Text] -> ReaderT BuilderDirs IO (DirTree Text))
-> [DirTree Text] -> ReaderT BuilderDirs IO (DirTree Text)
forall a b. (a -> b) -> a -> b
$ [Char] -> Text -> DirTree Text
forall a. [Char] -> a -> DirTree a
File [Char]
"default.nix" Text
defaultNixDirTree Text -> [DirTree Text] -> [DirTree Text]
forall a. a -> [a] -> [a]
:[DirTree Text]
subdirs

    renderNix :: NExpr -> Text
renderNix = SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (SimpleDocStream Any -> Text)
-> (NExpr -> SimpleDocStream Any) -> NExpr -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (Doc Any -> SimpleDocStream Any)
-> (NExpr -> Doc Any) -> NExpr -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NExpr -> Doc Any
forall ann. NExpr -> Doc ann
prettyNix

data DirConstraint = MustNameDirectory | MustNameDirectoryIfExists

toAbsDir :: DirConstraint -> FilePath -> IO (Path Abs Dir)
toAbsDir :: DirConstraint -> [Char] -> IO (Path Abs Dir)
toAbsDir DirConstraint
constraint [Char]
d = IO (Path Abs Dir) -> IO (Path Abs Dir)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Abs Dir) -> IO (Path Abs Dir))
-> IO (Path Abs Dir) -> IO (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ do
  Path Abs Dir
absD <- ([Char] -> IO [Char]
D.canonicalizePath [Char]
d IO [Char] -> ([Char] -> IO (Path Abs Dir)) -> IO (Path Abs Dir)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> IO (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs Dir)
P.parseAbsDir) IO (Path Abs Dir)
-> (PathException -> IO (Path Abs Dir)) -> IO (Path Abs Dir)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
    \(P.InvalidAbsDir [Char]
_) -> [Char] -> IO (Path Abs Dir)
forall (m :: * -> *) a. MonadIO m => [Char] -> m a
dieD [Char]
"does not name a directory"

  Bool
isDir <- [Char] -> IO Bool
D.doesDirectoryExist [Char]
d
  if Bool
isDir
    then Path Abs Dir -> IO (Path Abs Dir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
absD
    else case DirConstraint
constraint of
           DirConstraint
MustNameDirectory -> [Char] -> IO (Path Abs Dir)
forall (m :: * -> *) a. MonadIO m => [Char] -> m a
dieD [Char]
"does not name a directory"
           DirConstraint
MustNameDirectoryIfExists -> [Char] -> IO Bool
D.doesPathExist [Char]
d IO Bool -> (Bool -> IO (Path Abs Dir)) -> IO (Path Abs Dir)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
             IO (Path Abs Dir) -> IO (Path Abs Dir) -> Bool -> IO (Path Abs Dir)
forall a. a -> a -> Bool -> a
bool (Path Abs Dir -> IO (Path Abs Dir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
absD) ([Char] -> IO (Path Abs Dir)
forall (m :: * -> *) a. MonadIO m => [Char] -> m a
dieD [Char]
"names something other than a directory")

  where
    dieD :: [Char] -> m a
dieD [Char]
m = [Char] -> m a
forall (m :: * -> *) a. MonadIO m => [Char] -> m a
die ([Char] -> m a) -> [Char] -> m a
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
d [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
m

writeNixTree :: Config Identity -> IO ()
writeNixTree :: Config Identity -> IO ()
writeNixTree Config Identity
cfg = do
  Path Abs Dir
outRoot <- DirConstraint -> [Char] -> IO (Path Abs Dir)
toAbsDir DirConstraint
MustNameDirectoryIfExists ([Char] -> IO (Path Abs Dir)) -> [Char] -> IO (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ (Config Identity -> Identity [Char]) -> [Char]
forall a. (Config Identity -> Identity a) -> a
get Config Identity -> Identity [Char]
forall (f :: * -> *). Config f -> f [Char]
_outputRoot
  Path Abs Dir
inDir <- DirConstraint -> [Char] -> IO (Path Abs Dir)
toAbsDir DirConstraint
MustNameDirectory ([Char] -> IO (Path Abs Dir)) -> [Char] -> IO (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ (Config Identity -> Identity [Char]) -> [Char]
forall a. (Config Identity -> Identity a) -> a
get Config Identity -> Identity [Char]
forall (f :: * -> *). Config f -> f [Char]
_inDir

  let outRootPath :: [Char]
outRootPath = Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
P.toFilePath Path Abs Dir
outRoot
  outPathTree :: AnchoredDirTree [Char]
outPathTree@([Char]
_ :/ DirTree [Char]
outFiles) <- IO (AnchoredDirTree [Char]) -> IO (AnchoredDirTree [Char])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (AnchoredDirTree [Char]) -> IO (AnchoredDirTree [Char]))
-> IO (AnchoredDirTree [Char]) -> IO (AnchoredDirTree [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> IO (AnchoredDirTree [Char])
DT.build [Char]
outRootPath

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DirTree [Char] -> Bool
forall a. DirTree a -> Bool
defaultNixExists DirTree [Char]
outFiles) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    if (Config Identity -> Identity Bool) -> Bool
forall a. (Config Identity -> Identity a) -> a
get Config Identity -> Identity Bool
forall (f :: * -> *). Config f -> f Bool
_force
    then do
      [Char] -> IO ()
vPutStrLn [Char]
"a default.nix exists somewhere in the output tree, cleaning"
      IO (AnchoredDirTree ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (AnchoredDirTree ()) -> IO ())
-> (IO (AnchoredDirTree ()) -> IO (AnchoredDirTree ()))
-> IO (AnchoredDirTree ())
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (AnchoredDirTree ()) -> IO (AnchoredDirTree ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (AnchoredDirTree ()) -> IO ())
-> IO (AnchoredDirTree ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (([Char] -> [Char] -> IO ())
 -> AnchoredDirTree [Char] -> IO (AnchoredDirTree ()))
-> AnchoredDirTree [Char]
-> ([Char] -> [Char] -> IO ())
-> IO (AnchoredDirTree ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([Char] -> [Char] -> IO ())
-> AnchoredDirTree [Char] -> IO (AnchoredDirTree ())
forall a b.
([Char] -> a -> IO b)
-> AnchoredDirTree a -> IO (AnchoredDirTree b)
DT.writeDirectoryWith AnchoredDirTree [Char]
outPathTree (([Char] -> [Char] -> IO ()) -> IO (AnchoredDirTree ()))
-> ([Char] -> [Char] -> IO ()) -> IO (AnchoredDirTree ())
forall a b. (a -> b) -> a -> b
$ \[Char]
fp [Char]
_ ->
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Char]
"default.nix" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
fp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          [Char] -> IO ()
vPutStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"deleting " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
fp
          [Char] -> IO ()
D.removePathForcibly [Char]
fp
    else [Char] -> IO ()
forall (m :: * -> *) a. MonadIO m => [Char] -> m a
die [Char]
"a default.nix exists somewhere in the output tree, cannot proceed"

  DirTree Text
outTree <- Path Abs Dir -> IO (DirTree Text)
buildExprTree Path Abs Dir
inDir
  IO (AnchoredDirTree ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (AnchoredDirTree ()) -> IO ())
-> IO (AnchoredDirTree ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (([Char] -> Text -> IO ())
 -> AnchoredDirTree Text -> IO (AnchoredDirTree ()))
-> AnchoredDirTree Text
-> ([Char] -> Text -> IO ())
-> IO (AnchoredDirTree ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([Char] -> Text -> IO ())
-> AnchoredDirTree Text -> IO (AnchoredDirTree ())
forall a b.
([Char] -> a -> IO b)
-> AnchoredDirTree a -> IO (AnchoredDirTree b)
DT.writeDirectoryWith ([Char]
outRootPath [Char] -> DirTree Text -> AnchoredDirTree Text
forall a. [Char] -> DirTree a -> AnchoredDirTree a
:/ DirTree Text
outTree) (([Char] -> Text -> IO ()) -> IO (AnchoredDirTree ()))
-> ([Char] -> Text -> IO ()) -> IO (AnchoredDirTree ())
forall a b. (a -> b) -> a -> b
$ \[Char]
fp Text
t -> do
    [Char] -> IO ()
vPutStrLn ([Char] -> IO ()) -> ([Char] -> [Char]) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"writing " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>) ([Char] -> IO ()) -> IO [Char] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> IO [Char]
D.canonicalizePath [Char]
fp
    [Char] -> Text -> IO ()
T.writeFile [Char]
fp Text
t

  where
    get :: (Config Identity -> Identity a) -> a
get Config Identity -> Identity a
f = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> Identity a -> a
forall a b. (a -> b) -> a -> b
$ Config Identity -> Identity a
f Config Identity
cfg

    defaultNixExists :: DirTree a -> Bool
defaultNixExists (File [Char]
n a
_) = [Char]
n [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"default.nix"
    defaultNixExists (Dir [Char]
_ [DirTree a]
cs) = (DirTree a -> Bool) -> [DirTree a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any DirTree a -> Bool
defaultNixExists [DirTree a]
cs
    defaultNixExists Failed{} = Bool
False

    vPutStrLn :: [Char] -> IO ()
vPutStrLn [Char]
msg = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Config Identity -> Identity Bool) -> Bool
forall a. (Config Identity -> Identity a) -> a
get Config Identity -> Identity Bool
forall (f :: * -> *). Config f -> f Bool
_verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
msg

main :: IO ()
main :: IO ()
main = Config Maybe -> Maybe (Config Identity)
C.checkConfig (Config Maybe -> Maybe (Config Identity))
-> IO (Config Maybe) -> IO (Maybe (Config Identity))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserInfo (Config Maybe) -> IO (Config Maybe)
forall a. ParserInfo a -> IO a
execParser ParserInfo (Config Maybe)
C.configParserInfo IO (Maybe (Config Identity))
-> (Maybe (Config Identity) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  IO ()
-> (Config Identity -> IO ()) -> Maybe (Config Identity) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> IO ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Should be impossible") Config Identity -> IO ()
writeNixTree

die :: MonadIO m => String -> m a
die :: [Char] -> m a
die [Char]
msg = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char]
"FATAL: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
msg) IO () -> IO a -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO a
forall a. IO a
exitFailure