FileCreators.hs 20.6 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
-----------------------------------------------------------------------------
-- |
-- 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
  ) where

import Prelude ()
import Distribution.Client.Compat.Prelude hiding (empty)

import System.FilePath
  ( (</>), (<.>), takeExtension )

import Control.Monad
  ( forM_ )
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(..) )

Oleg Grenrus's avatar
Oleg Grenrus committed
52
import Distribution.CabalSpecVersion
53 54 55
import Distribution.Deprecated.Text
  ( display, Text(..) )
import Distribution.License
Oleg Grenrus's avatar
Oleg Grenrus committed
56
  ( licenseFromSPDX )
57 58 59 60 61 62 63 64 65 66
import qualified Distribution.ModuleName as ModuleName
  ( toFilePath )
import qualified Distribution.Package as P
  ( unPackageName )
import Distribution.Simple.Setup
  ( Flag(..), flagToMaybe )
import Distribution.Simple.Utils
  ( dropWhileEndLE )
import Distribution.Pretty
  ( prettyShow )
Oleg Grenrus's avatar
Oleg Grenrus committed
67 68

import qualified Distribution.SPDX as SPDX
69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87


---------------------------------------------------------------------------
--  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
Oleg Grenrus's avatar
Oleg Grenrus committed
88 89 90
  let isSimpleLicense :: SPDX.License -> Maybe SPDX.LicenseId
      isSimpleLicense (SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) = Just lid
      isSimpleLicense _                                                            = Nothing
91
  let licenseFile =
Oleg Grenrus's avatar
Oleg Grenrus committed
92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112
        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
113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339

          _ -> 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 "" display $ flagToMaybe $ packageName flags
  pver = maybe "" display $ 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 = display 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 -> forM_ 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 "" = ""
    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.  NOTE: this
--   is rather ad-hoc!  What we would REALLY like is to have a
--   standard low-level AST type representing .cabal files, which
--   preserves things like comments, and to write an *inverse*
--   parser/pretty-printer pair between .cabal files and this AST.
--   Then instead of this ad-hoc code we could just map an InitFlags
--   structure onto a low-level AST structure and use the existing
--   pretty-printing code to generate the file.
generateCabalFile :: String -> InitFlags -> String
generateCabalFile fileName c = trimTrailingWS $
  (++ "\n") .
  renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $
  -- Starting with 2.2 the `cabal-version` field needs to be the first line of the PD
Oleg Grenrus's avatar
Oleg Grenrus committed
340 341 342 343 344
  (if specVer < CabalSpecV1_12
   then fieldS "cabal-version" (Flag $ ">=" ++ showCabalSpecVersion specVer)
   else fieldS "cabal-version" (Flag $ showCabalSpecVersion specVer))
      Nothing
      False
345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383
  $$
  (if minimal c /= Flag True
    then showComment (Just $ "Initial package description '" ++ fileName ++ "' generated "
                          ++ "by 'cabal init'.  For further documentation, see "
                          ++ "http://haskell.org/cabal/users-guide/")
         $$ text ""
    else empty)
  $$
  vcat [ field  "name"          (packageName   c)
                (Just "The name of the package.")
                True

       , field  "version"       (version       c)
                (Just $ "The package version.  See the Haskell package versioning policy (PVP) for standards guiding when and how versions should be incremented.\nhttps://pvp.haskell.org\n"
                ++ "PVP summary:      +-+------- breaking API changes\n"
                ++ "                  | | +----- non-breaking API additions\n"
                ++ "                  | | | +--- code changes with no API change")
                True

       , fieldS "synopsis"      (synopsis      c)
                (Just "A short (one-line) description of the package.")
                True

       , fieldS "description"   NoFlag
                (Just "A longer description of the package.")
                True

       , fieldS "homepage"      (homepage     c)
                (Just "URL for the project homepage or repository.")
                False

       , fieldS "bug-reports"   NoFlag
                (Just "A URL where users can report bugs.")
                True

       , fieldS  "license"      licenseStr
                (Just "The license under which the package is released.")
                True

Oleg Grenrus's avatar
Oleg Grenrus committed
384 385 386
       , case license c of
           NoFlag         -> empty
           Flag SPDX.NONE -> empty
387 388 389 390 391 392 393 394 395 396 397 398
           _ -> fieldS "license-file" (Flag "LICENSE")
                       (Just "The file containing the license text.")
                       True

       , fieldS "author"        (author       c)
                (Just "The package author(s).")
                True

       , fieldS "maintainer"    (email        c)
                (Just "An email address to which users can send suggestions, bug reports, and patches.")
                True

Oleg Grenrus's avatar
Oleg Grenrus committed
399 400 401
       , fieldS "copyright"     NoFlag
                (Just "A copyright notice.")
                True
402 403 404 405 406

       , fieldS "category"      (either id display `fmap` category c)
                Nothing
                True

Oleg Grenrus's avatar
Oleg Grenrus committed
407
       , fieldS "build-type"    (if specVer >= CabalSpecV2_2 then NoFlag else Flag "Simple")
408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425
                Nothing
                False

       , fieldS "extra-source-files" (listFieldS (extraSrc c))
                (Just "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
           _               -> empty

       , if eligibleForTestSuite c then testSuiteStanza else empty
       ]
 where
   specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c)

