{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}

module Drasil.Generator.WriteSystem
  ( drasilMakefileReqOpts,
    concretizeAndWrite,
    setSystemLocale,
    WriteOptions (..),
    DebugDataPolicy (..)
  )
where

import Control.Lens ((^.))
import GHC.IO.Encoding (setLocaleEncoding, utf8, TextEncoding)
import System.Environment (lookupEnv)

import Drasil.FileHandling (OverwritePolicy (..), PathSegment, directory, localPath, ps, writeFiles, FileLayout)
import Drasil.System (HasSystemMeta (..), ToFiles (..))
import Language.Drasil (CommonIdea (abrv))

import Drasil.Generator.ChunkDump (buildDebuggingFiles)

-- | Internal: Set system locale encoding to UTF-8.
setSystemLocale :: IO ()
setSystemLocale :: IO ()
setSystemLocale = TextEncoding -> IO ()
setLocaleEncoding TextEncoding
utf8

{-# DEPRECATED setSystemLocale
  "Use `concretizeAndWrite` instead of directly setting system locale before file-writing." #-}

-- | When should debugging data be written?
data DebugDataPolicy
  = -- | Always.
    AlwaysWrite
      -- | The name of the directory to carry all debugging data files.
      PathSegment
  | -- | Only write debugging data if the following environment variable ('String') is non-empty.
    CheckEnvVar
      -- | The environment variable name.
      String
      -- | The name of the directory to carry all debugging data files.
      PathSegment
  | -- | Never.
    NeverWrite

-- | Configuration options for writing a repository of software artifacts.
data WriteOptions = WO
  { -- | Are we allowed to overwrite files or not?
    WriteOptions -> OverwritePolicy
overwritePolicy :: OverwritePolicy,
    -- | What is the name of the subfolder to be created?
    WriteOptions -> forall sys. HasSystemMeta sys => sys -> PathSegment
localDirName :: forall sys. HasSystemMeta sys => sys -> PathSegment,
    -- | What is the expected text encoding scheme?
    WriteOptions -> TextEncoding
textEncoding :: TextEncoding,
    -- | Should debugging data be written?
    WriteOptions -> DebugDataPolicy
debugDataPolicy :: DebugDataPolicy
  }

-- | These are the default file-writing 'WriteOptions' required for Drasil (the
-- main Makefile will not play well otherwise).
--
-- Options:
--
-- 1. 'overwritePolicy': Always allow file-overwriting.
-- 2. 'dirName': The example's abbreviation.
-- 3. 'textEncoding': UTF-8.
-- 4. 'debugDataPolicy': Dependant on `DEBUG_ENV` environment variable being
--    set, writing to a nested `.drasil` folder.
drasilMakefileReqOpts :: WriteOptions
drasilMakefileReqOpts :: WriteOptions
drasilMakefileReqOpts =
  OverwritePolicy
-> (forall sys. HasSystemMeta sys => sys -> PathSegment)
-> TextEncoding
-> DebugDataPolicy
-> WriteOptions
WO OverwritePolicy
OverwriteAllowed sys -> PathSegment
forall sys. HasSystemMeta sys => sys -> PathSegment
dirName TextEncoding
utf8 (String -> PathSegment -> DebugDataPolicy
CheckEnvVar String
"DEBUG_ENV" [ps|.drasil|])
  where
    dirName :: p -> PathSegment
dirName p
sys = let ab :: String
ab = CI -> String
forall c. CommonIdea c => c -> String
abrv (CI -> String) -> CI -> String
forall a b. (a -> b) -> a -> b
$ p
sys p -> Getting CI p CI -> CI
forall s a. s -> Getting a s a -> a
^. (SystemMeta -> Const CI SystemMeta) -> p -> Const CI p
forall c. HasSystemMeta c => Lens' c SystemMeta
Lens' p SystemMeta
systemMeta ((SystemMeta -> Const CI SystemMeta) -> p -> Const CI p)
-> ((CI -> Const CI CI) -> SystemMeta -> Const CI SystemMeta)
-> Getting CI p CI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CI -> Const CI CI) -> SystemMeta -> Const CI SystemMeta
forall c. HasSystemMeta c => Lens' c CI
Lens' SystemMeta CI
sysName
                   in [ps|{ab}|]

-- FIXME: Both `abrv` usage and `sysName` usage above is dubious. We need to
-- replace this field with something better, such as project name and project
-- shortname (repo name).

-- | Internal: 'DebugDataPolicy' eliminator.
debugData :: HasSystemMeta sys => sys -> DebugDataPolicy -> IO (Maybe FileLayout)
debugData :: forall sys.
HasSystemMeta sys =>
sys -> DebugDataPolicy -> IO (Maybe FileLayout)
debugData sys
_ DebugDataPolicy
NeverWrite = Maybe FileLayout -> IO (Maybe FileLayout)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FileLayout
forall a. Maybe a
Nothing
debugData sys
sys (AlwaysWrite PathSegment
dirName) =
  Maybe FileLayout -> IO (Maybe FileLayout)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FileLayout -> IO (Maybe FileLayout))
