picnoir/hnix
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Move handling of with statements into MonadEval

Browse source
This commit is contained in:
John Wiegley 2018-04-11 11:53:30 -07:00
parent 8068c7b43e
commit ffa8d85dd2
6 changed files with 90 additions and 73 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
src/Nix/Builtins.hs
View file

@ -70,8 +70,9 @@ import System.Posix.Files
import Text.Regex.TDFA
type MonadBuiltins e m =
(Scoped e (NThunk m) m, MonadCatch m, MonadEffects m,
Framed e m, MonadVar m, MonadFile m, MonadFix m)
(Scoped e (NThunk m) m,
Framed e m, MonadVar m, MonadFile m, MonadCatch m,
MonadEffects m, MonadFix m)
baseEnv :: (MonadBuiltins e m, Scoped e (NThunk m) m)
=> m (Scopes m (NThunk m))

11
src/Nix/Context.hs
View file

@ -9,12 +9,15 @@ import Nix.Stack
import Nix.Utils
data Context m v = Context
{ scopes :: Scopes m v
, frames :: Frames
{ scopes :: Scopes m v
, frames :: Frames
}
instance Has (Context m v) (Scopes m v) where
hasLens f (Context x y) = flip Context y <$> f x
hasLens f (Context x y) = (\x' -> Context x' y) <$> f x
instance Has (Context m v) Frames where
hasLens f (Context x y) = Context x <$> f y
hasLens f (Context x y) = (\y' -> Context x y') <$> f y
newContext :: Context m v
newContext = Context emptyScopes []

13
src/Nix/Eval.hs
View file

@ -56,6 +56,7 @@ class (Show v, Monoid (MText v),
evalBinary :: NBinaryOp -> v -> m v -> m v
-- ^ The second argument is an action because operators such as boolean &&
-- and || may not evaluate the second argument.
evalWith :: m v -> m v -> m v
evalIf :: v -> m v -> m v -> m v
evalAssert :: v -> m v -> m v
evalApp :: v -> m v -> m v
@ -143,17 +144,7 @@ eval (NLet binds e) = do
eval (NIf cond t f) = cond >>= \v -> evalIf v t f
eval (NWith scope body) = do
traceM "NWith"
-- The scope is deliberately wrapped in a thunk here, since the WeakScope
-- constructor argument is evaluated each time a name is looked up within
-- the weak scope, and we want to be sure the action it evaluates is to
-- force a thunk, so its value is only computed once.
s <- thunk scope
pushWeakScope ?? body $ force s $ \v -> case wantVal v of
Just (s :: AttrSet t) -> pure s
_ -> evalError @v $ "scope must be a set in with statement, but saw: "
++ show v
eval (NWith scope body) = evalWith scope body
eval (NAssert cond body) = cond >>= \v -> evalAssert v body

27
src/Nix/Exec.hs
View file

@ -66,7 +66,8 @@ import System.Posix.Files
import System.Process (readProcessWithExitCode)
type MonadExec e m =
(Framed e m, MonadVar m, MonadFile m, MonadEffects m)
(Scoped e (NThunk m) m, Framed e m, MonadVar m, MonadFile m,
MonadEffects m)
nverr :: forall e m a. MonadExec e m => String -> m a
nverr = evalError @(NValue m)
@ -129,8 +130,8 @@ instance MonadExec e m => MonadThunk (NValue m) (NThunk m) m where
value = coerce . valueRef
instance MonadExec e m => MonadEval (NValue m) m where
freeVariable var = nverr $
"Undefined variable '" ++ Text.unpack var ++ "'"
freeVariable var =
nverr $ "Undefined variable '" ++ Text.unpack var ++ "'"
evalCurPos = do
Compose (Ann (SrcSpan delta _) _):_ <-
@ -145,6 +146,20 @@ instance MonadExec e m => MonadEval (NValue m) m where
evalUnary = execUnaryOp
evalBinary = execBinaryOp
evalWith scope body = do
-- The scope is deliberately wrapped in a thunk here, since it is
-- evaluated each time a name is looked up within the weak scope, and
-- we want to be sure the action it evaluates is to force a thunk, so
-- its value is only computed once.
traceM "Evaluating with scope"
s <- thunk scope
pushWeakScope ?? body $ force s $ \v -> case wantVal v of
Just (s :: AttrSet (NThunk m)) -> do
traceM $ "Scope is: " ++ show (void s)
pure s
_ -> nverr $ "scope must be a set in with statement, but saw: "
++ show v
evalIf c t f = case wantVal c of
Just b -> if b then t else f
_ -> nverr $ "condition must be a boolean: "++ show c
@ -199,9 +214,7 @@ execUnaryOp op arg = do
++ " must evaluate to an atomic type: " ++ showValue x
execBinaryOp
:: forall e m.
(Framed e m, MonadVar m, MonadFile m,
MonadEval (NValue m) m, MonadEffects m)
:: forall e m. (MonadExec e m, MonadEval (NValue m) m)
=> NBinaryOp -> NValue m -> m (NValue m) -> m (NValue m)
execBinaryOp NOr larg rarg = case larg of
@ -435,7 +448,7 @@ instance (MonadFix m, MonadThrow m, MonadIO m) => MonadEffects (Lazy m) where
_ -> error "derivationStrict: nix-instantiate failed"
runLazyM :: MonadIO m => Lazy m a -> m a
runLazyM = flip runReaderT (Context emptyScopes []) . runLazy
runLazyM = flip runReaderT newContext . runLazy
-- | Incorrectly normalize paths by rewriting patterns like @a/b/..@ to @a@.
-- This is incorrect on POSIX systems, because if @b@ is a symlink, its

31
src/Nix/Lint.hs
View file

@ -122,6 +122,12 @@ unpackSymbolic :: MonadVar m
=> Symbolic m -> m (NSymbolicF (NTypeF m (SThunk m)))
unpackSymbolic = readVar . coerce
type MonadLint e m =
(Scoped e (SThunk m) m, Framed e m, MonadVar m, MonadFile m)
symerr :: forall e m a. MonadLint e m => String -> m a
symerr = evalError @(Symbolic m)
renderSymbolic :: MonadLint e m => Symbolic m -> m String
renderSymbolic = unpackSymbolic >=> \case
NAny -> return "<any>"
@ -233,12 +239,6 @@ unify context (Symbolic x) (Symbolic y) = do
writeVar y (NMany m)
packSymbolic (NMany m)
type MonadLint e m =
(Framed e m, MonadVar m, MonadFile m)
symerr :: forall e m a. MonadLint e m => String -> m a
symerr = evalError @(Symbolic m)
instance MonadLint e m => ConvertValue (Symbolic m) Bool where
ofVal = const $ error "Should never need to make symbolic from bool"
wantVal = const $ error "Should never need bool value of a symbolic"
@ -323,6 +323,17 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
evalBinary = lintBinaryOp
evalWith scope body = do
-- The scope is deliberately wrapped in a thunk here, since it is
-- evaluated each time a name is looked up within the weak scope, and
-- we want to be sure the action it evaluates is to force a thunk, so
-- its value is only computed once.
s <- thunk scope
pushWeakScope ?? body $ force s $ \v -> case wantVal v of
Just (s :: AttrSet (SThunk m)) -> pure s
_ -> symerr $ "scope must be a set in with statement, but saw: "
++ show v
evalIf cond t f = do
t' <- t
f' <- f
@ -350,9 +361,7 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
projectMText = const $ return Nothing -- jww (2018-04-10): TODO
lintBinaryOp
:: forall e m.
(Framed e m, MonadVar m, MonadFile m,
MonadEval (Symbolic m) m)
:: forall e m. (MonadLint e m, MonadEval (Symbolic m) m)
=> NBinaryOp -> Symbolic m -> m (Symbolic m) -> m (Symbolic m)
lintBinaryOp op lsym rarg = do
rsym <- rarg
@ -438,10 +447,10 @@ instance MonadThrow (Lint s) where
throwM e = Lint $ ReaderT $ \_ -> unsafeIOToST $ throw e
runLintM :: Lint s a -> ST s a
runLintM = flip runReaderT (Context emptyScopes []) . runLint
runLintM = flip runReaderT newContext . runLint
symbolicBaseEnv :: Monad m => m (Scopes m (SThunk m))
symbolicBaseEnv = return [] -- jww (2018-04-02): TODO
symbolicBaseEnv = return emptyScopes
lint :: NExprLoc -> ST s (Symbolic (Lint s))
lint expr = runLintM $

76
src/Nix/Scope.hs
View file

@ -4,6 +4,7 @@
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@ -12,71 +13,70 @@ module Nix.Scope where
import Control.Applicative
import Control.Monad.Reader
import qualified Data.HashMap.Lazy as M
import Data.Semigroup
import Data.Text (Text)
import Nix.Utils
data Scope m a
= Scope (AttrSet a)
| WeakScope (m (AttrSet a))
-- ^ Weak scopes (used by 'with') are delayed until first needed.
newtype Scope a = Scope { getScope :: AttrSet a }
deriving (Functor, Foldable, Traversable)
instance Show (Scope m a) where
instance Show (Scope a) where
show (Scope m) = show (M.keys m)
show (WeakScope _) = "<weak scope>"
newScope :: AttrSet a -> Scope m a
newScope :: AttrSet a -> Scope a
newScope = Scope
newWeakScope :: m (AttrSet a) -> Scope m a
newWeakScope = WeakScope
isWeakScope :: Scope m a -> Bool
isWeakScope (WeakScope _) = True
isWeakScope _ = False
scopeLookup :: Monad m => Text -> [Scope m v] -> m (Maybe v)
scopeLookup key = paraM go Nothing
scopeLookup :: Text -> [Scope v] -> Maybe v
scopeLookup key = foldr go Nothing
where
go (Scope m) _ rest = return $ M.lookup key m <|> rest
go (WeakScope m) ms rest = do
-- If the symbol lookup is in a weak scope, first see if there are any
-- matching symbols from the *non-weak* scopes after this one. If so,
-- prefer that, otherwise perform the lookup here. This way, if there
-- are several weaks scopes in a row, followed by non-weak scopes,
-- we'll first prefer the symbol from the non-weak scopes, and then
-- prefer it from the first weak scope that matched.
mres <- scopeLookup key (filter (not . isWeakScope) ms)
case mres of
Nothing -> m >>= \m' ->
return $ M.lookup key m' <|> rest
_ -> return mres
go (Scope m) rest = M.lookup key m <|> rest
type Scopes m v = [Scope m v]
data Scopes m v = Scopes
{ lexicalScopes :: [Scope v]
, dynamicScopes :: [m (Scope v)]
}
instance Show (Scopes m v) where
show (Scopes m v) =
"Scopes: " ++ show m ++ ", and "
++ show (length v) ++ " with-scopes"
instance Semigroup (Scopes m v) where
Scopes ls lw <> Scopes rs rw = Scopes (ls <> rs) (lw <> rw)
instance Monoid (Scopes m v) where
mempty = emptyScopes
mappend = (<>)
type Scoped e v m = (MonadReader e m, Has e (Scopes m v))
emptyScopes :: Scopes m v
emptyScopes = []
emptyScopes = Scopes [] []
currentScopes :: Scoped e v m => m (Scopes m v)
currentScopes = asks (view hasLens)
clearScopes :: forall v m e r. Scoped e v m => m r -> m r
clearScopes = local (set hasLens ([] :: [Scope m v]))
clearScopes = local (set hasLens (emptyScopes @m @v))
pushScope :: forall v m e r. Scoped e v m => AttrSet v -> m r -> m r
pushScope s = local (over hasLens (Scope @m s :))
pushScope s = pushScopes (Scopes [Scope s] [])
pushWeakScope :: forall v m e r. Scoped e v m
=> m (AttrSet v) -> m r -> m r
pushWeakScope s = local (over hasLens (WeakScope s :))
pushWeakScope :: forall v m e r. Scoped e v m => m (AttrSet v) -> m r -> m r
pushWeakScope s = pushScopes (Scopes [] [Scope <$> s])
pushScopes :: Scoped e v m => Scopes m v -> m r -> m r
pushScopes s = local (over hasLens (s ++))
pushScopes s = local (over hasLens (s <>))
lookupVar :: forall e v m. (Scoped e v m, Monad m) => Text -> m (Maybe v)
lookupVar k = join $ asks (scopeLookup @m k . view hasLens)
lookupVar k = do
mres <- asks (scopeLookup k . lexicalScopes @m . view hasLens)
case mres of
Just sym -> return $ Just sym
Nothing -> do
ws <- asks (dynamicScopes . view hasLens)
foldr (\x -> liftM2 (<|>) (M.lookup k . getScope <$> x))
(return Nothing) ws
withScopes :: forall v m e a. Scoped e v m => Scopes m v -> m a -> m a
withScopes scope = clearScopes @v . pushScopes scope