mirror of
https://github.com/nmattia/niv.git
synced 2024-10-06 12:27:35 +03:00
wip custom command
This commit is contained in:
parent
6f03879b8a
commit
8ac6299dd7
69
src/Niv/Custom/Cmd.hs
Normal file
69
src/Niv/Custom/Cmd.hs
Normal file
@ -0,0 +1,69 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE Arrows #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Niv.Custom.Cmd where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Arrow
|
||||
import Data.Maybe
|
||||
import Data.Text.Extended as T
|
||||
import Niv.Cmd
|
||||
import Niv.Logger
|
||||
import Niv.Sources
|
||||
import Niv.Update
|
||||
import System.Exit (ExitCode(ExitSuccess))
|
||||
import System.Process (readProcessWithExitCode)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
import qualified Data.ByteString.Lazy.Char8 as BL8
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Options.Applicative as Opts
|
||||
import qualified Options.Applicative.Help.Pretty as Opts
|
||||
|
||||
customCmd :: Cmd
|
||||
customCmd = Cmd
|
||||
{ description = describeCustom
|
||||
, parseCmdShortcut = const Nothing
|
||||
, parsePackageSpec = undefined
|
||||
, updateCmd = customUpdate'
|
||||
, name = "custom"
|
||||
}
|
||||
|
||||
describeCustom :: Opts.InfoMod a
|
||||
describeCustom = mconcat
|
||||
[ Opts.fullDesc
|
||||
, Opts.progDesc "Add a custom dependency. Experimental."
|
||||
, Opts.headerDoc $ Just $
|
||||
"Examples:" Opts.<$$>
|
||||
"" Opts.<$$>
|
||||
" niv add custom --path ./script/update-dep"
|
||||
]
|
||||
|
||||
parseCustomPackageSpec :: Opts.Parser PackageSpec
|
||||
parseCustomPackageSpec = pure $ PackageSpec HMS.empty
|
||||
|
||||
customUpdate :: (FilePath -> Aeson.Object -> IO Aeson.Object) -> Update () ()
|
||||
customUpdate runExe = proc () -> do
|
||||
path <- load "path" -< ()
|
||||
vals <- Read -< ()
|
||||
newVal <- run' (uncurry runExe) -< (,) <$> path <*> pure vals
|
||||
override -< newVal
|
||||
|
||||
customUpdate' :: Update () ()
|
||||
customUpdate' = customUpdate runExe
|
||||
where
|
||||
runExe fp obj = do
|
||||
(exitCode, sout, serr) <- readProcessWithExitCode fp [ BL8.unpack $ Aeson.encode obj ] ""
|
||||
case (exitCode, lines sout) of
|
||||
(ExitSuccess, [l]) -> case Aeson.decodeStrict (B8.pack l) of
|
||||
Just (Aeson.Object obj) -> pure obj
|
||||
_ -> error $ show $ T.unlines
|
||||
[ T.unwords [ "stdout:" , T.pack sout ]
|
||||
, T.unwords [ "stderr:" , T.pack serr ]
|
||||
]
|
22
src/Niv/Custom/Test.hs
Normal file
22
src/Niv/Custom/Test.hs
Normal file
@ -0,0 +1,22 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE Arrows #-}
|
||||
|
||||
module Niv.Custom.Test (tests) where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Bifunctor
|
||||
import Niv.Custom.Cmd
|
||||
import Niv.Sources
|
||||
import Niv.Update
|
||||
import Test.Tasty.HUnit ((@=?))
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import qualified Test.Tasty as Tasty
|
||||
import qualified Test.Tasty.HUnit as Tasty
|
||||
|
||||
tests :: [Tasty.TestTree]
|
||||
tests = [ test_foo ]
|
||||
|
||||
test_foo :: Tasty.TestTree
|
||||
test_foo = Tasty.testGroup "bar"
|
||||
[ Tasty.testCase "baz" $ pure ()
|
||||
]
|
@ -4,6 +4,7 @@ import Niv.Sources.Test
|
||||
import Niv.GitHub.Test
|
||||
import Niv.Update.Test
|
||||
import qualified Niv.Git.Test as Git
|
||||
import qualified Niv.Custom.Test as Custom
|
||||
import qualified Test.Tasty as Tasty
|
||||
import qualified Test.Tasty.HUnit as Tasty
|
||||
|
||||
@ -33,4 +34,5 @@ tests = Tasty.testGroup "niv"
|
||||
[ Tasty.testCase "has latest version" test_shippedSourcesNixIsLatest
|
||||
]
|
||||
, Tasty.testGroup "git" Git.tests
|
||||
, Tasty.testGroup "custom" Custom.tests
|
||||
]
|
||||
|
@ -36,6 +36,8 @@ data Update b c where
|
||||
Update :: T.Text -> Update (Box Value) (Box Value)
|
||||
Run :: (a -> IO b) -> Update (Box a) (Box b)
|
||||
Template :: Update (Box T.Text) (Box T.Text)
|
||||
Override :: Update (Box Aeson.Object) ()
|
||||
Read :: Update () Aeson.Object
|
||||
|
||||
instance ArrowZero Update where
|
||||
zeroArrow = Zero
|
||||
@ -65,6 +67,8 @@ instance Show (Update b c) where
|
||||
Update k -> "Update " <> T.unpack k
|
||||
Run _act -> "Io"
|
||||
Template -> "Template"
|
||||
Override -> "Override"
|
||||
Read -> "Read"
|
||||
|
||||
data Compose a c = forall b. Compose' (Update b c) (Update a b)
|
||||
|
||||
@ -238,6 +242,14 @@ runUpdate' attrs = \case
|
||||
HMS.lookup k attrs) v' of
|
||||
Nothing -> pure $ UpdateFailed $ FailTemplate v' (HMS.keys attrs)
|
||||
Just v'' -> pure $ UpdateSuccess attrs (v'' <* v) -- carries over v's newness
|
||||
Override -> pure $ UpdateNeedMore $ \v -> do
|
||||
v' <- runBox v
|
||||
let v'' = fmap ((Locked,) . pure) v'
|
||||
-- let v'' = fmap (\(f, v''') -> (f, pure v''')) v'
|
||||
pure $ UpdateSuccess v'' ()
|
||||
Read -> do
|
||||
attrs' <- mapM (\(_, x) -> runBox x) attrs
|
||||
pure $ UpdateReady $ UpdateSuccess attrs attrs'
|
||||
|
||||
decodeBox :: FromJSON a => T.Text -> Box Value -> Box a
|
||||
decodeBox msg v = v { boxOp = boxOp v >>= decodeValue msg }
|
||||
@ -281,6 +293,13 @@ useOrSet k =
|
||||
UseOrSet k >>>
|
||||
arr (decodeBox $ "When trying to use or set key " <> k)
|
||||
|
||||
|
||||
override :: Update (Box Aeson.Object) ()
|
||||
override = Override
|
||||
|
||||
read :: Update () Aeson.Object
|
||||
read = Read
|
||||
|
||||
update :: JSON a => T.Text -> Update (Box a) (Box a)
|
||||
update k =
|
||||
arr (fmap Aeson.toJSON) >>>
|
||||
|
Loading…
Reference in New Issue
Block a user