-> Maybe FileLayout -> IO (Maybe FileLayout)
forall a b. (a -> b) -> a -> b
$ FileLayout -> Maybe FileLayout
forall a. a -> Maybe a
Just (FileLayout -> Maybe FileLayout) -> FileLayout -> Maybe FileLayout
forall a b. (a -> b) -> a -> b
$ PathSegment -> [FileLayout] -> FileLayout
forall (f :: * -> *).
Foldable f =>
PathSegment -> f FileLayout -> FileLayout
directory PathSegment
dirName ([FileLayout] -> FileLayout) -> [FileLayout] -> FileLayout
forall a b. (a -> b) -> a -> b
$ sys -> [FileLayout]
forall sys. HasSystemMeta sys => sys -> [FileLayout]
buildDebuggingFiles sys
sys
debugData sys
sys (CheckEnvVar String
envVar PathSegment
dirName) = do
  Maybe String
maybeDebugging <- String -> IO (Maybe String)
lookupEnv String
envVar
  case Maybe String
maybeDebugging of
    (Just String
v) | Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
v)
      -> Maybe FileLayout -> IO (Maybe FileLayout)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FileLayout -> IO (Maybe FileLayout))
-> Maybe FileLayout -> IO (Maybe FileLayout)
forall a b. (a -> b) -> a -> b
$ FileLayout -> Maybe FileLayout
forall a. a -> Maybe a
Just (FileLayout -> Maybe FileLayout) -> FileLayout -> Maybe FileLayout
forall a b. (a -> b) -> a -> b
$ PathSegment -> [FileLayout] -> FileLayout
forall (f :: * -> *).
Foldable f =>
PathSegment -> f FileLayout -> FileLayout
directory PathSegment
dirName ([FileLayout] -> FileLayout) -> [FileLayout] -> FileLayout
forall a b. (a -> b) -> a -> b
$ sys -> [FileLayout]
forall sys. HasSystemMeta sys => sys -> [FileLayout]
buildDebuggingFiles sys
sys
    Maybe String
_ -> Maybe FileLayout -> IO (Maybe FileLayout)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FileLayout
forall a. Maybe a
Nothing

-- | Concretize a system into a concrete set of files and write them to disk.
--
-- Note: Writes files to a subdirectory of the current working directory.
concretizeAndWrite ::
  (ToFiles sys concOpts) =>
  -- | The system.
  sys ->
  -- | The concretization options.
  concOpts ->
  -- | The file-writing options.
  WriteOptions ->
  -- | Files will be written to a local directory named after the abbreviation
  -- of the system.
  IO ()
concretizeAndWrite :: forall sys concOpts.
ToFiles sys concOpts =>
sys -> concOpts -> WriteOptions -> IO ()
concretizeAndWrite sys
sys concOpts
concOpts WO {TextEncoding
OverwritePolicy
DebugDataPolicy
forall sys. HasSystemMeta sys => sys -> PathSegment
overwritePolicy :: WriteOptions -> OverwritePolicy
localDirName :: WriteOptions -> forall sys. HasSystemMeta sys => sys -> PathSegment
textEncoding :: WriteOptions -> TextEncoding
debugDataPolicy :: WriteOptions -> DebugDataPolicy
overwritePolicy :: OverwritePolicy
localDirName :: forall sys. HasSystemMeta sys => sys -> PathSegment
textEncoding :: TextEncoding
debugDataPolicy :: DebugDataPolicy
..} = do
  TextEncoding -> IO ()
setLocaleEncoding TextEncoding
textEncoding
  Maybe FileLayout
debugFiles <- sys -> DebugDataPolicy -> IO (Maybe FileLayout)
forall sys.
HasSystemMeta sys =>
sys -> DebugDataPolicy -> IO (Maybe FileLayout)
debugData sys
sys DebugDataPolicy
debugDataPolicy
  let artifacts :: [FileLayout]
artifacts = sys -> concOpts -> [FileLayout]
forall sys opts. ToFiles sys opts => sys -> opts -> [FileLayout]
toFiles sys
sys concOpts
concOpts
      artifacts' :: [FileLayout]
artifacts' = [FileLayout]
-> (FileLayout -> [FileLayout]) -> Maybe FileLayout -> [FileLayout]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [FileLayout]
artifacts (FileLayout -> [FileLayout] -> [FileLayout]
forall a. a -> [a] -> [a]
: [FileLayout]
artifacts) Maybe FileLayout
debugFiles
      finalDir :: FileLayout
finalDir = PathSegment -> [FileLayout] -> FileLayout
forall (f :: * -> *).
Foldable f =>
PathSegment -> f FileLayout -> FileLayout
directory (sys -> PathSegment
forall sys. HasSystemMeta sys => sys -> PathSegment
localDirName sys
sys) [FileLayout]
artifacts'
  OverwritePolicy -> OsPath -> FileLayout -> IO ()
writeFiles OverwritePolicy
overwritePolicy OsPath
localPath FileLayout
finalDir