hpack-0.39.6: src/Hpack.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
module Hpack (
-- | /__NOTE:__/ This module is exposed to allow integration of Hpack into
-- other tools.  It is not meant for general use by end users.  The following
-- caveats apply:
--
-- * The API is undocumented, consult the source instead.
--
-- * The exposed types and functions primarily serve Hpack's own needs, not
-- that of a public API.  Breaking changes can happen as Hpack evolves.
--
-- As an Hpack user you either want to use the @hpack@ executable or a build
-- tool that supports Hpack (e.g. @stack@ or @cabal2nix@).

-- * Version
  version

-- * Running Hpack
, hpack
, hpackResult
, hpackResultWithError
, printResult
, Result(..)
, Status(..)

-- * Options
, defaultOptions
, setProgramName
, setTarget
, setDecode
, setFormatYamlParseError
, getOptions
, Verbose(..)
, Options(..)
, Force(..)
, GenerateHashStrategy(..)
, OutputStrategy(..)

#ifdef TEST
, hpackResultWithVersion
, header
, renderCabalFile
#endif
) where

import           Imports

import           Data.Version (Version)
import qualified Data.Version as Version
import           System.FilePath
import           System.Environment
import           System.Exit
import           System.IO (stderr)
import           Data.Aeson (Value)
import           Data.Maybe

import           Paths_hpack (version)
import           Hpack.Options
import           Hpack.Config
import           Hpack.Error (HpackError, formatHpackError)
import           Hpack.Render
import           Hpack.Util
import           Hpack.Utf8 as Utf8
import           Hpack.CabalFile
import qualified Data.Yaml as Yaml

programVersion :: Maybe Version -> String
programVersion Nothing = "hpack"
programVersion (Just v) = "hpack version " ++ Version.showVersion v

header :: FilePath -> Maybe Version -> (Maybe Hash) -> [String]
header p v hash = [
    "-- This file has been generated from " ++ takeFileName p ++ " by " ++ programVersion v ++ "."
  , "--"
  , "-- see: https://github.com/sol/hpack"
  ] ++ case hash of
    Just h -> ["--" , "-- hash: " ++ h, ""]
    Nothing -> [""]

data Options = Options {
  optionsDecodeOptions :: DecodeOptions
, optionsForce :: Force
, optionsGenerateHashStrategy :: GenerateHashStrategy
, optionsToStdout :: Bool
, optionsOutputStrategy :: OutputStrategy
}

data GenerateHashStrategy = ForceHash | ForceNoHash | PreferHash | PreferNoHash
  deriving (Eq, Show)

getOptions :: FilePath -> [String] -> IO (Maybe (Verbose, Options))
getOptions defaultPackageConfig args = do
  result <- parseOptions defaultPackageConfig args
  case result of
    PrintVersion -> do
      putStrLn (programVersion $ Just version)
      return Nothing
    PrintNumericVersion -> do
      putStrLn (Version.showVersion version)
      return Nothing
    Help -> do
      printHelp
      return Nothing
    Run (ParseOptions verbose force hash toStdout file outputStrategy) -> do
      let generateHash = case hash of
            Just True -> ForceHash
            Just False -> ForceNoHash
            Nothing -> PreferNoHash
      return $ Just (verbose, Options defaultDecodeOptions {decodeOptionsTarget = file} force generateHash toStdout outputStrategy)
    ParseError -> do
      printHelp
      exitFailure

printHelp :: IO ()
printHelp = do
  name <- getProgName
  Utf8.hPutStrLn stderr $ unlines [
      "Usage: " ++ name ++ " [ --silent ] [ --canonical ] [ --force | -f ] [ --[no-]hash ] [ PATH ] [ - ]"
    , "       " ++ name ++ " --version"
    , "       " ++ name ++ " --numeric-version"
    , "       " ++ name ++ " --help"
    ]

hpack :: Verbose -> Options -> IO ()
hpack verbose options = hpackResult options >>= printResult verbose

