Everything compiling again, but 25 tests failing
This commit is contained in:
parent
92e904beda
commit
2c0c896871
|
@ -586,6 +586,7 @@ executable hnix
|
|||
, deepseq >=1.4.2 && <1.5
|
||||
, exceptions
|
||||
, filepath
|
||||
, free
|
||||
, hashing
|
||||
, haskeline
|
||||
, hnix
|
||||
|
|
13
main/Main.hs
13
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 " ++)
|
||||
|
|
|
@ -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
|
||||
|
|
28
src/Nix.hs
28
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
|
||||
|
@ -140,17 +140,17 @@ processResult h val = do
|
|||
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 '"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in a new issue