From 7d0a366c0c5c81009e0a45a07e74ed8e7cd00bc0 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Wed, 20 Nov 2019 16:34:26 +0100 Subject: [PATCH] Extract modules out of Niv.Cli --- default.nix | 4 + src/Data/Aeson/Extended.hs | 17 ++++ src/Data/HashMap/Strict/Extended.hs | 40 ++++++++ src/Niv/Cli.hs | 142 +--------------------------- src/Niv/Sources.hs | 105 ++++++++++++++++++++ 5 files changed, 169 insertions(+), 139 deletions(-) create mode 100644 src/Data/Aeson/Extended.hs create mode 100644 src/Data/HashMap/Strict/Extended.hs create mode 100644 src/Niv/Sources.hs diff --git a/default.nix b/default.nix index a46aeb1..bbe7cfc 100644 --- a/default.nix +++ b/default.nix @@ -27,6 +27,10 @@ with rec "^app$" "^app.*.hs$" "^src$" + "^src/Data$" + "^src/Data/Aeson$" + "^src/Data/HashMap$" + "^src/Data/HashMap/Strict$" "^src/Niv$" "^src/Niv/GitHub$" "^src/Niv/Update$" diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs new file mode 100644 index 0000000..822f83c --- /dev/null +++ b/src/Data/Aeson/Extended.hs @@ -0,0 +1,17 @@ +module Data.Aeson.Extended where + +import Data.Aeson (ToJSON) +import qualified Data.Aeson.Encode.Pretty as AesonPretty +import qualified Data.ByteString.Lazy as BL + +--- Aeson + +-- | Efficiently prettify and serialize a JSON value as a lazy 'BL.ByteString' +-- and write it to a file. +encodeFilePretty :: (ToJSON a) => FilePath -> a -> IO () +encodeFilePretty fp = BL.writeFile fp . AesonPretty.encodePretty' config + where + config = AesonPretty.defConfig { + AesonPretty.confTrailingNewline = True, + AesonPretty.confCompare = compare + } diff --git a/src/Data/HashMap/Strict/Extended.hs b/src/Data/HashMap/Strict/Extended.hs new file mode 100644 index 0000000..2833b5c --- /dev/null +++ b/src/Data/HashMap/Strict/Extended.hs @@ -0,0 +1,40 @@ + +module Data.HashMap.Strict.Extended where + +import Control.Monad +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HMS + +--- HashMap + +forWithKeyM + :: (Eq k, Hashable k, Monad m) + => HMS.HashMap k v1 + -> (k -> v1 -> m v2) + -> m (HMS.HashMap k v2) +forWithKeyM = flip mapWithKeyM + +forWithKeyM_ + :: (Eq k, Hashable k, Monad m) + => HMS.HashMap k v1 + -> (k -> v1 -> m ()) + -> m () +forWithKeyM_ = flip mapWithKeyM_ + +mapWithKeyM + :: (Eq k, Hashable k, Monad m) + => (k -> v1 -> m v2) + -> HMS.HashMap k v1 + -> m (HMS.HashMap k v2) +mapWithKeyM f m = do + fmap mconcat $ forM (HMS.toList m) $ \(k, v) -> + HMS.singleton k <$> f k v + +mapWithKeyM_ + :: (Eq k, Hashable k, Monad m) + => (k -> v1 -> m ()) + -> HMS.HashMap k v1 + -> m () +mapWithKeyM_ f m = do + forM_ (HMS.toList m) $ \(k, v) -> + HMS.singleton k <$> f k v diff --git a/src/Niv/Cli.hs b/src/Niv/Cli.hs index fe8b7f2..207cf8a 100644 --- a/src/Niv/Cli.hs +++ b/src/Niv/Cli.hs @@ -11,16 +11,17 @@ module Niv.Cli where import Control.Applicative import Control.Monad -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey, (.=)) -import Data.Bifunctor (first) +import Data.Aeson ((.=)) import Data.Char (isSpace) import Data.FileEmbed (embedFile) import Data.Functor +import Data.HashMap.Strict.Extended import Data.Hashable (Hashable) import Data.String.QQ (s) import Data.Version (showVersion) import Niv.GitHub import Niv.Logger +import Niv.Sources import Niv.Update import System.Environment (getArgs) import System.Exit (ExitCode(ExitSuccess)) @@ -28,10 +29,8 @@ import System.FilePath ((), takeDirectory) import System.Process (readProcessWithExitCode) import UnliftIO import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Encode.Pretty as AesonPretty import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy as L import qualified Data.HashMap.Strict as HMS import qualified Data.Text as T import qualified Data.Text.IO as T @@ -68,63 +67,10 @@ parseCommand = Opts.subparser ( Opts.command "modify" parseCmdModify <> Opts.command "drop" parseCmdDrop ) -newtype Sources = Sources - { unSources :: HMS.HashMap PackageName PackageSpec } - deriving newtype (FromJSON, ToJSON) - -data SourcesError - = SourcesDoesntExist - | SourceIsntJSON - | SpecIsntAMap - -getSourcesEither :: IO (Either SourcesError Sources) -getSourcesEither = do - Dir.doesFileExist pathNixSourcesJson >>= \case - False -> pure $ Left SourcesDoesntExist - True -> - decodeFileStrict pathNixSourcesJson >>= \case - Just value -> case valueToSources value of - Nothing -> pure $ Left SpecIsntAMap - Just srcs -> pure $ Right srcs - Nothing -> pure $ Left SourceIsntJSON - where - valueToSources :: Aeson.Value -> Maybe Sources - valueToSources = \case - Aeson.Object obj -> fmap (Sources . mapKeys PackageName) $ traverse - (\case - Aeson.Object obj' -> Just (PackageSpec obj') - _ -> Nothing - ) obj - _ -> Nothing - mapKeys :: (Eq k2, Hashable k2) => (k1 -> k2) -> HMS.HashMap k1 v -> HMS.HashMap k2 v - mapKeys f = HMS.fromList . map (first f) . HMS.toList - -getSources :: IO Sources -getSources = - getSourcesEither >>= either - (\case - SourcesDoesntExist -> abortSourcesDoesntExist - SourceIsntJSON -> abortSourcesIsntJSON - SpecIsntAMap -> abortSpecIsntAMap - ) pure - -setSources :: Sources -> IO () -setSources sources = encodeFile pathNixSourcesJson sources - -newtype PackageName = PackageName { unPackageName :: T.Text } - deriving newtype (Eq, Hashable, FromJSONKey, ToJSONKey, Show) - parsePackageName :: Opts.Parser PackageName parsePackageName = PackageName <$> Opts.argument Opts.str (Opts.metavar "PACKAGE") -newtype PackageSpec = PackageSpec { unPackageSpec :: Aeson.Object } - deriving newtype (FromJSON, ToJSON, Show, Semigroup, Monoid) - --- | Simply discards the 'Freedom' -attrsToSpec :: Attrs -> PackageSpec -attrsToSpec = PackageSpec . fmap snd - parsePackageSpec :: Opts.Parser PackageSpec parsePackageSpec = (PackageSpec . HMS.fromList . fmap fixupAttributes) <$> @@ -505,60 +451,6 @@ cmdDrop packageName = \case -- Aux ------------------------------------------------------------------------------- ---- Aeson - --- | Efficiently deserialize a JSON value from a file. --- If this fails due to incomplete or invalid input, 'Nothing' is --- returned. --- --- The input file's content must consist solely of a JSON document, --- with no trailing data except for whitespace. --- --- This function parses immediately, but defers conversion. See --- 'json' for details. -decodeFileStrict :: (FromJSON a) => FilePath -> IO (Maybe a) -decodeFileStrict = fmap Aeson.decodeStrict . B.readFile - --- | Efficiently serialize a JSON value as a lazy 'L.ByteString' and write it to a file. -encodeFile :: (ToJSON a) => FilePath -> a -> IO () -encodeFile fp = L.writeFile fp . AesonPretty.encodePretty' config - where - config = AesonPretty.defConfig { AesonPretty.confTrailingNewline = True, AesonPretty.confCompare = compare } - ---- HashMap - -forWithKeyM - :: (Eq k, Hashable k, Monad m) - => HMS.HashMap k v1 - -> (k -> v1 -> m v2) - -> m (HMS.HashMap k v2) -forWithKeyM = flip mapWithKeyM - -forWithKeyM_ - :: (Eq k, Hashable k, Monad m) - => HMS.HashMap k v1 - -> (k -> v1 -> m ()) - -> m () -forWithKeyM_ = flip mapWithKeyM_ - -mapWithKeyM - :: (Eq k, Hashable k, Monad m) - => (k -> v1 -> m v2) - -> HMS.HashMap k v1 - -> m (HMS.HashMap k v2) -mapWithKeyM f m = do - fmap mconcat $ forM (HMS.toList m) $ \(k, v) -> - HMS.singleton k <$> f k v - -mapWithKeyM_ - :: (Eq k, Hashable k, Monad m) - => (k -> v1 -> m ()) - -> HMS.HashMap k v1 - -> m () -mapWithKeyM_ f m = do - forM_ (HMS.toList m) $ \(k, v) -> - HMS.singleton k <$> f k v - nixPrefetchURL :: Bool -> T.Text -> IO T.Text nixPrefetchURL unpack (T.unpack -> url) = do (exitCode, sout, serr) <- runNixPrefetch @@ -617,10 +509,6 @@ pathNixSourcesNix = "nix" "sources.nix" initNixSourcesNixContent :: B.ByteString initNixSourcesNixContent = $(embedFile "nix/sources.nix") --- | @nix/sources.json" -pathNixSourcesJson :: FilePath -pathNixSourcesJson = "nix" "sources.json" - -- | Empty JSON map initNixSourcesJsonContent :: B.ByteString initNixSourcesJsonContent = "{}" @@ -633,14 +521,6 @@ githubUpdate' = githubUpdate nixPrefetchURL githubLatestRev githubRepo -- Abort ------------------------------------------------------------------------------- -abortSourcesDoesntExist :: IO a -abortSourcesDoesntExist = abort $ T.unlines [ line1, line2 ] - where - line1 = "Cannot use " <> T.pack pathNixSourcesJson - line2 = [s| -The sources file does not exist! You may need to run 'niv init'. -|] - abortSourcesIsntAMap :: IO a abortSourcesIsntAMap = abort $ T.unlines [ line1, line2 ] where @@ -651,22 +531,6 @@ specification, e.g.: { ... } |] -abortSpecIsntAMap :: IO a -abortSpecIsntAMap = abort $ T.unlines [ line1, line2 ] - where - line1 = "Cannot use " <> T.pack pathNixSourcesJson - line2 = [s| -The package specifications in the sources file should be JSON maps from -attribute name to attribute value, e.g.: - { "nixpkgs": { "foo": "bar" } } -|] - -abortSourcesIsntJSON :: IO a -abortSourcesIsntJSON = abort $ T.unlines [ line1, line2 ] - where - line1 = "Cannot use " <> T.pack pathNixSourcesJson - line2 = "The sources file should be JSON." - abortCannotAddPackageExists :: PackageName -> IO a abortCannotAddPackageExists (PackageName n) = abort $ T.unlines [ "Cannot add package " <> n <> "." diff --git a/src/Niv/Sources.hs b/src/Niv/Sources.hs new file mode 100644 index 0000000..a999e77 --- /dev/null +++ b/src/Niv/Sources.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} + +module Niv.Sources where + +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) +import Data.Bifunctor (first) +import Data.Hashable (Hashable) +import Data.String.QQ (s) +import Niv.GitHub +import Niv.Update +import System.FilePath (()) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Extended as Aeson +import qualified Data.HashMap.Strict as HMS +import qualified Data.Text as T +import qualified System.Directory as Dir + +data SourcesError + = SourcesDoesntExist + | SourceIsntJSON + | SpecIsntAMap + +newtype Sources = Sources + { unSources :: HMS.HashMap PackageName PackageSpec } + deriving newtype (FromJSON, ToJSON) + +getSourcesEither :: IO (Either SourcesError Sources) +getSourcesEither = do + Dir.doesFileExist pathNixSourcesJson >>= \case + False -> pure $ Left SourcesDoesntExist + True -> + Aeson.decodeFileStrict pathNixSourcesJson >>= \case + Just value -> case valueToSources value of + Nothing -> pure $ Left SpecIsntAMap + Just srcs -> pure $ Right srcs + Nothing -> pure $ Left SourceIsntJSON + where + valueToSources :: Aeson.Value -> Maybe Sources + valueToSources = \case + Aeson.Object obj -> fmap (Sources . mapKeys PackageName) $ traverse + (\case + Aeson.Object obj' -> Just (PackageSpec obj') + _ -> Nothing + ) obj + _ -> Nothing + mapKeys :: (Eq k2, Hashable k2) => (k1 -> k2) -> HMS.HashMap k1 v -> HMS.HashMap k2 v + mapKeys f = HMS.fromList . map (first f) . HMS.toList + +getSources :: IO Sources +getSources = + getSourcesEither >>= either + (\case + SourcesDoesntExist -> abortSourcesDoesntExist + SourceIsntJSON -> abortSourcesIsntJSON + SpecIsntAMap -> abortSpecIsntAMap + ) pure + +setSources :: Sources -> IO () +setSources sources = Aeson.encodeFilePretty pathNixSourcesJson sources + +newtype PackageName = PackageName { unPackageName :: T.Text } + deriving newtype (Eq, Hashable, FromJSONKey, ToJSONKey, Show) + +newtype PackageSpec = PackageSpec { unPackageSpec :: Aeson.Object } + deriving newtype (FromJSON, ToJSON, Show, Semigroup, Monoid) + +-- | Simply discards the 'Freedom' +attrsToSpec :: Attrs -> PackageSpec +attrsToSpec = PackageSpec . fmap snd + +-- | @nix/sources.json@ +pathNixSourcesJson :: FilePath +pathNixSourcesJson = "nix" "sources.json" + +------------------------------------------------------------------------------- +-- ABORT messages +------------------------------------------------------------------------------- + +abortSourcesDoesntExist :: IO a +abortSourcesDoesntExist = abort $ T.unlines [ line1, line2 ] + where + line1 = "Cannot use " <> T.pack pathNixSourcesJson + line2 = [s| +The sources file does not exist! You may need to run 'niv init'. +|] + +abortSourcesIsntJSON :: IO a +abortSourcesIsntJSON = abort $ T.unlines [ line1, line2 ] + where + line1 = "Cannot use " <> T.pack pathNixSourcesJson + line2 = "The sources file should be JSON." + +abortSpecIsntAMap :: IO a +abortSpecIsntAMap = abort $ T.unlines [ line1, line2 ] + where + line1 = "Cannot use " <> T.pack pathNixSourcesJson + line2 = [s| +The package specifications in the sources file should be JSON maps from +attribute name to attribute value, e.g.: + { "nixpkgs": { "foo": "bar" } } +|]