{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cabal (replace, convert) where

import Control.Monad.Catch (Exception, throwM)
import Control.Monad.Logger (logInfo)
import Control.Monad.Reader (MonadReader (ask), asks, liftIO)
import Data.ByteString (ByteString, append, breakSubstring, concat, readFile, stripPrefix)
import qualified Data.ByteString.Char8 as BS (pack, unpack)
import Data.List.NonEmpty (head, nonEmpty)
import Data.Text (Text, unlines)
import qualified Data.Text as T (pack, unpack)
import Data.Text.Encoding (encodeUtf8)
import Data.Text.IO (writeFile)
import Distribution.Fields
  ( CommentPosition (NoComment),
    Field (Field, Section),
    FieldLine (FieldLine),
    Name (Name),
    SectionArg (SecArgName, SecArgStr),
    fromParsecFields,
    readFields,
    showFields,
  )
import Distribution.Fields.Field (fieldLineAnn)
import Distribution.Parsec.Position (Position)
import Distribution.SPDX (licenseId)
import qualified Environment (T (..))
import Initialiser.Types (Initialiser)
import System.Directory.Extra (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
import System.FilePath (replaceBaseName, (</>))
import Prelude hiding (concat, head, readFile, unlines, writeFile)

#if __GLASGOW_HASKELL__ < 908
import Text.Parsec.Error (ParseError)
instance Exception ParseError
#endif

newtype MissingAnnotationException = MissingAnnotationException Text
  deriving (Int -> MissingAnnotationException -> ShowS
[MissingAnnotationException] -> ShowS
MissingAnnotationException -> FilePath
(Int -> MissingAnnotationException -> ShowS)
-> (MissingAnnotationException -> FilePath)
-> ([MissingAnnotationException] -> ShowS)
-> Show MissingAnnotationException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MissingAnnotationException -> ShowS
showsPrec :: Int -> MissingAnnotationException -> ShowS
$cshow :: MissingAnnotationException -> FilePath
show :: MissingAnnotationException -> FilePath
$cshowList :: [MissingAnnotationException] -> ShowS
showList :: [MissingAnnotationException] -> ShowS
Show)

instance Exception MissingAnnotationException

replace :: FilePath -> Initialiser ()
replace :: FilePath -> Initialiser ()
replace FilePath
path = do
  FilePath -> Initialiser ()
replaceCabal FilePath
path
  FilePath
"lib" FilePath -> (FilePath -> Initialiser ()) -> Initialiser ()
`replaceDirectoryWith` FilePath -> Initialiser ()
replaceLib
  FilePath
"test" FilePath -> (FilePath -> Initialiser ()) -> Initialiser ()
`replaceDirectoryWith` FilePath -> Initialiser ()
replaceTest
  FilePath
"bin" FilePath -> (FilePath -> Initialiser ()) -> Initialiser ()
`replaceDirectoryWith` FilePath -> Initialiser ()
replaceBin

replaceCabal :: FilePath -> Initialiser ()
replaceCabal :: FilePath -> Initialiser ()
replaceCabal FilePath
path = do
  -- TODO handle in replaceWith
  FilePath
path' <- (T -> FilePath) -> Initialiser FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (FilePath -> ShowS
replaceBaseName FilePath
path ShowS -> (T -> FilePath) -> T -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> FilePath) -> (T -> Text) -> T -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> Text
Environment.name)
  $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> Initialiser ()
(Text -> Initialiser ())
-> (Text -> Text) -> Text -> Initialiser ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> Initialiser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logInfo (Text
"replacing cabal " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (ShowS
forall a. Show a => a -> FilePath
show FilePath
path) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (ShowS
forall a. Show a => a -> FilePath
show FilePath
path'))
  -- TODO replaceWith convert
  FieldName
contents <- IO FieldName -> Initialiser FieldName
forall a. IO a -> Initialiser a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FieldName -> Initialiser FieldName)
-> IO FieldName -> Initialiser FieldName
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FieldName
readFile FilePath
path
  Text
contents' <- FieldName -> Initialiser Text
convert FieldName
contents
  IO () -> Initialiser ()
forall a. IO a -> Initialiser a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initialiser ()) -> IO () -> Initialiser ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> IO ()
writeFile FilePath
path' Text
contents'
  -- TODO handle in replaceWith
  IO () -> Initialiser ()
