diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs index b3605c4b..4075bbae 100644 --- a/src/Nix/Eval.hs +++ b/src/Nix/Eval.hs @@ -62,7 +62,9 @@ class (Show v, Monad m) => MonadEval v m | v -> m where evalIf :: v -> m v -> m v -> m v evalAssert :: v -> m v -> m v evalApp :: v -> m v -> m v - evalAbs :: Params (m v) -> (m v -> m v) -> m v + evalAbs :: Params (m v) + -> (forall a. m v -> (AttrSet (m v) -> m v -> m (a, v)) -> m (a, v)) + -> m v {- evalSelect :: v -> NonEmpty Text -> Maybe (m v) -> m v @@ -170,10 +172,10 @@ eval (NAbs params body) = do -- we defer here so the present scope is restored when the parameters and -- body are forced during application. scope <- currentScopes @_ @t - evalAbs params $ \arg -> + evalAbs params $ \arg k -> withScopes @t scope $ do args <- buildArgument params arg - pushScope args body + pushScope args (k (M.map (`force` pure) args) body) -- | If you know that the 'scope' action will result in an 'AttrSet t', then -- this implementation may be used as an implementation for 'evalWith'. diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs index 21e3f65e..975421f8 100644 --- a/src/Nix/Exec.hs +++ b/src/Nix/Exec.hs @@ -209,10 +209,10 @@ instance MonadNix e m => MonadEval (NValue m) m where evalAssert c body = fromValue c >>= \b -> do span <- currentPos if b - then do - scope <- currentScopes - addProvenance (\b -> Provenance scope (NAssert_ span (Just c) (Just b))) <$> body - else nverr $ Assertion span c + then do + scope <- currentScopes + addProvenance (\b -> Provenance scope (NAssert_ span (Just c) (Just b))) <$> body + else nverr $ Assertion span c evalApp f x = do scope <- currentScopes @@ -220,10 +220,11 @@ instance MonadNix e m => MonadEval (NValue m) m where addProvenance (const $ Provenance scope (NBinary_ span NApp (Just f) Nothing)) <$> callFunc f x - evalAbs p b = do + evalAbs p k = do scope <- currentScopes span <- currentPos - pure $ nvClosureP (Provenance scope (NAbs_ span (Nothing <$ p) Nothing)) (void p) b + pure $ nvClosureP (Provenance scope (NAbs_ span (Nothing <$ p) Nothing)) + (void p) (\arg -> snd <$> k arg (\_ b -> ((),) <$> b)) evalError = throwError diff --git a/src/Nix/Lint.hs b/src/Nix/Lint.hs index e90b9ed8..5a4f6add 100644 --- a/src/Nix/Lint.hs +++ b/src/Nix/Lint.hs @@ -64,7 +64,7 @@ data NTypeF (m :: * -> *) r | TStr | TList r | TSet (Maybe (HashMap Text r)) - | TClosure (Params ()) (m (Symbolic m) -> m (Symbolic m)) + | TClosure (Params ()) | TPath | TBuiltin String (SThunk m -> m (Symbolic m)) deriving Functor @@ -140,7 +140,7 @@ renderSymbolic = unpackSymbolic >=> \case TSet (Just s) -> do x <- traverse (`force` renderSymbolic) s return $ "{" ++ show x ++ "}" - f@(TClosure p _) -> do + f@(TClosure p) -> do (args, sym) <- do f' <- mkSymbolic [f] lintApp (NAbs (void p) ()) f' everyPossible @@ -310,7 +310,7 @@ instance MonadLint e m => MonadEval (Symbolic m) m where pure body' evalApp = (fmap snd .) . lintApp (NBinary NApp () ()) - evalAbs params body = mkSymbolic [TClosure (void params) body] + evalAbs params _ = mkSymbolic [TClosure (void params)] evalError = throwError @@ -364,7 +364,7 @@ lintApp context fun arg = unpackSymbolic fun >>= \case "Cannot apply something not known to be a function" NMany xs -> do (args:_, ys) <- fmap unzip $ forM xs $ \case - TClosure _params _f -> arg >>= unpackSymbolic >>= \case + TClosure _params -> arg >>= unpackSymbolic >>= \case NAny -> do error "NYI" diff --git a/src/Nix/Type/Infer.hs b/src/Nix/Type/Infer.hs index a27b58e1..ff5c3fa1 100644 --- a/src/Nix/Type/Infer.hs +++ b/src/Nix/Type/Infer.hs @@ -8,6 +8,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -387,35 +388,39 @@ instance MonadEval (Judgment s) (Infer s) where (cs1 ++ cs2 ++ [EqConst t1 (t2 `TArr` tv)]) tv - evalAbs (Param x) e = do + evalAbs (Param x) k = do tv@(TVar a) <- fresh - Judgment as cs t <- - extendMSet a (e (pure (Judgment (As.singleton x tv) [] tv))) + ((), Judgment as cs t) <- + extendMSet a (k (pure (Judgment (As.singleton x tv) [] tv)) + (\_ b -> ((),) <$> b)) return $ Judgment (as `As.remove` x) (cs ++ [EqConst t' tv | t' <- As.lookup x as]) (tv `TArr` t) - evalAbs (ParamSet ps _variadic _mname) e = do - js <- fmap concat $ forM ps $ \(name, mdef) -> case mdef of - Just _ -> pure [] - Nothing -> do + evalAbs (ParamSet ps variadic _mname) k = do + js <- fmap concat $ forM ps $ \(name, _) -> do tv <- fresh pure [(name, tv)] + let (env, tys) = (\f -> foldl' f (As.empty, M.empty) js) $ \(as1, t1) (k, t) -> (as1 `As.merge` As.singleton k t, M.insert k t t1) + arg = pure $ Judgment env [] (TSet True tys) + call = k arg $ \args b -> (args,) <$> b names = map fst js - Judgment as cs t <- - (\f -> foldr f (e (pure (Judgment env [] (TSet True tys)))) js) - $ \(_, TVar a) rest -> extendMSet a rest + + (args, Judgment as cs t) <- + foldr (\(_, TVar a) -> extendMSet a) call js + + ty <- TSet variadic <$> traverse (inferredType <$>) args + return $ Judgment (foldl' As.remove as names) (cs ++ [ EqConst t' (tys M.! x) | x <- names , t' <- As.lookup x as]) - -- jww (2018-05-01): How do we recover the actual args used? - (t `TArr` t) + (ty `TArr` t) evalError = throwError . EvaluationError