wip custom command

src/Niv/Custom/Cmd.hs

@@ -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 ]
+          ]

src/Niv/Custom/Test.hs

@@ -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 ()
+  ]

src/Niv/Test.hs

@@ -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
     ]

src/Niv/Update.hs

@@ -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) >>>