{-# 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, (</>))
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 p = flip runReaderT (BuilderDirs p [P.reldir|.|]) $ do
  (_ :/ inDirTree) <- P.toFilePath <$> asks _root >>= liftIO . DT.build

  case inDirTree of
    Dir _ fs -> go (".", fs) -- Use "." to avoid the root in output paths
    _ -> fail "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 (dirName, dirFiles) = do
      relDirName <- P.parseRelDir dirName
      local (\b -> b { _subdir = _subdir b </> relDirName }) $ do
        files <- traverse P.parseRelFile [ f | File f _ <- dirFiles ]
        dirs <- traverse P.parseRelDir [ d | Dir d _ <- dirFiles ]

        defaultNix <- renderNix <$> mkBuildExpr files dirs
        subdirs <- traverse go [ (d, fs) | Dir d fs <- dirFiles ]
        pure . Dir dirName $ File "default.nix" defaultNix:subdirs

    renderNix = renderStrict . layoutPretty defaultLayoutOptions . prettyNix

data DirConstraint = MustNameDirectory | MustNameDirectoryIfExists

toAbsDir :: DirConstraint -> FilePath -> IO (Path Abs Dir)
toAbsDir constraint d = liftIO $ do
  absD <- (D.canonicalizePath d >>= P.parseAbsDir) `catch`
    \(P.InvalidAbsDir _) -> dieD "does not name a directory"

  isDir <- D.doesDirectoryExist d
  if isDir
    then pure absD
    else case constraint of
           MustNameDirectory -> dieD "does not name a directory"
           MustNameDirectoryIfExists -> D.doesPathExist d >>=
             bool (pure absD) (dieD "names something other than a directory")

  where
    dieD m = die $ show d <> " " <> m

writeNixTree :: Config Identity -> IO ()
writeNixTree cfg = do
  outRoot <- toAbsDir MustNameDirectoryIfExists $ get _outputRoot
  inDir <- toAbsDir MustNameDirectory $ get _inDir

  let outRootPath = P.toFilePath outRoot
  outPathTree@(_ :/ outFiles) <- liftIO $ DT.build outRootPath

  when (defaultNixExists outFiles) $
    if get _force
    then do
      vPutStrLn "a default.nix exists somewhere in the output tree, cleaning"
      void . liftIO $ flip DT.writeDirectoryWith outPathTree $ \fp _ ->
        when ("default.nix" `isSuffixOf` fp) $ do
          vPutStrLn $ "deleting " <> fp
          D.removePathForcibly fp
    else die "a default.nix exists somewhere in the output tree, cannot proceed"

  outTree <- buildExprTree inDir
  void $ flip DT.writeDirectoryWith (outRootPath :/ outTree) $ \fp t -> do
    vPutStrLn . ("writing " <>) =<< D.canonicalizePath fp
    T.writeFile fp t

  where
    get f = runIdentity $ f cfg

    defaultNixExists (File n _) = n == "default.nix"
    defaultNixExists (Dir _ cs) = any defaultNixExists cs
    defaultNixExists Failed{} = False

    vPutStrLn msg = when (get _verbose) $ putStrLn msg

main :: IO ()
main = C.checkConfig <$> execParser C.configParserInfo >>=
  maybe (fail "Should be impossible") writeNixTree

die :: MonadIO m => String -> m a
die msg = liftIO $ hPutStrLn stderr ("FATAL: " <> msg) *> exitFailure