Add command-line options --hash and --no-hash

src/Hpack.hs

@@ -33,6 +33,7 @@ module Hpack (
 , Verbose(..)
 , Options(..)
 , Force(..)
+, GenerateHashStrategy(..)
 
 #ifdef TEST
 , hpackResultWithVersion
@@ -49,6 +50,7 @@ import           System.Environment
 import           System.Exit
 import           System.IO (stderr)
 import           Data.Aeson (Value)
+import           Data.Maybe
 
 import           Paths_hpack (version)
 import           Hpack.Options
@@ -74,9 +76,13 @@ header p v hash = [
 data Options = Options {
   optionsDecodeOptions :: DecodeOptions
 , optionsForce :: Force
+, optionsGenerateHashStrategy :: GenerateHashStrategy
 , optionsToStdout :: Bool
 }
 
+data GenerateHashStrategy = ForceHash | ForceNoHash | PreferHash | PreferNoHash
+  deriving (Eq, Show)
+
 getOptions :: FilePath -> [String] -> IO (Maybe (Verbose, Options))
 getOptions defaultPackageConfig args = do
   result <- parseOptions defaultPackageConfig args
@@ -90,9 +96,12 @@ getOptions defaultPackageConfig args = do
     Help -> do
       printHelp
       return Nothing
-    Run options -> case options of
-      ParseOptions verbose force toStdout file -> do
-        return $ Just (verbose, Options defaultDecodeOptions {decodeOptionsTarget = file} force toStdout)
+    Run (ParseOptions verbose force hash toStdout file) -> do
+      let generateHash = case hash of
+            Just True -> ForceHash
+            Just False -> ForceNoHash
+            Nothing -> PreferNoHash
+      return $ Just (verbose, Options defaultDecodeOptions {decodeOptionsTarget = file} force generateHash toStdout)
     ParseError -> do
       printHelp
       exitFailure
@@ -101,7 +110,7 @@ printHelp :: IO ()
 printHelp = do
   name <- getProgName
   Utf8.hPutStrLn stderr $ unlines [
-      "Usage: " ++ name ++ " [ --silent ] [ --force | -f ] [ PATH ] [ - ]"
+      "Usage: " ++ name ++ " [ --silent ] [ --force | -f ] [ --[no-]hash ] [ PATH ] [ - ]"
     , "       " ++ name ++ " --version"
     , "       " ++ name ++ " --numeric-version"
     , "       " ++ name ++ " --help"
@@ -111,7 +120,7 @@ hpack :: Verbose -> Options -> IO ()
 hpack verbose options = hpackResult options >>= printResult verbose
 
 defaultOptions :: Options
-defaultOptions = Options defaultDecodeOptions NoForce False
+defaultOptions = Options defaultDecodeOptions NoForce PreferNoHash False
 
 setTarget :: FilePath -> Options -> Options
 setTarget target options@Options{..} =
@@ -157,21 +166,22 @@ printWarnings :: [String] -> IO ()
 printWarnings = mapM_ $ Utf8.hPutStrLn stderr . ("WARNING: " ++)
 
 mkStatus :: CabalFile -> CabalFile -> Status
-mkStatus new@(CabalFile _ mNewVersion _ _) existing@(CabalFile _ mExistingVersion _ _)
+mkStatus new@(CabalFile _ mNewVersion mNewHash _) existing@(CabalFile _ mExistingVersion _ _)
   | new `hasSameContent` existing = OutputUnchanged
   | otherwise = case mExistingVersion of
       Nothing -> ExistingCabalFileWasModifiedManually
-      Just existingVersion
-        | existingVersion < makeVersion [0, 20, 0] -> Generated
+      Just _
         | mNewVersion < mExistingVersion -> AlreadyGeneratedByNewerHpack
-        | hashMismatch existing -> ExistingCabalFileWasModifiedManually
+        | isJust mNewHash && hashMismatch existing -> ExistingCabalFileWasModifiedManually
         | otherwise -> Generated
 
 hasSameContent :: CabalFile -> CabalFile -> Bool
 hasSameContent (CabalFile cabalVersionA _ _ a) (CabalFile cabalVersionB _ _ b) = cabalVersionA == cabalVersionB && a == b
 
 hashMismatch :: CabalFile -> Bool
-hashMismatch cabalFile = cabalFileHash cabalFile /= Just (calculateHash cabalFile)
+hashMismatch cabalFile = case cabalFileHash cabalFile of
+  Nothing -> False
+  Just hash -> hash /= calculateHash cabalFile
 
 calculateHash :: CabalFile -> Hash
 calculateHash (CabalFile cabalVersion _ _ body) = sha256 (unlines $ cabalVersion ++ body)
@@ -180,11 +190,11 @@ hpackResult :: Options -> IO Result
 hpackResult = hpackResultWithVersion version
 
 hpackResultWithVersion :: Version -> Options -> IO Result
-hpackResultWithVersion v (Options options force toStdout) = do
+hpackResultWithVersion v (Options options force generateHashStrategy toStdout) = do
   DecodeResult pkg (lines -> cabalVersion) cabalFileName warnings <- readPackageConfig options >>= either die return
   mExistingCabalFile <- readCabalFile cabalFileName
   let
-    newCabalFile = makeCabalFile mExistingCabalFile cabalVersion v pkg
+    newCabalFile = makeCabalFile generateHashStrategy mExistingCabalFile cabalVersion v pkg
 
     status = case force of
       Force -> Generated
@@ -206,11 +216,25 @@ writeCabalFile options toStdout name cabalFile = do
   where
     write = if toStdout then Utf8.putStr else Utf8.writeFile name
 
-makeCabalFile :: Maybe CabalFile -> [String] -> Version -> Package -> CabalFile
-makeCabalFile mExistingCabalFile cabalVersion v pkg = CabalFile cabalVersion (Just v) (Just hash) body
+makeCabalFile :: GenerateHashStrategy -> Maybe CabalFile -> [String] -> Version -> Package -> CabalFile
+makeCabalFile strategy mExistingCabalFile cabalVersion v pkg = cabalFile
   where
-    hash = sha256 (unlines $ cabalVersion ++ body)
+    cabalFile = CabalFile cabalVersion (Just v) hash body
+
+    hash
+      | shouldGenerateHash mExistingCabalFile strategy = Just $ calculateHash cabalFile
+      | otherwise = Nothing
+
     body = lines $ renderPackage (maybe [] cabalFileContents mExistingCabalFile) pkg
 
+shouldGenerateHash :: Maybe CabalFile -> 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 -> CabalFile -> [String]
 renderCabalFile file (CabalFile cabalVersion hpackVersion hash body) = cabalVersion ++ header file hpackVersion hash ++ body

src/Hpack/Options.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE LambdaCase #-}
 module Hpack.Options where
 
+import           Control.Applicative
+import           Control.Monad
+import           Data.Maybe
 import           System.FilePath
 import           System.Directory
 
@@ -16,6 +19,7 @@ data Force = Force | NoForce
 data ParseOptions = ParseOptions {
   parseOptionsVerbose :: Verbose
 , parseOptionsForce :: Force
+, parseOptionsHash :: Maybe Bool
 , parseOptionsToStdout :: Bool
 , parseOptionsTarget :: FilePath
 } deriving (Eq, Show)
@@ -30,18 +34,30 @@ parseOptions defaultTarget = \ case
       file <- expandTarget defaultTarget target
       let
         options
-          | toStdout = ParseOptions NoVerbose Force toStdout file
-          | otherwise = ParseOptions verbose force toStdout file
+          | toStdout = ParseOptions NoVerbose Force hash toStdout file
+          | otherwise = ParseOptions verbose force hash toStdout file
       return (Run options)
     Left err -> return err
     where
       silentFlag = "--silent"
       forceFlags = ["--force", "-f"]
+      hashFlag = "--hash"
+      noHashFlag = "--no-hash"
 
-      flags = silentFlag : forceFlags
+      flags = hashFlag : noHashFlag : silentFlag : forceFlags
 
+      verbose :: Verbose
       verbose = if silentFlag `elem` args then NoVerbose else Verbose
+
+      force :: Force
       force = if any (`elem` args) forceFlags then Force else NoForce
+
+      hash :: Maybe Bool
+      hash = listToMaybe . reverse $ mapMaybe parse args
+        where
+          parse :: String -> Maybe Bool
+          parse t = True <$ guard (t == hashFlag) <|> False <$ guard (t == noHashFlag)
+
       ys = filter (`notElem` flags) args
 
       targets :: Either ParseResult (Maybe FilePath, Bool)

test/Hpack/OptionsSpec.hs

@@ -18,30 +18,42 @@ spec = do
 
     context "by default" $ do
       it "returns Run" $ do
-        parseOptions defaultTarget [] `shouldReturn` Run (ParseOptions Verbose NoForce False defaultTarget)
+        parseOptions defaultTarget [] `shouldReturn` Run (ParseOptions Verbose NoForce Nothing False defaultTarget)
 
       it "includes target" $ do
-        parseOptions defaultTarget ["foo.yaml"] `shouldReturn` Run (ParseOptions Verbose NoForce False "foo.yaml")
+        parseOptions defaultTarget ["foo.yaml"] `shouldReturn` Run (ParseOptions Verbose NoForce Nothing False "foo.yaml")
 
       context "with superfluous arguments" $ do
         it "returns ParseError" $ do
           parseOptions defaultTarget ["foo", "bar"] `shouldReturn` ParseError
 
       context "with --silent" $ do
         it "sets optionsVerbose to NoVerbose" $ do
-          parseOptions defaultTarget ["--silent"] `shouldReturn` Run (ParseOptions NoVerbose NoForce False defaultTarget)
+          parseOptions defaultTarget ["--silent"] `shouldReturn` Run (ParseOptions NoVerbose NoForce Nothing False defaultTarget)
 
       context "with --force" $ do
         it "sets optionsForce to Force" $ do
-          parseOptions defaultTarget ["--force"] `shouldReturn` Run (ParseOptions Verbose Force False defaultTarget)
+          parseOptions defaultTarget ["--force"] `shouldReturn` Run (ParseOptions Verbose Force Nothing False defaultTarget)
 
       context "with -f" $ do
         it "sets optionsForce to Force" $ do
-          parseOptions defaultTarget ["-f"] `shouldReturn` Run (ParseOptions Verbose Force False defaultTarget)
+          parseOptions defaultTarget ["-f"] `shouldReturn` Run (ParseOptions Verbose Force Nothing False defaultTarget)
+
+      context "when determining parseOptionsHash" $ do
+
+        it "assumes True on --hash" $ do
+          parseOptions defaultTarget ["--hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just True) False defaultTarget)
+
+        it "assumes False on --no-hash" $ do
+          parseOptions defaultTarget ["--no-hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just False) False defaultTarget)
+
+        it "gives last occurrence precedence" $ do
+          parseOptions defaultTarget ["--no-hash", "--hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just True) False defaultTarget)
+          parseOptions defaultTarget ["--hash", "--no-hash"] `shouldReturn` Run (ParseOptions Verbose NoForce (Just False) False defaultTarget)
 
       context "with -" $ do
         it "sets optionsToStdout to True, implies Force and NoVerbose" $ do
-          parseOptions defaultTarget ["-"] `shouldReturn` Run (ParseOptions NoVerbose Force True defaultTarget)
+          parseOptions defaultTarget ["-"] `shouldReturn` Run (ParseOptions NoVerbose Force Nothing True defaultTarget)
 
         it "rejects - for target" $ do
           parseOptions defaultTarget ["-", "-"] `shouldReturn` ParseError