{-# 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 Data.ByteString.Char8 (pack)
import Data.Text (Text, unpack)
import Data.Text.Encoding (encodeUtf8)
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 (Initialise)
import System.Directory.Extra (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
import System.FilePath (replaceBaseName, (</>))
import Text.Parsec.Error (ParseError)
import Prelude hiding (concat, readFile)

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' <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a b c. (a -> b -> c) -> b -> a -> c
flip [Char] -> [Char] -> [Char]
replaceBaseName [Char]
path forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Configuration -> Text
name)
  -- TODO replaceWith convert
  FieldName
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO FieldName
readFile [Char]
path
  [Char]
contents' <- FieldName -> Initialise [Char]
convert FieldName
contents
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
writeFile [Char]
path' [Char]
contents'
  -- TODO handle in replaceWith
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
removeFile [Char]
path

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

convert' :: Field Position -> Initialise (Field Position)
convert' :: Field Position -> Initialise (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
year :: Configuration -> Year
path :: Configuration -> [Char]
licence :: Configuration -> LicenseId
maintainer :: Configuration -> Text
author :: Configuration -> Text
homepage :: Configuration -> URI
year :: Year
path :: [Char]
licence :: LicenseId
maintainer :: Text
author :: Text
homepage :: URI
name :: Text
name :: Configuration -> Text
..} <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. a -> a
id
  case FieldName
fName of
    -- package
    FieldName
"name" -> forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (Text -> FieldName
encodeUtf8 Text
name)
    FieldName
"version" -> forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field FieldName
"0.1.0.0"
    FieldName
"license" -> forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field ([Char] -> FieldName
pack forall a b. (a -> b) -> a -> b
$ LicenseId -> [Char]
licenseId LicenseId
licence)
    FieldName
"copyright" -> forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field ([Char] -> FieldName
pack forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]
"(c)", forall a. Show a => a -> [Char]
show Year
year, Text -> [Char]
unpack Text
author])
    FieldName
"author" -> forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (Text -> FieldName
encodeUtf8 Text
author)
    FieldName
"maintainer" -> forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (Text -> FieldName
encodeUtf8 Text
maintainer)
    FieldName
"homepage" -> forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field forall a b. (a -> b) -> a -> b
$ [Char] -> FieldName
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show URI
homepage
    FieldName
"bug-reports" -> forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field forall a b. (a -> b) -> a -> b
$ [Char] -> FieldName
pack (forall a. Show a => a -> [Char]
show URI
homepage forall a. [a] -> [a] -> [a]
++ [Char]
"/issues")
    FieldName
"synopsis" -> forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field FieldName
"TODO"
    FieldName
"description" -> forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field FieldName
"TODO"
    -- common
    FieldName
"import" -> forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field (Text -> FieldName
encodeUtf8 Text
name FieldName -> FieldName -> FieldName
`append` FieldName
"-common")
    FieldName
"exposed-modules" -> forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field FieldName
""
    FieldName
"other-modules" -> forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field FieldName
""
    FieldName
"build-depends" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name Position
n forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> FieldLine Position -> FieldLine Position
convertFieldLine Text
name) [FieldLine Position]
ls
    FieldName
"hs-source-dirs" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name Position
n forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> FieldLine Position -> FieldLine Position
convertFieldLine Text
name) [FieldLine Position]
ls
    -- source-repository
    FieldName
"location" -> forall {f :: * -> *}.
Applicative f =>
FieldName -> f (Field Position)
field forall a b. (a -> b) -> a -> b
$ [Char] -> FieldName
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show URI
homepage
    FieldName
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Field Position
f
  where
    field :: FieldName -> f (Field Position)
field FieldName
s = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name Position
n [forall ann. ann -> FieldName -> FieldLine ann
FieldLine Position
annotation FieldName
s]
    annotation :: Position
annotation = forall ann. FieldLine ann -> ann
fieldLineAnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head 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
year :: Year
path :: [Char]
licence :: LicenseId
maintainer :: Text
author :: Text
homepage :: URI
name :: Text
year :: Configuration -> Year
path :: Configuration -> [Char]
licence :: Configuration -> LicenseId
maintainer :: Configuration -> Text
author :: Configuration -> Text
homepage :: Configuration -> URI
name :: Configuration -> Text
..} <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. a -> a
id
  [Field Position]
fs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Field Position -> Initialise (Field Position)
convert' [Field Position]
fs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Field ann
Section Name Position
n (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) -> forall ann. ann -> FieldName -> SectionArg ann
SecArgName Position
a forall a b. (a -> b) -> a -> b
$ Text -> FieldName -> FieldName
convertString Text
n FieldName
o
  (SecArgStr Position
a FieldName
o) -> forall ann. ann -> FieldName -> SectionArg ann
SecArgStr Position
a 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) = forall ann. ann -> FieldName -> FieldLine ann
FieldLine Position
annotation 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' <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Configuration -> Text
name
  [Char]
path' <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (([Char] -> [Char] -> [Char]
</> [Char]
component [Char] -> [Char] -> [Char]
</> Text -> [Char]
unpack Text
name') forall b c a. (b -> c) -> (a -> b) -> a -> c
. Configuration -> [Char]
path)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
path'
  [Char] -> Initialise ()
r [Char]
path'
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
removeDirectoryRecursive forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char]
replaceBaseName [Char]
"initialise" [Char]
path'

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

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

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