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

module Cabal (replace, convert) where

import Configuration (Configuration (..))
import Control.Exception (Exception)
import Control.Monad.Catch (throwM)
import Control.Monad.Reader (asks, liftIO)
import Data.ByteString (ByteString, append, breakSubstring, concat, readFile, stripPrefix)
import qualified Data.ByteString.Char8 as BS (pack)
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 Initialise.Types (Initialise)
import System.Directory.Extra (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
import System.FilePath (replaceBaseName, (</>))
import Text.Parsec.Error (ParseError)
import Prelude hiding (concat, readFile, unlines, writeFile)

instance Exception ParseError

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

replaceCabal :: FilePath -> Initialise ()
replaceCabal :: [Char] -> Initialise ()
replaceCabal [Char]
path = do
  -- TODO handle in replaceWith
  [Char]
path' <- (Configuration -> [Char]) -> ReaderT Configuration IO [Char]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ([Char] -> [Char] -> [Char]
replaceBaseName [Char]
path ([Char] -> [Char])
-> (Configuration -> [Char]) -> Configuration -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> [Char])
-> (Configuration -> Text) -> Configuration -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Configuration -> Text
name)
  -- TODO replaceWith convert
  FieldName
contents <- IO FieldName -> ReaderT Configuration IO FieldName
forall a. IO a -> ReaderT Configuration IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FieldName -> ReaderT Configuration IO FieldName)
-> IO FieldName -> ReaderT Configuration IO FieldName
forall a b. (a -> b) -> a -> b
$ [Char] -> IO FieldName
readFile [Char]
path
  Text
contents' <- FieldName -> Initialise Text
convert FieldName
contents
  IO () -> Initialise ()
forall a. IO a -> ReaderT Configuration IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initialise ()) -> IO () -> Initialise ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text -> IO ()
writeFile [Char]
path' Text
contents'
  -- TODO handle in replaceWith
  IO () -> Initialise ()
forall a. IO a -> ReaderT Configuration IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initialise ()) -> IO () -> Initialise ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
removeFile [Char]
path

convert :: ByteString -> Initialise Text
convert :: FieldName -> Initialise Text
convert FieldName
contents = do
  [Field Position]
fs <- (ParseError -> ReaderT Configuration IO [Field Position])
-> ([Field Position] -> ReaderT Configuration IO [Field Position])
-> Either ParseError [Field Position]
-> ReaderT Configuration IO [Field Position]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseError -> ReaderT Configuration IO [Field Position]
forall e a.
(HasCallStack, Exception e) =>
e -> ReaderT Configuration IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM [Field Position] -> ReaderT Configuration IO [Field Position]
forall a. a -> ReaderT Configuration IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> Either ParseError [Field Position]
readFields FieldName
contents)
  [Char] -> Text
