From 2c0c896871a284181af44a6fc9b19f715c4089ab Mon Sep 17 00:00:00 2001 From: John Wiegley Date: Mon, 18 Mar 2019 17:04:11 -0700 Subject: [PATCH] Everything compiling again, but 25 tests failing --- hnix.cabal | 1 + main/Main.hs | 13 ++++++++----- main/Repl.hs | 5 +++-- src/Nix.hs | 30 +++++++++++++++--------------- src/Nix/Builtins.hs | 2 +- src/Nix/Thunk/Standard.hs | 22 ++++++++++++++++++---- src/Nix/Value.hs | 6 ++++++ 7 files changed, 52 insertions(+), 27 deletions(-) diff --git a/hnix.cabal b/hnix.cabal index e25f612..69f23c2 100644 --- a/hnix.cabal +++ b/hnix.cabal @@ -586,6 +586,7 @@ executable hnix , deepseq >=1.4.2 && <1.5 , exceptions , filepath + , free , hashing , haskeline , hnix diff --git a/main/Main.hs b/main/Main.hs index 8a0a578..34b8556 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -14,6 +14,7 @@ import qualified Control.DeepSeq as Deep import qualified Control.Exception as Exc import Control.Monad import Control.Monad.Catch +import Control.Monad.Free import Control.Monad.IO.Class -- import Control.Monad.ST import qualified Data.Aeson.Text as A @@ -39,6 +40,7 @@ import qualified Nix.Type.Env as Env import qualified Nix.Type.Infer as HM import Nix.Utils import Nix.Var +import Nix.Value.Monad import Options.Applicative hiding ( ParserResult(..) ) import qualified Repl import System.FilePath @@ -132,7 +134,7 @@ main = do where printer | finder opts - = fromValue @(AttrSet (StandardThunk IO)) >=> findAttrs + = fromValue @(AttrSet (StandardValue IO)) >=> findAttrs | xml opts = liftIO . putStrLn @@ -152,14 +154,15 @@ main = do | otherwise = liftIO . print <=< prettyNValue where + findAttrs :: AttrSet (StandardValue IO) -> StandardT IO () findAttrs = go "" where go prefix s = do xs <- forM (sortOn fst (M.toList s)) - $ \(k, nv@(StdThunk (extract -> t))) -> case t of - Value v -> pure (k, Just v) - Thunk _ _ ref -> do + $ \(k, nv) -> case nv of + Free v -> pure (k, Just (Free v)) + Pure (StdThunk (extract -> Thunk _ _ ref)) -> do let path = prefix ++ Text.unpack k (_, descend) = filterEntry path k val <- readVar @(StandardT IO) ref @@ -197,7 +200,7 @@ main = do _ -> (True, True) forceEntry k v = - catch (Just <$> force v pure) $ \(NixException frames) -> do + catch (Just <$> demand v pure) $ \(NixException frames) -> do liftIO . putStrLn . ("Exception forcing " ++) diff --git a/main/Repl.hs b/main/Repl.hs index 523cd98..e018b22 100644 --- a/main/Repl.hs +++ b/main/Repl.hs @@ -115,7 +115,7 @@ exec update source = do -- tyctx' <- hoistErr $ inferTop (tyctx st) expr -- TODO: track scope with (tmctx st) - mVal <- lift $ lift $ try $ pushScope @t M.empty (evalExprLoc expr) + mVal <- lift $ lift $ try $ pushScope M.empty (evalExprLoc expr) case mVal of Left (NixException frames) -> do @@ -171,7 +171,8 @@ typeof args = do val <- case M.lookup line (tmctx st) of Just val -> return val Nothing -> exec False line - liftIO $ putStrLn $ describeValue . valueType . extract . _nValue $ val + str <- lift $ lift $ showValueType val + liftIO $ putStrLn str where line = Text.pack (unwords args) -- :quit command diff --git a/src/Nix.hs b/src/Nix.hs index 15a195d..bb3ebb6 100644 --- a/src/Nix.hs +++ b/src/Nix.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} module Nix @@ -51,6 +51,7 @@ import Nix.Render.Frame import Nix.Thunk import Nix.Utils import Nix.Value +import Nix.Value.Monad import Nix.XML -- | This is the entry point for all evaluations, whatever the expression tree @@ -82,7 +83,7 @@ nixEvalExprLoc -> m (NValue t f m) nixEvalExprLoc mpath = nixEval mpath - (Eval.addStackFrames @t . Eval.addSourcePositions) + (Eval.addStackFrames . Eval.addSourcePositions) (Eval.eval . annotated . getCompose) -- | Evaluate a nix expression with tracing in the default context. Note that @@ -117,13 +118,12 @@ evaluateExpression mpath evaluator handler expr = do eval' = (normalForm =<<) . nixEvalExpr mpath - argmap args = pure $ nvSet (M.fromList args') mempty - where args' = map (fmap (wrapValue . nValueFromNF)) args + argmap args = nvSet (M.fromList args') mempty + where args' = map (fmap nValueFromNF) args - compute ev x args p = do - f :: NValue t f m <- ev mpath x - processResult p =<< case f of - NVClosure _ g -> force ?? pure =<< g args + compute ev x args p = ev mpath x >>= \f -> demand f $ \f' -> + processResult p =<< case f' of + NVClosure _ g -> g args _ -> pure f processResult @@ -135,22 +135,22 @@ processResult processResult h val = do opts :: Options <- asks (view hasLens) case attr opts of - Nothing -> h val + Nothing -> h val Just (Text.splitOn "." -> keys) -> go keys val where go :: [Text.Text] -> NValue t f m -> m a go [] v = h v - go ((Text.decimal -> Right (n,"")) : ks) v = case v of + go ((Text.decimal -> Right (n,"")) : ks) v = demand v $ \case NVList xs -> case ks of - [] -> force @t @m @(NValue t f m) (xs !! n) h - _ -> force (xs !! n) (go ks) + [] -> h (xs !! n) + _ -> go ks (xs !! n) _ -> errorWithoutStackTrace $ "Expected a list for selector '" ++ show n ++ "', but got: " ++ show v - go (k : ks) v = case v of + go (k : ks) v = demand v $ \case NVSet xs _ -> case M.lookup k xs of Nothing -> errorWithoutStackTrace @@ -158,8 +158,8 @@ processResult h val = do ++ Text.unpack k ++ "'" Just v' -> case ks of - [] -> force v' h - _ -> force v' (go ks) + [] -> h v' + _ -> go ks v' _ -> errorWithoutStackTrace $ "Expected a set for selector '" diff --git a/src/Nix/Builtins.hs b/src/Nix/Builtins.hs index fe457e2..c8b369b 100644 --- a/src/Nix/Builtins.hs +++ b/src/Nix/Builtins.hs @@ -174,7 +174,7 @@ builtinsList = sequence , add2 Normal "catAttrs" catAttrs , add2 Normal "compareVersions" compareVersions_ , add Normal "concatLists" concatLists - , add' Normal "concatStringsSep" (arity2 principledIntercalateNixString) + -- , add' Normal "concatStringsSep" (arity2 principledIntercalateNixString) , add0 Normal "currentSystem" currentSystem , add0 Normal "currentTime" currentTime_ , add2 Normal "deepSeq" deepSeq diff --git a/src/Nix/Thunk/Standard.hs b/src/Nix/Thunk/Standard.hs index 0b5cd9a..453b2cb 100644 --- a/src/Nix/Thunk/Standard.hs +++ b/src/Nix/Thunk/Standard.hs @@ -23,6 +23,7 @@ module Nix.Thunk.Standard where import Control.Comonad ( Comonad ) import Control.Comonad.Env ( ComonadEnv ) import Control.Monad.Catch hiding ( catchJust ) +import Control.Monad.Free import Control.Monad.Reader import Control.Monad.Ref import Data.Typeable @@ -36,6 +37,7 @@ import Nix.Options import Nix.Thunk import Nix.Thunk.Basic import Nix.Value +import Nix.Value.Monad import Nix.Var newtype StdThunk (u :: (* -> *) -> * -> *) (m :: * -> *) = StdThunk @@ -82,6 +84,18 @@ instance ( MonadStdThunk (u m) -- wrapValue = StdThunk . StdCited . wrapValue -- getValue = getValue . _stdCited . _stdThunk +instance ( MonadAtomicRef (u m) + , MonadThunk (StdThunk u m) (StdLazy u m) (StdValue u m) + ) + => MonadValue (StdValue u m) (StdLazy u m) where + defer = fmap Pure . thunk + demand (Pure v) f = force v (flip demand f) + demand (Free v) f = f (Free v) + +instance HasCitations (StdLazy u m) (StdValue u m) (StdThunk u m) where + citations (StdThunk c) = citations1 c + addProvenance x (StdThunk c) = StdThunk (addProvenance1 x c) + instance HasCitations1 (StdLazy u m) (StdValue u m) (StdCited u m) where citations1 (StdCited c) = citations1 c addProvenance1 x (StdCited c) = StdCited (addProvenance1 x c) @@ -107,7 +121,7 @@ runStandard opts action = do runStandardIO :: Options -> StdLazy StdIdT IO a -> IO a runStandardIO = runStandard -whileForcingThunk - :: forall t f m s e r . (Exception s, Convertible e t f m) => s -> m r -> m r -whileForcingThunk frame = - withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame +-- whileForcingThunk +-- :: forall t f m s e r . (Exception s, Convertible e t f m) => s -> m r -> m r +-- whileForcingThunk frame = +-- withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame diff --git a/src/Nix/Value.hs b/src/Nix/Value.hs index c323bcb..1c1c5ce 100644 --- a/src/Nix/Value.hs +++ b/src/Nix/Value.hs @@ -501,6 +501,12 @@ describeValue = \case TPath -> "a path" TBuiltin -> "a builtin function" +showValueType :: (MonadThunk t m (NValue t f m), Comonad f) + => NValue t f m -> m String +showValueType (Pure t) = force t showValueType +showValueType (Free (NValue (extract -> v))) = + pure $ describeValue $ valueType $ v + data ValueFrame t f m = ForcingThunk t | ConcerningValue (NValue t f m)