forall a. IO a -> Initialiser a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initialiser ()) -> IO () -> Initialiser ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
path

convert :: ByteString -> Initialiser Text
convert :: FieldName -> Initialiser Text
convert FieldName
contents = do
  [Field Position]
fs <- (ParseError -> Initialiser [Field Position])
-> ([Field Position] -> Initialiser [Field Position])
-> Either ParseError [Field Position]
-> Initialiser [Field Position]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseError -> Initialiser [Field Position]
forall e a. (HasCallStack, Exception e) => e -> Initialiser a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM [Field Position] -> Initialiser [Field Position]
forall a. a -> Initialiser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> Either ParseError [Field Position]
readFields FieldName
contents)
  FilePath -> Text
T.pack (FilePath -> Text)
-> ([Field Position] -> FilePath) -> [Field Position] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> CommentPosition) -> [PrettyField Position] -> FilePath
forall ann.
(ann -> CommentPosition) -> [PrettyField ann] -> FilePath
showFields (CommentPosition -> Position -> CommentPosition
forall a b. a -> b -> a
const CommentPosition
NoComment) ([PrettyField Position] -> FilePath)
-> ([Field Position] -> [PrettyField Position])
-> [Field Position]
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Field Position] -> [PrettyField Position]
forall ann. [Field ann] -> [PrettyField ann]
fromParsecFields ([Field Position] -> Text)
-> Initialiser [Field Position] -> Initialiser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Field Position -> Initialiser (Field Position))
-> [Field Position] -> Initialiser [Field Position]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Field Position -> Initialiser (Field Position)
convert' [Field Position]
fs

convert' :: Field Position -> Initialiser (Field Position)
convert' :: Field Position -> Initialiser (Field Position)
convert' f :: Field Position
f@(Field n :: Name Position
n@(Name Position
_ FieldName
fName) [FieldLine Position]
ls) = do
  Environment.T {Year
FilePath
LicenseId
Text
URI
LogLevel
name :: T -> Text
name :: Text
cabalName :: Text
homepage :: URI
author :: Text
maintainer :: Text
licence :: LicenseId
path :: FilePath
year :: Year
verbosity :: LogLevel
cabalName :: T -> Text
homepage :: T -> URI
author :: T -> Text
maintainer :: T -> Text
licence :: T -> LicenseId
path :: T -> FilePath
year :: T -> Year
verbosity :: T -> LogLevel
..} <- (T -> T) -> Initialiser T
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks T -> T
forall a. a -> a
id
  Position
annotation <- case [FieldLine Position] -> Maybe (NonEmpty (FieldLine Position))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [FieldLine Position]
ls of
    (Just NonEmpty (FieldLine Position)
ls') -> Position -> Initialiser Position
forall a. a -> Initialiser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Position -> Initialiser Position)
-> Position -> Initialiser Position
forall a b. (a -> b) -> a -> b
$ FieldLine Position -> Position
forall ann. FieldLine ann -> ann
fieldLineAnn (NonEmpty (FieldLine Position) -> FieldLine Position
forall a. NonEmpty a -> a
head NonEmpty (FieldLine Position)
ls')
    Maybe (NonEmpty (FieldLine Position))
Nothing -> MissingAnnotationException -> Initialiser Position
forall e a. (HasCallStack, Exception e) => e -> Initialiser a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (MissingAnnotationException -> Initialiser Position)
-> MissingAnnotationException -> Initialiser Position
forall a b. (a -> b) -> a -> b
$ Text -> MissingAnnotationException
MissingAnnotationException (Text -> MissingAnnotationException)
-> Text -> MissingAnnotationException
forall a b. (a -> b) -> a -> b
$ Text
"field " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (FieldName -> FilePath
BS.unpack FieldName
fName) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has no annotation"
  let field :: FieldName -> f (Field Position)
field FieldName
s = Field Position -> f (Field Position)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field Position -> f (Field Position))
-> Field Position -> f (Field Position)
forall a b. (a -> b) -> a -> b
$ Name Position -> [FieldLine Position] -> Field Position
forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name Position
n [Position -> FieldName -> FieldLine Position
forall ann. ann -> FieldName -> FieldLine ann
FieldLine Position
annotation FieldName
s]
  case FieldName