T.pack ([Char] -> Text)
-> ([Field Position] -> [Char]) -> [Field Position] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> CommentPosition) -> [PrettyField Position] -> [Char]
forall ann. (ann -> CommentPosition) -> [PrettyField ann] -> [Char]
showFields (CommentPosition -> Position -> CommentPosition
forall a b. a -> b -> a
const CommentPosition
NoComment) ([PrettyField Position] -> [Char])
-> ([Field Position] -> [PrettyField Position])
-> [Field Position]
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Field Position] -> [PrettyField Position]
forall ann. [Field ann] -> [PrettyField ann]
fromParsecFields ([Field Position] -> Text)
-> ReaderT Configuration IO [Field Position] -> Initialise Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Field Position -> ReaderT Configuration IO (Field Position))
-> [Field Position] -> ReaderT Configuration IO [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 -> ReaderT Configuration IO (Field Position)
convert' [Field Position]
fs

convert' :: Field Position -> Initialise (Field Position)
convert' :: Field Position -> ReaderT Configuration IO (Field Position)
convert' f :: Field Position
f@(Field n :: Name Position
n@(Name Position
_ FieldName
fName) [FieldLine Position]
ls) = do
  Configuration {Year
[Char]
LicenseId
Text
URI
name :: Configuration -> Text
name :: Text
homepage :: URI
author :: Text
maintainer :: Text
licence :: LicenseId
path :: [Char]
year :: Year
homepage :: Configuration -> URI
author :: Configuration -> Text
maintainer :: Configuration -> Text
licence :: Configuration -> LicenseId
path :: Configuration -> [Char]
year :: Configuration -> Year
..} <- (Configuration -> Configuration)
-> ReaderT Configuration IO Configuration
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Configuration -> Configuration
forall a. a -> a
id
  case FieldName
fName of
    -- package
    FieldName
"name" -> FieldName -> ReaderT Configuration IO (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (Text -> FieldName
encodeUtf8 Text
name)
    FieldName
"version" -> FieldName -> ReaderT Configuration IO (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field FieldName
"0.1.0.0"
    FieldName
"license" -> FieldName -> ReaderT Configuration IO (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field ([Char] -> FieldName
BS.pack ([Char] -> FieldName) -> [Char] -> FieldName
forall a b. (a -> b) -> a -> b
$ LicenseId -> [Char]
licenseId LicenseId
licence)
    FieldName
"copyright" -> FieldName -> ReaderT Configuration IO (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field ([Char] -> FieldName
BS.pack ([Char] -> FieldName) -> [Char] -> FieldName
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]
"(c)", Year -> [Char]
forall a. Show a => a -> [Char]
show Year
year, Text -> [Char]
T.unpack Text
author])
    FieldName
"author" -> FieldName -> ReaderT Configuration IO (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (Text -> FieldName
encodeUtf8 Text
author)
    FieldName
"maintainer" -> FieldName -> ReaderT Configuration IO (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (Text -> FieldName
encodeUtf8 Text
maintainer)
    FieldName
"homepage" -> FieldName -> ReaderT Configuration IO (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (FieldName -> ReaderT Configuration IO (Field Position))
-> FieldName -> ReaderT Configuration IO (Field Position)
forall a b. (a -> b) -> a -> b
$ [Char] -> FieldName
BS.pack ([Char] -> FieldName) -> [Char] -> FieldName
forall a b. (a -> b) -> a -> b
$ URI -> [Char]
forall a. Show a => a -> [Char]
show URI
homepage
    FieldName
"bug-reports" -> FieldName -> ReaderT Configuration IO (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (FieldName -> ReaderT Configuration IO (Field Position))
-> FieldName -> ReaderT Configuration IO (Field Position)
forall a b. (a -> b) -> a -> b
$ [Char] -> FieldName
BS.pack (URI -> [Char]
forall a. Show a => a -> [Char]
show URI
homepage [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/issues")
    FieldName
"synopsis" -> FieldName -> ReaderT Configuration IO (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field FieldName
"TODO"
    FieldName
"description" -> FieldName -> ReaderT Configuration IO (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field FieldName
"TODO"
    -- common
    FieldName
"import" -> FieldName -> ReaderT Configuration IO (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 -> ReaderT Configuration IO (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field FieldName
""
    FieldName
"other-modules" -> FieldName -> ReaderT Configuration IO (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field FieldName
""
    FieldName
"build-depends" -> Field Position -> ReaderT Configuration IO (Field Position)
forall a. a -> ReaderT Configuration IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field Position -> ReaderT Configuration IO (Field Position))
-> Field Position -> ReaderT Configuration IO (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 -> ReaderT Configuration IO (Field Position)
forall a. a -> ReaderT Configuration IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field Position -> ReaderT Configuration IO (Field Position))
-> Field Position -> ReaderT Configuration IO (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 -> ReaderT Configuration IO (Field Position)
forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (FieldName -> ReaderT Configuration IO (Field Position))
-> FieldName -> ReaderT Configuration IO (Field Position)
forall a b. (a -> b) -> a -> b
$ [Char] -> FieldName
BS.pack ([Char] -> FieldName) -> [Char] -> FieldName
forall a b. (a -> b) -> a -> b
$ URI -> [Char]
forall a. Show a => a -> [Char]
show URI
homepage
    FieldName
_ -> Field Position -> ReaderT Configuration IO (Field Position)
forall a. a -> ReaderT Configuration IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Field Position
f
  where
    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]
    annotation :: Position
annotation = FieldLine Position -> Position
forall ann. FieldLine ann -> ann
fieldLineAnn (FieldLine Position -> Position)
-> ([FieldLine Position] -> FieldLine Position)
-> [FieldLine Position]
-> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FieldLine Position] -> FieldLine Position
forall a. HasCallStack => [a] -> a
head ([FieldLine Position] -> Position)
-> [FieldLine Position] -> Position
forall a b. (a -> b) -> a -> b
$ [FieldLine Position]
ls
convert' (Section Name Position
n [SectionArg Position]
arguments [Field Position]
fs) = do
  Configuration {Year
[Char]
LicenseId
Text
URI
name :: Configuration -> Text
homepage :: Configuration -> URI
author :: Configuration -> Text
maintainer :: Configuration -> Text
licence :: Configuration -> LicenseId
path :: Configuration -> [Char]
year :: Configuration -> Year
name :: Text
homepage :: URI
author :: Text
maintainer :: Text
licence :: LicenseId
path :: [Char]
year :: Year
..} <- (Configuration -> Configuration)
-> ReaderT Configuration IO Configuration
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Configuration -> Configuration
forall a. a -> a
id
  [Field Position]
fs' <- (Field Position -> ReaderT Configuration IO (Field Position))
-> [Field Position] -> ReaderT Configuration IO [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 -> ReaderT Configuration IO (Field Position)
convert' [Field Position]
fs
  Field Position -> ReaderT Configuration IO (Field Position)
forall a. a -> ReaderT Configuration IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field Position -> ReaderT Configuration IO (Field Position))
-> Field Position -> ReaderT Configuration IO (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 -> Initialise ()) -> Initialise ()
replaceDirectoryWith :: [Char] -> ([Char] -> Initialise ()) -> Initialise ()
replaceDirectoryWith [Char]
component [Char] -> Initialise ()
r = do
  Text
name' <- (Configuration -> Text) -> Initialise Text
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Configuration -> Text
name
  [Char]
path' <- (Configuration -> [Char]) -> ReaderT Configuration IO [Char]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (([Char] -> [Char] -> [Char]
</> [Char]
component [Char] -> [Char] -> [Char]
</> Text -> [Char]
T.unpack Text
name') ([Char] -> [Char])
-> (Configuration -> [Char]) -> Configuration -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Configuration -> [Char]
path)
  IO () -> Initialise ()
forall a. IO a -> ReaderT Configuration IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initialise ()) -> IO () -> Initialise ()
forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
path'
  [Char] -> Initialise ()
r [Char]
path'
  IO () -> Initialise ()
forall a. IO a -> ReaderT Configuration IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initialise ()) -> IO () -> Initialise ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
removeDirectoryRecursive ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char]
replaceBaseName [Char]
"initialise" [Char]
path'

replaceLib :: FilePath -> Initialise ()
replaceLib :: [Char] -> Initialise ()
replaceLib [Char]
_path = () -> Initialise ()
forall a. a -> ReaderT Configuration IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

replaceTest :: FilePath -> Initialise ()
replaceTest :: [Char] -> Initialise ()
replaceTest [Char]
path = do
  Text
name' <- (Configuration -> Text) -> Initialise Text
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Configuration -> Text
name
  -- TODO Template library.
  IO () -> Initialise ()
forall a. IO a -> ReaderT Configuration IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initialise ()) -> IO () -> Initialise ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> Text -> IO ()
writeFile ([Char]
path [Char] -> [Char] -> [Char]
</> [Char]
"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 -> Initialise ()
replaceBin :: [Char] -> Initialise ()
replaceBin [Char]
path = do
  Text
name' <- (Configuration -> Text) -> Initialise Text
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Configuration -> Text
name
  -- TODO Template library.(*)
  IO () -> Initialise ()
forall a. IO a -> ReaderT Configuration IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initialise ()) -> IO () -> Initialise ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> Text -> IO ()
writeFile ([Char]
path [Char] -> [Char] -> [Char]
</> [Char]
"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'
        ]