defaultOptions :: Options
defaultOptions = Options defaultDecodeOptions NoForce PreferNoHash False MinimizeDiffs

setTarget :: FilePath -> Options -> Options
setTarget target options@Options{..} =
  options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsTarget = target}}

setProgramName :: ProgramName -> Options -> Options
setProgramName name options@Options{..} =
  options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsProgramName = name}}

setDecode :: (FilePath -> IO (Either String ([String], Value))) -> Options -> Options
setDecode decode options@Options{..} =
  options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsDecode = decode}}

-- | This is used to format any `Yaml.ParseException`s encountered during
-- decoding of <https://github.com/sol/hpack#defaults defaults>.
--
-- Note that:
--
-- 1. This is not used to format `Yaml.ParseException`s encountered during
-- decoding of the main @package.yaml@.  To customize this you have to set a
-- custom decode function.
--
-- 2. Some of the constructors of `Yaml.ParseException` are never produced by
-- Hpack (e.g. `Yaml.AesonException` as Hpack uses it's own mechanism to decode
-- `Yaml.Value`s).
--
-- Example:
--
-- @
-- example :: IO (Either `HpackError` `Result`)
-- example = `hpackResultWithError` options
--   where
--     options :: `Options`
--     options = setCustomYamlParseErrorFormat format `defaultOptions`
--
--     format :: FilePath -> `Yaml.ParseException` -> String
--     format file err = file ++ ": " ++ displayException err
--
-- setCustomYamlParseErrorFormat :: (FilePath -> `Yaml.ParseException` -> String) -> `Options` -> `Options`
-- setCustomYamlParseErrorFormat format = `setDecode` decode >>> `setFormatYamlParseError` format
--   where
--     decode :: FilePath -> IO (Either String ([String], Value))
--     decode file = first (format file) \<$> `Hpack.Yaml.decodeYamlWithParseError` file
-- @
setFormatYamlParseError :: (FilePath -> Yaml.ParseException -> String) -> Options -> Options
setFormatYamlParseError formatYamlParseError options@Options{..} =
  options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsFormatYamlParseError = formatYamlParseError}}

data Result = Result {
  resultWarnings :: [String]
, resultCabalFile :: String
, resultStatus :: Status
} deriving (Eq, Show)

data Status =
    Generated
  | ExistingCabalFileWasModifiedManually
  | AlreadyGeneratedByNewerHpack
  | OutputUnchanged
  deriving (Eq, Show)

printResult :: Verbose -> Result -> IO ()
printResult verbose r = do
  printWarnings (resultWarnings r)
  when (verbose == Verbose) $ putStrLn $
    case resultStatus r of
      Generated -> "generated " ++ resultCabalFile r
      OutputUnchanged -> resultCabalFile r ++ " is up-to-date"
      AlreadyGeneratedByNewerHpack -> resultCabalFile r ++ " was generated with a newer version of hpack, please upgrade and try again."
      ExistingCabalFileWasModifiedManually -> resultCabalFile r ++ " was modified manually, please use --force to overwrite."
  case resultStatus r of
      Generated -> return ()
      OutputUnchanged -> return ()
      AlreadyGeneratedByNewerHpack -> exitFailure
      ExistingCabalFileWasModifiedManually -> exitFailure

printWarnings :: [String] -> IO ()
printWarnings = mapM_ $ Utf8.hPutStrLn stderr . ("WARNING: " ++)

mkStatus :: NewCabalFile -> ExistingCabalFile -> Status
mkStatus new@(CabalFile _ mNewVersion mNewHash _ _) existing@(CabalFile _ mExistingVersion _ _ _)
  | new `hasSameContent` existing = OutputUnchanged
  | otherwise = case mExistingVersion of
      Nothing -> ExistingCabalFileWasModifiedManually
      Just _
        | mNewVersion < mExistingVersion -> AlreadyGeneratedByNewerHpack
        | isJust mNewHash && hashMismatch existing -> ExistingCabalFileWasModifiedManually
        | otherwise -> Generated