Oleg Grenrus's avatar
Oleg Grenrus committed
426 427
   licenseStr | specVer < CabalSpecV2_2 = prettyShow . licenseFromSPDX <$> license c
              | otherwise               = prettyShow                   <$> license c
428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564

   generateBuildInfo :: BuildType -> InitFlags -> Doc
   generateBuildInfo buildType c' = vcat
     [ fieldS "other-modules" (listField otherMods)
              (Just $ case buildType of
                 LibBuild    -> "Modules included in this library but not exported."
                 ExecBuild -> "Modules included in this executable, other than Main.")
              True

     , fieldS "other-extensions" (listField (otherExts c'))
              (Just "LANGUAGE extensions used by modules in this package.")
              True

     , fieldS "build-depends" ((++ myLibDep) <$> listField (dependencies c'))
              (Just "Other library packages from which modules are imported.")
              True

     , fieldS "hs-source-dirs" (listFieldS (case buildType of
                                            LibBuild  -> sourceDirs c'
                                            ExecBuild -> applicationDirs c'))
              (Just "Directories containing source files.")
              True

     , fieldS "build-tools" (listFieldS (buildTools c'))
              (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.")
              False

     , field  "default-language" (language c')
              (Just "Base language which the package is written in.")
              True
     ]
     -- Hack: Can't construct a 'Dependency' which is just 'packageName'(?).
     where
       myLibDep = if exposedModules c' == Just [myLibModule] && buildType == ExecBuild
                      then case packageName c' of
                             Flag pkgName -> ", " ++ P.unPackageName pkgName
                             _ -> ""
                      else ""

       -- Only include 'MyLib' in 'other-modules' of the executable.
       otherModsFromFlag = otherModules c'
       otherMods = if buildType == LibBuild && otherModsFromFlag == Just [myLibModule]
                   then Nothing
                   else otherModsFromFlag

   listField :: Text s => Maybe [s] -> Flag String
   listField = listFieldS . fmap (map display)

   listFieldS :: Maybe [String] -> Flag String
   listFieldS = Flag . maybe "" (intercalate ", ")

   field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc
   field s f = fieldS s (fmap display f)

   fieldS :: String        -- ^ Name of the field
          -> Flag String   -- ^ Field contents
          -> Maybe String  -- ^ Comment to explain the field
          -> Bool          -- ^ Should the field be included (commented out) even if blank?
          -> Doc
   fieldS _ NoFlag _    inc | not inc || (minimal c == Flag True) = empty
   fieldS _ (Flag "") _ inc | not inc || (minimal c == Flag True) = empty
   fieldS s f com _ = case (isJust com, noComments c, minimal c) of
                        (_, _, Flag True) -> id
                        (_, Flag True, _) -> id
                        (True, _, _)      -> (showComment com $$) . ($$ text "")
                        (False, _, _)     -> ($$ text "")
                      $
                      comment f <<>> text s <<>> colon
                                <<>> text (replicate (20 - length s) ' ')
                                <<>> text (fromMaybe "" . flagToMaybe $ f)
   comment NoFlag    = text "-- "
   comment (Flag "") = text "-- "
   comment _         = text ""

   showComment :: Maybe String -> Doc
   showComment (Just t) = vcat
                        . map (text . ("-- "++)) . lines
                        . renderStyle style {
                            lineLength = 76,
                            ribbonsPerLine = 1.05
                          }
                        . vcat
                        . map (fcat . map text . breakLine)
                        . lines
                        $ t
   showComment Nothing  = text ""

   breakLine  [] = []
   breakLine  cs = case break (==' ') cs of (w,cs') -> w : breakLine' cs'
   breakLine' [] = []
   breakLine' cs = case span (==' ') cs of (w,cs') -> w : breakLine cs'

   trimTrailingWS :: String -> String
   trimTrailingWS = unlines . map (dropWhileEndLE isSpace) . lines

   executableStanza :: Doc
   executableStanza = text "\nexecutable" <+>
             text (maybe "" display . flagToMaybe $ packageName c) $$
             nest 2 (vcat
             [ fieldS "main-is" (mainIs c) (Just ".hs or .lhs file containing the Main module.") True

             , generateBuildInfo ExecBuild c
             ])

   libraryStanza :: Doc
   libraryStanza = text "\nlibrary" $$ nest 2 (vcat
             [ fieldS "exposed-modules" (listField (exposedModules c))
                      (Just "Modules exported by the library.")
                      True

             , generateBuildInfo LibBuild c
             ])

   testSuiteStanza :: Doc
   testSuiteStanza = text "\ntest-suite" <+>
     text (maybe "" ((++"-test") . display) . flagToMaybe $ packageName c) $$
     nest 2 (vcat
             [ field  "default-language" (language c)
               (Just "Base language which the package is written in.")
               True

             , fieldS "type" (Flag "exitcode-stdio-1.0")
               (Just "The interface type and version of the test suite.")
               True

             , fieldS "hs-source-dirs" (listFieldS (testDirs c))
               (Just "The directory where the test specifications are found.")
               True

             , fieldS "main-is" (Flag testFile)
               (Just "The entrypoint to the test suite.")
               True

             , fieldS "build-depends" (listField (dependencies c))
               (Just "Test dependencies.")
               True
             ])