{-# 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
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'))
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'
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
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"
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
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"
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
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
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'
]