hasSameContent :: NewCabalFile -> ExistingCabalFile -> Bool
hasSameContent (CabalFile cabalVersionA _ _ a ()) (CabalFile cabalVersionB _ _ b gitConflictMarkers) =
     cabalVersionA == cabalVersionB
  && a == b
  && gitConflictMarkers == DoesNotHaveGitConflictMarkers

hashMismatch :: ExistingCabalFile -> Bool
hashMismatch cabalFile = case cabalFileHash cabalFile of
  Nothing -> False
  Just hash -> cabalFileGitConflictMarkers cabalFile == HasGitConflictMarkers || hash /= calculateHash cabalFile

calculateHash :: CabalFile a -> Hash
calculateHash (CabalFile cabalVersion _ _ body _) = sha256 (unlines $ cabalVersion ++ body)

hpackResult :: Options -> IO Result
hpackResult opts = hpackResultWithError opts >>= either (die . formatHpackError programName) return
  where
    programName = decodeOptionsProgramName (optionsDecodeOptions opts)

hpackResultWithError :: Options -> IO (Either HpackError Result)
hpackResultWithError = hpackResultWithVersion version

hpackResultWithVersion :: Version -> Options -> IO (Either HpackError Result)
hpackResultWithVersion v (Options options force generateHashStrategy toStdout outputStrategy) = do
  readPackageConfigWithError options >>= \ case
    Right (DecodeResult pkg (lines -> cabalVersion) cabalFileName warnings) -> do
      mExistingCabalFile <- readCabalFile cabalFileName
      let
        newCabalFile = makeCabalFile outputStrategy generateHashStrategy mExistingCabalFile cabalVersion v pkg

        status = case force of
          Force -> Generated
          NoForce -> maybe Generated (mkStatus newCabalFile) mExistingCabalFile

      case status of
        Generated -> writeCabalFile options toStdout cabalFileName newCabalFile
        _ -> return ()

      return $ Right Result {
        resultWarnings = warnings
      , resultCabalFile = cabalFileName
      , resultStatus = status
      }
    Left err -> return $ Left err

writeCabalFile :: DecodeOptions -> Bool -> FilePath -> NewCabalFile -> IO ()
writeCabalFile options toStdout name cabalFile = do
  write . unlines $ renderCabalFile (decodeOptionsTarget options) cabalFile
  where
    write = if toStdout then Utf8.putStr else Utf8.ensureFile name

makeCabalFile :: OutputStrategy -> GenerateHashStrategy -> Maybe ExistingCabalFile -> [String] -> Version -> Package -> NewCabalFile
makeCabalFile outputStrategy generateHashStrategy mExistingCabalFile cabalVersion v pkg = cabalFile
  where
    hints :: [String]
    hints = case outputStrategy of
      CanonicalOutput -> []
      MinimizeDiffs -> maybe [] cabalFileContents mExistingCabalFile

    cabalFile :: NewCabalFile
    cabalFile = CabalFile cabalVersion (Just v) hash body ()

    hash :: Maybe Hash
    hash
      | shouldGenerateHash mExistingCabalFile generateHashStrategy = Just $ calculateHash cabalFile
      | otherwise = Nothing

    body :: [String]
    body = lines $ renderPackage hints pkg

shouldGenerateHash :: Maybe ExistingCabalFile -> GenerateHashStrategy -> Bool
shouldGenerateHash mExistingCabalFile strategy = case (strategy, mExistingCabalFile) of
  (ForceHash, _) -> True
  (ForceNoHash, _) -> False
  (PreferHash, Nothing) -> True
  (PreferNoHash, Nothing) -> False
  (_, Just CabalFile {cabalFileHash = Nothing}) -> False
  (_, Just CabalFile {cabalFileHash = Just _}) -> True

renderCabalFile :: FilePath -> NewCabalFile -> [String]
renderCabalFile file (CabalFile cabalVersion hpackVersion hash body _) = cabalVersion ++ header file hpackVersion hash ++ body