fName of
    -- package
    FieldName
"name" -> FieldName -> Initialiser (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (Text -> FieldName
encodeUtf8 Text
cabalName)
    FieldName
"version" -> FieldName -> Initialiser (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field FieldName
"0.1.0.0"
    FieldName
"license" -> FieldName -> Initialiser (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (FilePath -> FieldName
BS.pack (FilePath -> FieldName) -> FilePath -> FieldName
forall a b. (a -> b) -> a -> b
$ LicenseId -> FilePath
licenseId LicenseId
licence)
    FieldName
"copyright" -> FieldName -> Initialiser (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (FilePath -> FieldName
BS.pack (FilePath -> FieldName) -> FilePath -> FieldName
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [FilePath
"(c)", Year -> FilePath
forall a. Show a => a -> FilePath
show Year
year, Text -> FilePath
T.unpack Text
author])
    FieldName
"author" -> FieldName -> Initialiser (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (Text -> FieldName
encodeUtf8 Text
author)
    FieldName
"maintainer" -> FieldName -> Initialiser (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (Text -> FieldName
encodeUtf8 Text
maintainer)
    FieldName
"homepage" -> FieldName -> Initialiser (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (FieldName -> Initialiser (Field Position))
-> FieldName -> Initialiser (Field Position)
forall a b. (a -> b) -> a -> b
$ FilePath -> FieldName
BS.pack (FilePath -> FieldName) -> FilePath -> FieldName
forall a b. (a -> b) -> a -> b
$ URI -> FilePath
forall a. Show a => a -> FilePath
show URI
homepage
    FieldName
"bug-reports" -> FieldName -> Initialiser (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (FieldName -> Initialiser (Field Position))
-> FieldName -> Initialiser (Field Position)
forall a b. (a -> b) -> a -> b
$ FilePath -> FieldName
BS.pack (URI -> FilePath
forall a. Show a => a -> FilePath
show URI
homepage FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"/issues")
    FieldName
"synopsis" -> FieldName -> Initialiser (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field FieldName
"TODO"
    FieldName
"description" -> FieldName -> Initialiser (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field FieldName
"TODO"
    -- common
    FieldName
"import" -> FieldName -> Initialiser (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (Text -> FieldName
encodeUtf8 Text
name FieldName -> FieldName -> FieldName
`append` FieldName
"-common")
    FieldName
"exposed-modules" -> FieldName -> Initialiser (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field FieldName
""
    FieldName
"other-modules" -> FieldName -> Initialiser (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field FieldName
""
    FieldName
"build-depends" -> Field Position -> Initialiser (Field Position)
forall a. a -> Initialiser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field Position -> Initialiser (Field Position))
-> Field Position -> Initialiser (Field Position)
forall a b. (a -> b) -> a -> b
$ Name Position -> [FieldLine Position] -> Field Position
forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name Position
n ([FieldLine Position] -> Field Position)
-> [FieldLine Position] -> Field Position
forall a b. (a -> b) -> a -> b
$ (FieldLine Position -> FieldLine Position)
-> [FieldLine Position] -> [FieldLine Position]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> FieldLine Position -> FieldLine Position
convertFieldLine Text
name) [FieldLine Position]
ls
    FieldName
"hs-source-dirs" -> Field Position -> Initialiser (Field Position)
forall a. a -> Initialiser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field Position -> Initialiser (Field Position))
-> Field Position -> Initialiser (Field Position)
forall a b. (a -> b) -> a -> b
$ Name Position -> [FieldLine Position] -> Field Position
forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name Position
n ([FieldLine Position] -> Field Position)
-> [FieldLine Position] -> Field Position
forall a b. (a -> b) -> a -> b
$ (FieldLine Position -> FieldLine Position)
-> [FieldLine Position] -> [FieldLine Position]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> FieldLine Position -> FieldLine Position
convertFieldLine Text
name) [FieldLine Position]
ls
    -- source-repository
    FieldName
"location" -> FieldName -> Initialiser (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (FieldName -> Initialiser (Field Position))
-> FieldName -> Initialiser (Field Position)
forall a b. (a -> b) -> a -> b
$ FilePath -> FieldName
BS.pack (FilePath -> FieldName) -> FilePath -> FieldName
forall a b. (a -> b) -> a -> b
$ URI -> FilePath
forall a. Show a => a -> FilePath
show URI
homepage
    FieldName
_ -> Field Position -> Initialiser (Field Position)
forall a. a -> Initialiser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Field Position
f
convert' (Section Name Position
n [SectionArg Position]
arguments [Field Position]
fs) = do
  Environment.T {Year
FilePath
LicenseId
Text
URI
LogLevel
name :: T -> Text
cabalName :: T -> Text
homepage :: T -> URI
author :: T -> Text
maintainer :: T -> Text
licence :: T -> LicenseId
path :: T -> FilePath
year :: T -> Year
verbosity :: T -> LogLevel
name :: Text
cabalName :: Text
homepage :: URI
author :: Text
maintainer :: Text
licence :: LicenseId
path :: FilePath
year :: Year
verbosity :: LogLevel
..} <- (T -> T) -> Initialiser T
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks T -> T
forall a. a -> a
id
  [Field Position]
fs' <- (Field Position -> Initialiser (Field Position))
-> [Field Position] -> Initialiser [Field Position]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Field Position -> Initialiser (Field Position)
convert' [Field Position]
fs
  Field Position -> Initialiser (Field Position)
forall a. a -> Initialiser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field Position -> Initialiser (Field Position))
-> Field Position -> Initialiser (Field Position)
forall a b. (a -> b) -> a -> b
$ Name Position
-> [SectionArg Position] -> [Field Position] -> Field Position
forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Field ann
Section Name Position
n ((SectionArg Position -> SectionArg Position)
-> [SectionArg Position] -> [SectionArg Position]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> SectionArg Position -> SectionArg Position
convertSectionArgument Text
name) [SectionArg Position]
arguments) [Field Position]
fs'

convertSectionArgument :: Text -> SectionArg Position -> SectionArg Position
convertSectionArgument :: Text -> SectionArg Position -> SectionArg Position
convertSectionArgument Text
n SectionArg Position
s = case SectionArg Position
s of
  (SecArgName Position
a FieldName
o) -> Position -> FieldName -> SectionArg Position
forall ann. ann -> FieldName -> SectionArg ann
SecArgName Position
a (FieldName -> SectionArg Position)
-> FieldName -> SectionArg Position
forall a b. (a -> b) -> a -> b
$ Text -> FieldName -> FieldName
convertString Text
n FieldName
o
  (SecArgStr Position
a FieldName
o) -> Position -> FieldName -> SectionArg Position
forall ann. ann -> FieldName -> SectionArg ann
SecArgStr Position
a (FieldName -> SectionArg Position)
-> FieldName -> SectionArg Position
forall a b. (a -> b) -> a -> b
$ Text -> FieldName -> FieldName
convertString Text
n FieldName
o
  SectionArg Position
_ -> SectionArg Position
s

convertFieldLine :: Text -> FieldLine Position -> FieldLine Position
convertFieldLine :: Text -> FieldLine Position -> FieldLine Position
convertFieldLine Text
r (FieldLine Position
annotation FieldName
s) = Position -> FieldName -> FieldLine Position
forall ann. ann -> FieldName -> FieldLine ann
FieldLine Position
annotation (FieldName -> FieldLine Position)
-> FieldName -> FieldLine Position
forall a b. (a -> b) -> a -> b
$ Text -> FieldName -> FieldName
convertString Text
r FieldName
s

convertString :: Text -> ByteString -> ByteString
convertString :: Text -> FieldName -> FieldName
convertString Text
r FieldName
s = case FieldName
token FieldName -> FieldName -> Maybe FieldName
`stripPrefix` FieldName
rest of
  Just FieldName
suffix -> [FieldName] -> FieldName
concat [FieldName
prefix, Text -> FieldName
encodeUtf8 Text
r, FieldName
suffix]
  Maybe FieldName
Nothing -> FieldName
s
  where
    (FieldName
prefix, FieldName
rest) = FieldName
token FieldName -> FieldName -> (FieldName, FieldName)
`breakSubstring` FieldName
s
    token :: FieldName
token = FieldName
"initialise"

-- TODO Move to Initialise module?
replaceDirectoryWith :: FilePath -> (FilePath -> Initialiser ()) -> Initialiser ()
replaceDirectoryWith :: FilePath -> (FilePath -> Initialiser ()) -> Initialiser ()
replaceDirectoryWith FilePath
component FilePath -> Initialiser ()
r = do
  Environment.T {Year
FilePath
LicenseId
Text
URI
LogLevel
name :: T -> Text
cabalName :: T -> Text
homepage :: T -> URI
author :: T -> Text
maintainer :: T -> Text
licence :: T -> LicenseId
path :: T -> FilePath
year :: T -> Year
verbosity :: T -> LogLevel
name :: Text
cabalName :: Text
homepage :: URI
author :: Text
maintainer :: Text
licence :: LicenseId
path :: FilePath
year :: Year
verbosity :: LogLevel
..} <- Initialiser T
forall r (m :: * -> *). MonadReader r m => m r
ask
  let new :: FilePath
new = FilePath
component FilePath -> ShowS
</> Text -> FilePath
T.unpack Text
name
  let original :: FilePath
original = FilePath
component FilePath -> ShowS
</> FilePath
"initialise"
  $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> Initialiser ()
(Text -> Initialiser ())
-> (Text -> Text) -> Text -> Initialiser ()
forall a. a -> a
forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> Initialiser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logInfo (Text
"replacing directory " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (ShowS
forall a. Show a => a -> FilePath
show FilePath
original) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (ShowS
forall a. Show a => a -> FilePath
show FilePath
new))
  IO () -> Initialiser ()
forall a. IO a -> Initialiser a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initialiser ()) -> IO () -> Initialiser ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
path FilePath -> ShowS
</> FilePath
new
  FilePath -> Initialiser ()
r (FilePath -> Initialiser ()) -> FilePath -> Initialiser ()
forall a b. (a -> b) -> a -> b
$ FilePath
path FilePath -> ShowS
</> FilePath
new
  IO () -> Initialiser ()
forall a. IO a -> Initialiser a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initialiser ()) -> IO () -> Initialiser ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeDirectoryRecursive (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
path FilePath -> ShowS
</> FilePath
original

replaceLib :: FilePath -> Initialiser ()
replaceLib :: FilePath -> Initialiser ()
replaceLib FilePath
_path = () -> Initialiser ()
forall a. a -> Initialiser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

replaceTest :: FilePath -> Initialiser ()
replaceTest :: FilePath -> Initialiser ()
replaceTest FilePath
path = do
  Text
name' <- (T -> Text) -> Initialiser Text
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks T -> Text
Environment.name
  -- TODO Template library.
  IO () -> Initialiser ()
forall a. IO a -> Initialiser a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initialiser ()) -> IO () -> Initialiser ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> Text -> IO ()
writeFile (FilePath
path FilePath -> ShowS
</> FilePath
"Main.hs") (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Text] -> Text
unlines
        [ Text
"module Main (main) where",
          Text
"",
          Text
"import Test.Tasty (defautMain, testGroup)",
          Text
"",
          Text
"main :: IO ()",
          Text
"main = defaultMain $ testGroup \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-library\" []"
        ]

replaceBin :: FilePath -> Initialiser ()
replaceBin :: FilePath -> Initialiser ()
replaceBin FilePath
path = do
  Text
name' <- (T -> Text) -> Initialiser Text
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks T -> Text
Environment.name
  -- TODO Template library.(*)
  IO () -> Initialiser ()
forall a. IO a -> Initialiser a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initialiser ()) -> IO () -> Initialiser ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> Text -> IO ()
writeFile (FilePath
path FilePath -> ShowS
</> FilePath
"Main.hs") (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Text] -> Text
unlines
        [ Text
"module Main (main) where",
          Text
"",
          Text
"main :: IO ()",
          Text
"main = putStrLn " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'
        ]