content: {-# LANGUAGE OverloadedStrings #-}
  module ADL.Compiler.Utils(
    OutputArgs(..),
    FileWriter,
    writeOutputFile,
    withManifest,
    headNote,
    tailNote,
    )where
  
  import Prelude hiding (catch)
  import ADL.Compiler.EIO
  import Control.Concurrent.STM
  import Control.Monad
  import Control.Monad.Trans
  import Control.Exception
  import System.FilePath
  import System.Directory(doesFileExist, createDirectoryIfMissing, removeFile)
  import Data.List(sort)
  import qualified Data.ByteString.Lazy as LBS
  import qualified Data.ByteString as BS
  import qualified Data.Text as T
  import qualified Data.Text.IO as T
  import qualified Data.Text.Encoding as T
  import qualified Data.Set as Set
  import GHC.Stack (HasCallStack)
  
  data OutputArgs = OutputArgs {
    oa_log :: String -> IO (),
    oa_noOverwrite :: Bool,
    oa_outputPath :: FilePath,
    oa_manifestFile :: Maybe FilePath
    }
  
  type FileWriter = FilePath -> LBS.ByteString -> IO ()
    
  writeOutputFile :: OutputArgs -> FileWriter
  writeOutputFile (oa@OutputArgs{oa_noOverwrite=False}) fpath0 t = do
    let fpath = oa_outputPath oa </> fpath0
    oa_log oa ("writing " ++ fpath ++ "...")
    createDirectoryIfMissing True (takeDirectory fpath)
    LBS.writeFile fpath t
  writeOutputFile (oa@OutputArgs{oa_noOverwrite=True}) fpath0 t = do
    let fpath = oa_outputPath oa </> fpath0
    t0 <- catch (BS.readFile fpath) ((\_ -> return BS.empty) :: IOError -> IO BS.ByteString)
    if t /= LBS.fromStrict t0
       then do
         oa_log oa ("writing " ++ fpath ++ ".")
         createDirectoryIfMissing True (takeDirectory fpath)
         LBS.writeFile fpath t
      else
         oa_log oa ("leaving " ++ fpath ++ " unchanged.")
  
  data WriterWithManifest = WriterWithManifest {
   wwm_writeFile :: FileWriter,
   wwm_writeManifest :: IO ()
  }
  
  writerWithManifest :: OutputArgs -> IO WriterWithManifest
  writerWithManifest oa = do
    case oa_manifestFile oa of
      Nothing -> return (WriterWithManifest (writeOutputFile oa) (return ()))
      Just mfile -> do
        newFilesVar <- atomically (newTVar Set.empty)
        return WriterWithManifest{
          wwm_writeFile=writeFile newFilesVar,
          wwm_writeManifest=writeManifest mfile newFilesVar
        }
    where
      writeFile filesVar path content = do
        atomically $ do
          modifyTVar filesVar (Set.insert path)
        writeOutputFile oa path content
  
      writeManifest manifestPath filesVar = do
        -- Determine preexisting files from old manifest
        exists <- doesFileExist manifestPath
        existingFiles <-
          if exists then readManifest manifestPath
                    else return Set.empty
        newFiles <- atomically (readTVar filesVar)
  
        -- Write the new manifest
        let header = "# manifest @" <> "generated by the adl compiler"
            manifest = T.unlines (header : sort (map T.pack (Set.toList newFiles)))
        T.writeFile manifestPath manifest
  
        -- Remove files that no longer exist
        let oldFiles = Set.difference existingFiles newFiles
        forM_ oldFiles $ \file -> do
          let opath = oa_outputPath oa </> file
          exists <- doesFileExist opath
          when exists $ do
            oa_log oa ("Removing defunct file " <> file <> ".")
            removeFile opath
  
      readManifest path = do
        content <- T.readFile path
        let files =
              ( Set.fromList
              . map T.unpack
              . filter (not . T.isPrefixOf "#")
              . map T.strip
              . T.lines
              ) content
        return files
  
  withManifest:: OutputArgs -> (FileWriter -> EIO e a) -> EIO e a
  withManifest oa ma = do
    wwm <- liftIO $ writerWithManifest oa
    a <- ma (wwm_writeFile wwm)
    liftIO $ wwm_writeManifest wwm
    return a
  
  
  headNote:: HasCallStack => String -> [a] -> a
  headNote _ (a:as) = a
  headNote err _ = error err
  
  tailNote :: HasCallStack => String -> [a] -> [a]
  tailNote  _ (a:as) = as
  tailNote  err _ = error err
  
  