hackport-0.6.6: cabal/cabal-install/Distribution/Client/Init/FileCreators.hs
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Init.FileCreators
-- Copyright : (c) Brent Yorgey 2009
-- License : BSD-like
--
-- Maintainer : cabal-devel@haskell.org
-- Stability : provisional
-- Portability : portable
--
-- Functions to create files during 'cabal init'.
--
-----------------------------------------------------------------------------
module Distribution.Client.Init.FileCreators (
-- * Commands
writeLicense
, writeChangeLog
, createDirectories
, createLibHs
, createMainHs
, createTestSuiteIfEligible
, writeCabalFile
-- * For testing
, generateCabalFile
) where
import Prelude ()
import Distribution.Client.Compat.Prelude hiding (empty)
import System.FilePath
( (</>), (<.>), takeExtension )
import Distribution.Types.Dependency
import Distribution.Types.VersionRange
import Data.Time
( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )
import System.Directory
( getCurrentDirectory, doesFileExist, copyFile
, createDirectoryIfMissing )
import Text.PrettyPrint hiding ((<>), mode, cat)
import Distribution.Client.Init.Defaults
( defaultCabalVersion, myLibModule )
import Distribution.Client.Init.Licenses
( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc )
import Distribution.Client.Init.Utils
( eligibleForTestSuite, message )
import Distribution.Client.Init.Types
( InitFlags(..), BuildType(..), PackageType(..) )
import Distribution.CabalSpecVersion
import Distribution.Compat.Newtype
( Newtype )
import Distribution.Fields.Field
( FieldName )
import Distribution.License
( licenseFromSPDX )
import qualified Distribution.ModuleName as ModuleName
( toFilePath )
import Distribution.FieldGrammar.Newtypes
( SpecVersion(..) )
import Distribution.PackageDescription.FieldGrammar
( formatDependencyList, formatExposedModules, formatHsSourceDirs,
formatOtherExtensions, formatOtherModules, formatExtraSourceFiles )
import Distribution.Simple.Flag
( maybeToFlag )
import Distribution.Simple.Setup
( Flag(..), flagToMaybe )
import Distribution.Simple.Utils
( toUTF8BS )
import Distribution.Fields.Pretty
( PrettyField(..), showFields' )
import qualified Distribution.SPDX as SPDX
---------------------------------------------------------------------------
-- File generation ------------------------------------------------------
---------------------------------------------------------------------------
-- | Write the LICENSE file, as specified in the InitFlags license field.
--
-- For licences that contain the author's name(s), the values are taken
-- from the 'authors' field of 'InitFlags', and if not specified will
-- be the string "???".
--
-- If the license type is unknown no license file will be created and
-- a warning will be raised.
writeLicense :: InitFlags -> IO ()
writeLicense flags = do
message flags "\nGenerating LICENSE..."
year <- show <$> getCurrentYear
let authors = fromMaybe "???" . flagToMaybe . author $ flags
let isSimpleLicense :: SPDX.License -> Maybe SPDX.LicenseId
isSimpleLicense (SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) = Just lid
isSimpleLicense _ = Nothing
let licenseFile =
case flagToMaybe (license flags) >>= isSimpleLicense of
Just SPDX.BSD_2_Clause -> Just $ bsd2 authors year
Just SPDX.BSD_3_Clause -> Just $ bsd3 authors year
Just SPDX.Apache_2_0 -> Just apache20
Just SPDX.MIT -> Just $ mit authors year
Just SPDX.MPL_2_0 -> Just mpl20
Just SPDX.ISC -> Just $ isc authors year
-- GNU license come in "only" and "or-later" flavours
-- license file used are the same.
Just SPDX.GPL_2_0_only -> Just gplv2
Just SPDX.GPL_3_0_only -> Just gplv3
Just SPDX.LGPL_2_1_only -> Just lgpl21
Just SPDX.LGPL_3_0_only -> Just lgpl3
Just SPDX.AGPL_3_0_only -> Just agplv3
Just SPDX.GPL_2_0_or_later -> Just gplv2
Just SPDX.GPL_3_0_or_later -> Just gplv3
Just SPDX.LGPL_2_1_or_later -> Just lgpl21
Just SPDX.LGPL_3_0_or_later -> Just lgpl3
Just SPDX.AGPL_3_0_or_later -> Just agplv3
_ -> Nothing
case licenseFile of
Just licenseText -> writeFileSafe flags "LICENSE" licenseText
Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself."
-- | Returns the current calendar year.
getCurrentYear :: IO Integer
getCurrentYear = do
u <- getCurrentTime
z <- getCurrentTimeZone
let l = utcToLocalTime z u
(y, _, _) = toGregorian $ localDay l
return y
defaultChangeLog :: FilePath
defaultChangeLog = "CHANGELOG.md"
-- | Writes the changelog to the current directory.
writeChangeLog :: InitFlags -> IO ()
writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do
message flags ("Generating "++ defaultChangeLog ++"...")
writeFileSafe flags defaultChangeLog changeLog
where
changeLog = unlines
[ "# Revision history for " ++ pname
, ""
, "## " ++ pver ++ " -- YYYY-mm-dd"
, ""
, "* First version. Released on an unsuspecting world."
]
pname = maybe "" prettyShow $ flagToMaybe $ packageName flags
pver = maybe "" prettyShow $ flagToMaybe $ version flags
-- | Creates and writes the initialized .cabal file.
--
-- Returns @False@ if no package name is specified, @True@ otherwise.
writeCabalFile :: InitFlags -> IO Bool
writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do
message flags "Error: no package name provided."
return False
writeCabalFile flags@(InitFlags{packageName = Flag p}) = do
let cabalFileName = prettyShow p ++ ".cabal"
message flags $ "Generating " ++ cabalFileName ++ "..."
writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags)
return True
-- | Write a file \"safely\", backing up any existing version (unless
-- the overwrite flag is set).
writeFileSafe :: InitFlags -> FilePath -> String -> IO ()
writeFileSafe flags fileName content = do
moveExistingFile flags fileName
writeFile fileName content
-- | Create directories, if they were given, and don't already exist.
createDirectories :: Maybe [String] -> IO ()
createDirectories mdirs = case mdirs of
Just dirs -> for_ dirs (createDirectoryIfMissing True)
Nothing -> return ()
-- | Create MyLib.hs file, if its the only module in the liste.
createLibHs :: InitFlags -> IO ()
createLibHs flags = when ((exposedModules flags) == Just [myLibModule]) $ do
let modFilePath = ModuleName.toFilePath myLibModule ++ ".hs"
case sourceDirs flags of
Just (srcPath:_) -> writeLibHs flags (srcPath </> modFilePath)
_ -> writeLibHs flags modFilePath
-- | Write a MyLib.hs file if it doesn't already exist.
writeLibHs :: InitFlags -> FilePath -> IO ()
writeLibHs flags libPath = do
dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)
let libFullPath = dir </> libPath
exists <- doesFileExist libFullPath
unless exists $ do
message flags $ "Generating " ++ libPath ++ "..."
writeFileSafe flags libFullPath myLibHs
-- | Default MyLib.hs file. Used when no Lib.hs exists.
myLibHs :: String
myLibHs = unlines
[ "module MyLib (someFunc) where"
, ""
, "someFunc :: IO ()"
, "someFunc = putStrLn \"someFunc\""
]
-- | Create Main.hs, but only if we are init'ing an executable and
-- the mainIs flag has been provided.
createMainHs :: InitFlags -> IO ()
createMainHs flags =
if hasMainHs flags then
case applicationDirs flags of
Just (appPath:_) -> writeMainHs flags (appPath </> mainFile)
_ -> writeMainHs flags mainFile
else return ()
where
mainFile = case mainIs flags of
Flag x -> x
NoFlag -> error "createMainHs: no mainIs"
-- | Write a main file if it doesn't already exist.
writeMainHs :: InitFlags -> FilePath -> IO ()
writeMainHs flags mainPath = do
dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)
let mainFullPath = dir </> mainPath
exists <- doesFileExist mainFullPath
unless exists $ do
message flags $ "Generating " ++ mainPath ++ "..."
writeFileSafe flags mainFullPath (mainHs flags)
-- | Returns true if a main file exists.
hasMainHs :: InitFlags -> Bool
hasMainHs flags = case mainIs flags of
Flag _ -> (packageType flags == Flag Executable
|| packageType flags == Flag LibraryAndExecutable)
_ -> False
-- | Default Main.(l)hs file. Used when no Main.(l)hs exists.
--
-- If we are initializing a new 'LibraryAndExecutable' then import 'MyLib'.
mainHs :: InitFlags -> String
mainHs flags = (unlines . map prependPrefix) $ case packageType flags of
Flag LibraryAndExecutable ->
[ "module Main where"
, ""
, "import qualified MyLib (someFunc)"
, ""
, "main :: IO ()"
, "main = do"
, " putStrLn \"Hello, Haskell!\""
, " MyLib.someFunc"
]
_ ->
[ "module Main where"
, ""
, "main :: IO ()"
, "main = putStrLn \"Hello, Haskell!\""
]
where
prependPrefix :: String -> String
prependPrefix "" = ""
prependPrefix line
| isLiterate = "> " ++ line
| otherwise = line
isLiterate = case mainIs flags of
Flag mainPath -> takeExtension mainPath == ".lhs"
_ -> False
-- | Create a test suite for the package if eligible.
createTestSuiteIfEligible :: InitFlags -> IO ()
createTestSuiteIfEligible flags =
when (eligibleForTestSuite flags) $ do
createDirectories (testDirs flags)
createTestHs flags
-- | The name of the test file to generate (if --tests is specified).
testFile :: String
testFile = "MyLibTest.hs"
-- | Create MyLibTest.hs, but only if we are init'ing a library and
-- the initializeTestSuite flag has been set.
--
-- It is up to the caller to verify that the package is eligible
-- for test suite initialization (see eligibleForTestSuite).
createTestHs :: InitFlags -> IO ()
createTestHs flags =
case testDirs flags of
Just (testPath:_) -> writeTestHs flags (testPath </> testFile)
_ -> writeMainHs flags testFile
-- | Write a test file.
writeTestHs :: InitFlags -> FilePath -> IO ()
writeTestHs flags testPath = do
dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)
let testFullPath = dir </> testPath
exists <- doesFileExist testFullPath
unless exists $ do
message flags $ "Generating " ++ testPath ++ "..."
writeFileSafe flags testFullPath testHs
-- | Default MyLibTest.hs file.
testHs :: String
testHs = unlines
[ "module Main (main) where"
, ""
, "main :: IO ()"
, "main = putStrLn \"Test suite not yet implemented.\""
]
-- | Move an existing file, if there is one, and the overwrite flag is
-- not set.
moveExistingFile :: InitFlags -> FilePath -> IO ()
moveExistingFile flags fileName =
unless (overwrite flags == Flag True) $ do
e <- doesFileExist fileName
when e $ do
newName <- findNewName fileName
message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName
copyFile fileName newName
-- | Given a file path find a new name for the file that does not
-- already exist.
findNewName :: FilePath -> IO FilePath
findNewName oldName = findNewName' 0
where
findNewName' :: Integer -> IO FilePath
findNewName' n = do
let newName = oldName <.> ("save" ++ show n)
e <- doesFileExist newName
if e then findNewName' (n+1) else return newName
-- | Generate a .cabal file from an InitFlags structure.
generateCabalFile :: String -> InitFlags -> String
generateCabalFile fileName c =
showFields' annCommentLines postProcessFieldLines 4 $ catMaybes
[ fieldP "cabal-version" (Flag . SpecVersion $ specVer)
[]
False
, field "name" (packageName c)
["Initial package description '" ++ fileName ++ "' generated by",
"'cabal init'. For further documentation, see:",
" http://haskell.org/cabal/users-guide/",
"",
"The name of the package."]
True
, field "version" (version c)
["The package version.",
"See the Haskell package versioning policy (PVP) for standards",
"guiding when and how versions should be incremented.",
"https://pvp.haskell.org",
"PVP summary: +-+------- breaking API changes",
" | | +----- non-breaking API additions",
" | | | +--- code changes with no API change"]
True
, fieldS "synopsis" (synopsis c)
["A short (one-line) description of the package."]
True
, fieldS "description" NoFlag
["A longer description of the package."]
True
, fieldS "homepage" (homepage c)
["URL for the project homepage or repository."]
False
, fieldS "bug-reports" NoFlag
["A URL where users can report bugs."]
True
, fieldS "license" licenseStr
["The license under which the package is released."]
True
, case license c of
NoFlag -> Nothing
Flag SPDX.NONE -> Nothing
_ -> fieldS "license-file" (Flag "LICENSE")
["The file containing the license text."]
True
, fieldS "author" (author c)
["The package author(s)."]
True
, fieldS "maintainer" (email c)
["An email address to which users can send suggestions, bug reports, and patches."]
True
, fieldS "copyright" NoFlag
["A copyright notice."]
True
, fieldS "category" (either id prettyShow `fmap` category c)
[]
True
, fieldS "build-type" (if specVer >= CabalSpecV2_2 then NoFlag else Flag "Simple")
[]
False
, fieldPAla "extra-source-files" formatExtraSourceFiles (maybeToFlag (extraSrc c))
["Extra files to be distributed with the package, such as examples or a README."]
True
]
++
(case packageType c of
Flag Executable -> [executableStanza]
Flag Library -> [libraryStanza]
Flag LibraryAndExecutable -> [libraryStanza, executableStanza]
_ -> [])
++
if eligibleForTestSuite c then [testSuiteStanza] else []
where
specVer :: CabalSpecVersion
specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c)
licenseStr | specVer < CabalSpecV2_2 = prettyShow . licenseFromSPDX <$> license c
| otherwise = prettyShow <$> license c
generateBuildInfo :: BuildType -> InitFlags -> [PrettyField FieldAnnotation]
generateBuildInfo buildType c' = catMaybes
[ fieldPAla "other-modules" formatOtherModules (maybeToFlag otherMods)
[ case buildType of
LibBuild -> "Modules included in this library but not exported."
ExecBuild -> "Modules included in this executable, other than Main."]
True
, fieldPAla "other-extensions" formatOtherExtensions (maybeToFlag (otherExts c))
["LANGUAGE extensions used by modules in this package."]
True
, fieldPAla "build-depends" formatDependencyList (maybeToFlag buildDependencies)
["Other library packages from which modules are imported."]
True
, fieldPAla "hs-source-dirs" formatHsSourceDirs
(maybeToFlag (case buildType of
LibBuild -> sourceDirs c
ExecBuild -> applicationDirs c))
["Directories containing source files."]
True
, fieldS "build-tools" (listFieldS $ buildTools c)
["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]
False
, field "default-language" (language c)
["Base language which the package is written in."]
True
]
-- Hack: Can't construct a 'Dependency' which is just 'packageName'(?).
where
buildDependencies :: Maybe [Dependency]
buildDependencies = (++ myLibDep) <$> dependencies c'
myLibDep :: [Dependency]
myLibDep = if exposedModules c' == Just [myLibModule] && buildType == ExecBuild
then case packageName c' of
Flag pkgName ->
[mkDependency pkgName anyVersion mainLibSet]
_ -> []
else []
-- Only include 'MyLib' in 'other-modules' of the executable.
otherModsFromFlag = otherModules c'
otherMods = if buildType == LibBuild && otherModsFromFlag == Just [myLibModule]
then Nothing
else otherModsFromFlag
listFieldS :: Maybe [String] -> Flag String
listFieldS Nothing = NoFlag
listFieldS (Just []) = NoFlag
listFieldS (Just xs) = Flag . intercalate ", " $ xs
-- | Construct a 'PrettyField' from a field that can be automatically
-- converted to a 'Doc' via 'display'.
field :: Pretty t
=> FieldName
-> Flag t
-> [String]
-> Bool
-> Maybe (PrettyField FieldAnnotation)
field fieldName fieldContentsFlag = fieldS fieldName (prettyShow <$> fieldContentsFlag)
-- | Construct a 'PrettyField' from a 'String' field.
fieldS :: FieldName -- ^ Name of the field
-> Flag String -- ^ Field contents
-> [String] -- ^ Comment to explain the field
-> Bool -- ^ Should the field be included (commented out) even if blank?
-> Maybe (PrettyField FieldAnnotation)
fieldS fieldName fieldContentsFlag = fieldD fieldName (text <$> fieldContentsFlag)
-- | Construct a 'PrettyField' from a Flag which can be 'pretty'-ied.
fieldP :: Pretty a
=> FieldName
-> Flag a
-> [String]
-> Bool
-> Maybe (PrettyField FieldAnnotation)
fieldP fieldName fieldContentsFlag fieldComments includeField =
fieldPAla fieldName Identity fieldContentsFlag fieldComments includeField
-- | Construct a 'PrettyField' from a flag which can be 'pretty'-ied, wrapped in newtypeWrapper.
fieldPAla
:: (Pretty b, Newtype a b)
=> FieldName
-> (a -> b)
-> Flag a
-> [String]
-> Bool
-> Maybe (PrettyField FieldAnnotation)
fieldPAla fieldName newtypeWrapper fieldContentsFlag fieldComments includeField =
fieldD fieldName (pretty . newtypeWrapper <$> fieldContentsFlag) fieldComments includeField
-- | Construct a 'PrettyField' from a 'Doc' Flag.
fieldD :: FieldName -- ^ Name of the field
-> Flag Doc -- ^ Field contents
-> [String] -- ^ Comment to explain the field
-> Bool -- ^ Should the field be included (commented out) even if blank?
-> Maybe (PrettyField FieldAnnotation)
fieldD fieldName fieldContentsFlag fieldComments includeField =
case fieldContentsFlag of
NoFlag ->
-- If there is no content, optionally produce a commented out field.
fieldSEmptyContents fieldName fieldComments includeField
Flag fieldContents ->
if isEmpty fieldContents
then
-- If the doc is empty, optionally produce a commented out field.
fieldSEmptyContents fieldName fieldComments includeField
else
-- If the doc is not empty, produce a field.
Just $ case (noComments c, minimal c) of
-- If the "--no-comments" flag is set, strip comments.
(Flag True, _) ->
fieldSWithContents fieldName fieldContents []
-- If the "--minimal" flag is set, strip comments.
(_, Flag True) ->
fieldSWithContents fieldName fieldContents []
-- Otherwise, include comments.
(_, _) ->
fieldSWithContents fieldName fieldContents fieldComments
-- | Optionally produce a field with no content (depending on flags).
fieldSEmptyContents :: FieldName
-> [String]
-> Bool
-> Maybe (PrettyField FieldAnnotation)
fieldSEmptyContents fieldName fieldComments includeField
| not includeField || (minimal c == Flag True) =
Nothing
| otherwise =
Just (PrettyField (commentedOutWithComments fieldComments) fieldName empty)
-- | Produce a field with content.
fieldSWithContents :: FieldName
-> Doc
-> [String]
-> PrettyField FieldAnnotation
fieldSWithContents fieldName fieldContents fieldComments =
PrettyField (withComments (map ("-- " ++) fieldComments)) fieldName fieldContents
executableStanza :: PrettyField FieldAnnotation
executableStanza = PrettySection annNoComments (toUTF8BS "executable") [exeName] $ catMaybes
[ fieldS "main-is" (mainIs c)
[".hs or .lhs file containing the Main module."]
True
]
++
generateBuildInfo ExecBuild c
where
exeName = text (maybe "" prettyShow . flagToMaybe $ packageName c)
libraryStanza :: PrettyField FieldAnnotation
libraryStanza = PrettySection annNoComments (toUTF8BS "library") [] $ catMaybes
[ fieldPAla "exposed-modules" formatExposedModules (maybeToFlag (exposedModules c))
["Modules exported by the library."]
True
]
++
generateBuildInfo LibBuild c
testSuiteStanza :: PrettyField FieldAnnotation
testSuiteStanza = PrettySection annNoComments (toUTF8BS "test-suite") [testSuiteName] $ catMaybes
[ field "default-language" (language c)
["Base language which the package is written in."]
True
, fieldS "type" (Flag "exitcode-stdio-1.0")
["The interface type and version of the test suite."]
True
, fieldPAla "hs-source-dirs" formatHsSourceDirs
(maybeToFlag (testDirs c))
["Directories containing source files."]
True
, fieldS "main-is" (Flag testFile)
["The entrypoint to the test suite."]
True
, fieldPAla "build-depends" formatDependencyList (maybeToFlag (dependencies c))
["Test dependencies."]
True
]
where
testSuiteName =
text (maybe "" ((++"-test") . prettyShow) . flagToMaybe $ packageName c)
-- | Annotations for cabal file PrettyField.
data FieldAnnotation = FieldAnnotation
{ annCommentedOut :: Bool
-- ^ True iif the field and its contents should be commented out.
, annCommentLines :: [String]
-- ^ Comment lines to place before the field or section.
}
-- | A field annotation instructing the pretty printer to comment out the field
-- and any contents, with no comments.
commentedOutWithComments :: [String] -> FieldAnnotation
commentedOutWithComments = FieldAnnotation True . map ("-- " ++)
-- | A field annotation with the specified comment lines.
withComments :: [String] -> FieldAnnotation
withComments = FieldAnnotation False
-- | A field annotation with no comments.
annNoComments :: FieldAnnotation
annNoComments = FieldAnnotation False []
postProcessFieldLines :: FieldAnnotation -> [String] -> [String]
postProcessFieldLines ann
| annCommentedOut ann = map ("-- " ++)
| otherwise = id