From 4cb9b097d6f689dda7b242c641f0e3694f1f4942 Mon Sep 17 00:00:00 2001 From: Anton-Latukha Date: Thu, 4 Mar 2021 18:20:04 +0200 Subject: [PATCH 1/8] Effects.Basic: m refactor --- src/Nix/Effects/Basic.hs | 28 +++++++++++++++------------- src/Nix/Expr/Types/Annotated.hs | 3 ++- 2 files changed, 17 insertions(+), 14 deletions(-) diff --git a/src/Nix/Effects/Basic.hs b/src/Nix/Effects/Basic.hs index 46b5e229a..b236628d4 100644 --- a/src/Nix/Effects/Basic.hs +++ b/src/Nix/Effects/Basic.hs @@ -12,6 +12,7 @@ module Nix.Effects.Basic where import Control.Monad import Control.Monad.State.Strict +import Data.Bifunctor ( first ) import Data.HashMap.Lazy ( HashMap ) import qualified Data.HashMap.Lazy as M import Data.List @@ -250,18 +251,19 @@ defaultImportPath path = do traceM $ "Importing file " <> path withFrame Info (ErrorCall $ "While importing file " <> show path) $ do imports <- gets fst - evalExprLoc =<< case M.lookup path imports of - Just expr -> pure expr - Nothing -> do - eres <- parseNixFileLoc path - case eres of - Failure err -> - throwError - $ ErrorCall - . show $ fillSep ["Parse during import failed:", err] - Success expr -> do - modify (\(a, b) -> (M.insert path expr a, b)) - pure expr + evalExprLoc =<< + maybe + (do + eres <- parseNixFileLoc path + case eres of + Failure err -> throwError $ ErrorCall . show $ fillSep ["Parse during import failed:", err] + Success expr -> + do + modify (first (M.insert path expr)) + pure expr + ) + pure -- return expr + (M.lookup path imports) defaultPathToDefaultNix :: MonadNix e t f m => FilePath -> m FilePath defaultPathToDefaultNix = pathToDefaultNixFile @@ -270,7 +272,7 @@ defaultPathToDefaultNix = pathToDefaultNixFile pathToDefaultNixFile :: MonadFile m => FilePath -> m FilePath pathToDefaultNixFile p = do isDir <- doesDirectoryExist p - pure $ if isDir then p "default.nix" else p + pure $ p ifTrue "default.nix" isDir defaultTraceEffect :: MonadPutStr m => String -> m () defaultTraceEffect = Nix.Effects.putStrLn diff --git a/src/Nix/Expr/Types/Annotated.hs b/src/Nix/Expr/Types/Annotated.hs index d45ea4ebb..7ebaa8ec2 100644 --- a/src/Nix/Expr/Types/Annotated.hs +++ b/src/Nix/Expr/Types/Annotated.hs @@ -33,7 +33,8 @@ import Data.Aeson.TH import Data.Binary ( Binary(..) ) import Data.Data import Data.Eq.Deriving -import Data.Fix ( Fix(..), unfoldFix ) +import Data.Fix ( Fix(..) + , unfoldFix ) import Data.Function ( on ) import Data.Functor.Compose import Data.Hashable From 62b77eabeb749c7a13157ace2d6a5ade30795bc8 Mon Sep 17 00:00:00 2001 From: Anton-Latukha Date: Thu, 4 Mar 2021 18:21:45 +0200 Subject: [PATCH 2/8] Effects.Basic: m refactor --- src/Nix/Effects/Basic.hs | 34 ++++++++++++---------------------- 1 file changed, 12 insertions(+), 22 deletions(-) diff --git a/src/Nix/Effects/Basic.hs b/src/Nix/Effects/Basic.hs index b236628d4..fa4da9427 100644 --- a/src/Nix/Effects/Basic.hs +++ b/src/Nix/Effects/Basic.hs @@ -178,25 +178,18 @@ findPathBy finder ls name = do fetchTarball :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) fetchTarball = demand $ \case - NVSet s _ -> case M.lookup "url" s of - Nothing -> - throwError $ ErrorCall "builtins.fetchTarball: Missing url attribute" - Just url -> demand (go (M.lookup "sha256" s)) url + NVSet s _ -> + maybe + (throwError $ ErrorCall "builtins.fetchTarball: Missing url attribute") + (demand (go (M.lookup "sha256" s))) + (M.lookup "url" s) v@NVStr{} -> go Nothing v - v -> - throwError - $ ErrorCall - $ "builtins.fetchTarball: Expected URI or set, got " - <> show v + v -> throwError $ ErrorCall $ "builtins.fetchTarball: Expected URI or set, got " <> show v where go :: Maybe (NValue t f m) -> NValue t f m -> m (NValue t f m) go msha = \case NVStr ns -> fetch (stringIgnoreContext ns) msha - v -> - throwError - $ ErrorCall - $ "builtins.fetchTarball: Expected URI or string, got " - <> show v + v -> throwError $ ErrorCall $ "builtins.fetchTarball: Expected URI or string, got " <> show v {- jww (2018-04-11): This should be written using pipes in another module fetch :: Text -> Maybe (NThunk m) -> m (NValue t f m) @@ -234,14 +227,11 @@ findPathM findPathM = findPathBy existingPath where existingPath :: MonadEffects t f m => FilePath -> m (Maybe FilePath) - existingPath path = do - apath <- makeAbsolutePath @t @f path - exists <- doesPathExist apath - pure $ - bool - mempty - (pure apath) - exists + existingPath path = + do + apath <- makeAbsolutePath @t @f path + doesExist <- doesPathExist apath + pure $ ifTrue (pure apath) doesExist defaultImportPath :: (MonadNix e t f m, MonadState (HashMap FilePath NExprLoc, b) m) From fcb62cffc798268835e98f7876397d934189d829 Mon Sep 17 00:00:00 2001 From: Anton-Latukha Date: Thu, 4 Mar 2021 18:30:59 +0200 Subject: [PATCH 3/8] Effects.Basic: m refactor --- src/Nix/Effects/Basic.hs | 41 ++++++++++++++++++++++++---------------- 1 file changed, 25 insertions(+), 16 deletions(-) diff --git a/src/Nix/Effects/Basic.hs b/src/Nix/Effects/Basic.hs index fa4da9427..9ddec533f 100644 --- a/src/Nix/Effects/Basic.hs +++ b/src/Nix/Effects/Basic.hs @@ -136,31 +136,40 @@ findPathBy finder ls name = do go mp = maybe (demand - (fromValue >=> \(s :: HashMap Text (NValue t f m)) -> do - p <- resolvePath s - demand - (fromValue >=> \(Path path) -> - maybe - (tryPath path mempty) - (demand ( - fromValueMay >=> \case - Just (nsPfx :: NixString) -> - let pfx = stringIgnoreContext nsPfx - in bool + (\ nvhmt -> + do + (s :: HashMap Text (NValue t f m)) <- fromValue nvhmt + p <- resolvePath s + + demand + (\ nvpath -> + do + (Path path) <- fromValue nvpath + maybe + (tryPath path mempty) + (demand + (\ nvmns -> + do + (\case + Just (nsPfx :: NixString) -> + let pfx = stringIgnoreContext nsPfx in + bool (tryPath path mempty) (tryPath path (pure (Text.unpack pfx))) (not $ Text.null pfx) - _ -> tryPath path mempty + _ -> tryPath path mempty + ) =<< fromValueMay nvmns ) - ) - (M.lookup "prefix" s) - ) - p + ) + (M.lookup "prefix" s) + ) + p ) ) (const . pure . pure) mp + tryPath :: FilePath -> Maybe FilePath -> m (Maybe FilePath) tryPath p (Just n) | n' : ns <- splitDirectories name, n == n' = finder $ p joinPath ns tryPath p _ = finder $ p name From c6e433c975a33a9d876d60662d96e9540ec850b3 Mon Sep 17 00:00:00 2001 From: Anton-Latukha Date: Thu, 4 Mar 2021 18:34:19 +0200 Subject: [PATCH 4/8] Effects.Basic: m refactor --- src/Nix/Effects/Basic.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Nix/Effects/Basic.hs b/src/Nix/Effects/Basic.hs index 9ddec533f..16afbc323 100644 --- a/src/Nix/Effects/Basic.hs +++ b/src/Nix/Effects/Basic.hs @@ -153,9 +153,9 @@ findPathBy finder ls name = do (\case Just (nsPfx :: NixString) -> let pfx = stringIgnoreContext nsPfx in - bool - (tryPath path mempty) - (tryPath path (pure (Text.unpack pfx))) + tryPath path $ bool + mempty + (pure (Text.unpack pfx)) (not $ Text.null pfx) _ -> tryPath path mempty ) =<< fromValueMay nvmns From 3e0b84f48d7d43467a2327ba686cd85e6478cb9a Mon Sep 17 00:00:00 2001 From: Anton-Latukha Date: Thu, 4 Mar 2021 18:46:09 +0200 Subject: [PATCH 5/8] Effects.Basic: m refactor --- src/Nix/Effects/Basic.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/Nix/Effects/Basic.hs b/src/Nix/Effects/Basic.hs index 16afbc323..354e7d184 100644 --- a/src/Nix/Effects/Basic.hs +++ b/src/Nix/Effects/Basic.hs @@ -150,15 +150,16 @@ findPathBy finder ls name = do (demand (\ nvmns -> do - (\case - Just (nsPfx :: NixString) -> - let pfx = stringIgnoreContext nsPfx in - tryPath path $ bool - mempty - (pure (Text.unpack pfx)) - (not $ Text.null pfx) - _ -> tryPath path mempty - ) =<< fromValueMay nvmns + mns <- fromValueMay nvmns + tryPath path $ + case mns of + Just (nsPfx :: NixString) -> + let pfx = stringIgnoreContext nsPfx in + bool + mempty + (pure (Text.unpack pfx)) + (not $ Text.null pfx) + _ -> mempty ) ) (M.lookup "prefix" s) From 904bfca9a2c5ed7e9f55ddfd47db9ee67a62bc5a Mon Sep 17 00:00:00 2001 From: Anton-Latukha Date: Thu, 4 Mar 2021 18:55:32 +0200 Subject: [PATCH 6/8] Effects.Basic: m refactor This may look obnoxious currently, but this is a process of moving the `tryPath` to have it only once. But this form would allow to easily replace `demand` here during https://github.com/haskell-nix/hnix/issues/850, and the structure would fold alpha convert simplify quite drastically. --- src/Nix/Effects/Basic.hs | 37 +++++++++++++++++++------------------ 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/src/Nix/Effects/Basic.hs b/src/Nix/Effects/Basic.hs index 354e7d184..daa87868a 100644 --- a/src/Nix/Effects/Basic.hs +++ b/src/Nix/Effects/Basic.hs @@ -144,25 +144,26 @@ findPathBy finder ls name = do demand (\ nvpath -> do - (Path path) <- fromValue nvpath - maybe - (tryPath path mempty) - (demand - (\ nvmns -> - do - mns <- fromValueMay nvmns - tryPath path $ - case mns of - Just (nsPfx :: NixString) -> - let pfx = stringIgnoreContext nsPfx in - bool - mempty - (pure (Text.unpack pfx)) - (not $ Text.null pfx) - _ -> mempty + (Path path) <- fromValue nvpath + + maybe + (tryPath path mempty) + (demand + (\ nvmns -> + do + mns <- fromValueMay nvmns + tryPath path $ + case mns of + Just (nsPfx :: NixString) -> + let pfx = stringIgnoreContext nsPfx in + bool + mempty + (pure (Text.unpack pfx)) + (not $ Text.null pfx) + _ -> mempty + ) ) - ) - (M.lookup "prefix" s) + (M.lookup "prefix" s) ) p ) From 4b346e74817f60d498a4836ed33b10271ab07507 Mon Sep 17 00:00:00 2001 From: Anton-Latukha Date: Thu, 4 Mar 2021 19:48:43 +0200 Subject: [PATCH 7/8] Effects.Basic: m refactor --- src/Nix/Effects/Basic.hs | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/src/Nix/Effects/Basic.hs b/src/Nix/Effects/Basic.hs index daa87868a..72fdb7df4 100644 --- a/src/Nix/Effects/Basic.hs +++ b/src/Nix/Effects/Basic.hs @@ -67,7 +67,7 @@ defaultMakeAbsolutePath origPath = do removeDotDotIndirections <$> canonicalizePath absPath expandHomePath :: MonadFile m => FilePath -> m FilePath -expandHomePath ('~' : xs) = flip (<>) xs <$> getHomeDirectory +expandHomePath ('~' : xs) = (<> xs) <$> getHomeDirectory expandHomePath p = pure p -- | Incorrectly normalize paths by rewriting patterns like @a/b/..@ to @a@. @@ -96,11 +96,18 @@ defaultFindEnvPath = findEnvPathM findEnvPathM :: forall e t f m . MonadNix e t f m => FilePath -> m FilePath findEnvPathM name = do mres <- lookupVar "__nixPath" + maybe (error "impossible") - (demand (fromValue >=> \(l :: [NValue t f m]) -> - findPathBy nixFilePath l name)) + (demand + (\ nv -> + do + (l :: [NValue t f m]) <- fromValue nv + findPathBy nixFilePath l name + ) + ) mres + where nixFilePath :: MonadEffects t f m => FilePath -> m (Maybe FilePath) nixFilePath path = do @@ -219,9 +226,12 @@ fetchTarball = demand $ \case nixInstantiateExpr $ "builtins.fetchTarball \"" <> Text.unpack uri <> "\"" fetch url (Just t) = demand - (fromValue >=> \nsSha -> + (\nv -> do + nsSha <- fromValue nv + let sha = stringIgnoreContext nsSha - in nixInstantiateExpr + + nixInstantiateExpr $ "builtins.fetchTarball { " <> "url = \"" <> Text.unpack url <> "\"; " <> "sha256 = \"" <> Text.unpack sha <> "\"; }" ) t From 084aac8e5ce96680ca5673be8b56fc85fbaafadd Mon Sep 17 00:00:00 2001 From: Anton-Latukha Date: Thu, 4 Mar 2021 20:13:56 +0200 Subject: [PATCH 8/8] class MonadValue: unflip `inform` --- ChangeLog.md | 4 +++- src/Nix/Eval.hs | 2 +- src/Nix/Standard.hs | 8 ++++---- src/Nix/Type/Infer.hs | 6 +++--- src/Nix/Value/Monad.hs | 2 +- 5 files changed, 12 insertions(+), 10 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 73a4668f7..8b8173f92 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -43,11 +43,13 @@ furtherF :: (m a -> m a) -> t -> m t ``` - * [(link)](https://github.com/haskell-nix/hnix/pull/862/files) `Nix.Value.Monad`: `class MonadValue v m`: `demand` unflipped the arguments into a classical order. As a result, `demand` now tail recurse. + * [(link)](https://github.com/haskell-nix/hnix/pull/862/files) [(link)](https://github.com/haskell-nix/hnix/pull/870/files) `Nix.Value.Monad`: `class MonadValue v m`: unflipped the arguments of methods into a classical order. As a result, `demand` now tail recurse. ```haskell demand :: (v -> m r) -> v -> m r -- was :: v -> (v -> m r) -> m r + inform :: (m v -> m v) -> v -> m v + -- was :: v -> (m v -> m v) -> m v ``` * [(link)](https://github.com/haskell-nix/hnix/pull/863/files) `Nix.Normal`: `normalizeValue` removed first functional argument that was passing the function that did the thunk forcing. Now function provides the thunk forcing. Now to normalize simply use `normalizeValue v`. diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs index aafba066b..d64d5c375 100644 --- a/src/Nix/Eval.hs +++ b/src/Nix/Eval.hs @@ -163,7 +163,7 @@ eval (NAbs params body) = do scope <- currentScopes :: m (Scopes m v) evalAbs params $ \arg k -> withScopes scope $ do args <- buildArgument params arg - pushScope args (k (fmap (inform ?? withScopes scope) args) body) + pushScope args (k (fmap (inform (withScopes scope)) args) body) eval (NSynHole name) = synHole name diff --git a/src/Nix/Standard.hs b/src/Nix/Standard.hs index 861a4ea31..86f75caa2 100644 --- a/src/Nix/Standard.hs +++ b/src/Nix/Standard.hs @@ -246,14 +246,14 @@ instance ( MonadAtomicRef m v inform - :: StdValue m - -> ( m (StdValue m) + :: ( m (StdValue m) -> m (StdValue m) ) + -> StdValue m -> m (StdValue m) -- 2021-02-27: NOTE: When swapping, switch to `further`. - inform (Pure t) f = Pure <$> furtherF f t - inform (Free v) f = Free <$> bindNValue' id (`inform` f) v + inform f (Pure t) = Pure <$> furtherF f t + inform f (Free v) = Free <$> bindNValue' id (inform f) v {------------------------------------------------------------------------} diff --git a/src/Nix/Type/Infer.hs b/src/Nix/Type/Infer.hs index c29e2e14a..63bf21b97 100644 --- a/src/Nix/Type/Infer.hs +++ b/src/Nix/Type/Infer.hs @@ -414,12 +414,12 @@ instance Monad m => MonadValue (Judgment s) (InferT s m) where demand = ($) inform - :: Judgment s - -> ( InferT s m (Judgment s) + :: ( InferT s m (Judgment s) -> InferT s m (Judgment s) ) + -> Judgment s -> InferT s m (Judgment s) - inform j f = f (pure j) + inform f j = f (pure j) {- instance MonadInfer m diff --git a/src/Nix/Value/Monad.hs b/src/Nix/Value/Monad.hs index 63cd6942e..f4cfed717 100644 --- a/src/Nix/Value/Monad.hs +++ b/src/Nix/Value/Monad.hs @@ -8,4 +8,4 @@ class MonadValue v m where -- | If 'v' is a thunk, 'inform' allows us to modify the action to be -- performed by the thunk, perhaps by enriching it with scope info, for -- example. - inform :: v -> (m v -> m v) -> m v + inform :: (m v -> m v) -> v -> m v