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

Abstract Scopes

Browse source
This commit is contained in:
Ryan Trinkle 2018-11-17 16:21:03 -05:00
parent e6b189e69b
commit d60130c566
7 changed files with 80 additions and 48 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
src/Nix/Builtins.hs
View file

@ -110,7 +110,7 @@ withNixContext mpath action = do
let ref = value @(NValue m) @(NThunk m) @m $ nvPath path
pushScope (M.singleton "__cur_file" ref) action
builtins :: (MonadNix e m, Scoped e (NThunk m) m)
builtins :: (MonadNix e m, Scoped (NThunk m) m)
=> m (Scopes m (NThunk m))
builtins = do
ref <- thunk $ flip nvSet M.empty <$> buildMap
@ -296,7 +296,7 @@ builtinsList = sequence [
foldNixPath :: forall e m r. MonadNix e m
=> (FilePath -> Maybe String -> NixPathEntryType -> r -> m r) -> r -> m r
foldNixPath f z = do
mres <- lookupVar @_ @(NThunk m) "__includes"
mres <- lookupVar "__includes"
dirs <- case mres of
Nothing -> return []
Just v -> fromNix @[Text] v
@ -822,7 +822,7 @@ scopedImport asetArg pathArg =
fromValue @(AttrSet (NThunk m)) asetArg >>= \s ->
fromValue pathArg >>= \(Path p) -> do
path <- pathToDefaultNix p
mres <- lookupVar @_ @(NThunk m) "__cur_file"
mres <- lookupVar "__cur_file"
path' <- case mres of
Nothing -> do
traceM "No known current directory"

36
src/Nix/Eval.hs
View file

@ -76,9 +76,9 @@ class (Show v, Monad m) => MonadEval v m | v -> m where
-}
evalError :: Exception s => s -> m a
type MonadNixEval e v t m =
type MonadNixEval v t m =
(MonadEval v m,
Scoped e t m,
Scoped t m,
MonadThunk v t m,
MonadFix m,
ToValue Bool m v,
@ -95,12 +95,12 @@ data EvalFrame m v
instance (Typeable m, Typeable v) => Exception (EvalFrame m v)
eval :: forall e v t m. MonadNixEval e v t m => NExprF (m v) -> m v
eval :: forall v t m. MonadNixEval v t m => NExprF (m v) -> m v
eval (NSym "__curPos") = evalCurPos
eval (NSym var) =
lookupVar var >>= maybe (freeVariable var) (force ?? evaledSym var)
(lookupVar var :: m (Maybe t)) >>= maybe (freeVariable var) (force ?? evaledSym var)
eval (NConstant x) = evalConstant x
eval (NStr str) = evalString str
@ -109,7 +109,7 @@ eval (NEnvPath p) = evalEnvPath p
eval (NUnary op arg) = evalUnary op =<< arg
eval (NBinary NApp fun arg) = do
scope <- currentScopes @_ @t
scope <- currentScopes :: m (Scopes m t)
fun >>= (`evalApp` withScopes scope arg)
eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg
@ -143,25 +143,25 @@ eval (NAbs params body) = do
-- needs to be used when evaluating the body and default arguments, hence
-- we defer here so the present scope is restored when the parameters and
-- body are forced during application.
scope <- currentScopes @_ @t
evalAbs params $ \arg k -> withScopes @t scope $ do
scope <- currentScopes :: m (Scopes m t)
evalAbs params $ \arg k -> withScopes scope $ do
args <- buildArgument params arg
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'.
evalWithAttrSet :: forall e v t m. MonadNixEval e v t m => m v -> m v -> m v
evalWithAttrSet :: forall v t m. MonadNixEval v t m => m v -> m v -> m v
evalWithAttrSet aset 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.
scope <- currentScopes @_ @t
scope <- currentScopes :: m (Scopes m t)
s <- thunk $ withScopes scope aset
pushWeakScope ?? body $ force s $
fmap fst . fromValue @(AttrSet t, AttrSet SourcePos)
attrSetAlter :: forall e v t m. MonadNixEval e v t m
attrSetAlter :: forall v t m. MonadNixEval v t m
=> [Text]
-> SourcePos
-> AttrSet (m v)
@ -208,12 +208,12 @@ desugarBinds embed binds = evalState (mapM (go <=< collect) binds) M.empty
Just (p, v) <- gets $ M.lookup x
pure $ NamedVar (StaticKey x :| []) (embed v) p
evalBinds :: forall e v t m. MonadNixEval e v t m
evalBinds :: forall v t m. MonadNixEval v t m
=> Bool
-> [Binding (m v)]
-> m (AttrSet t, AttrSet SourcePos)
evalBinds recursive binds = do
scope <- currentScopes @_ @t
scope <- currentScopes :: m (Scopes m t)
buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds)
where
moveOverridesLast = uncurry (++) .
@ -278,7 +278,7 @@ evalBinds recursive binds = do
insert (m, p) (path, pos, value) = attrSetAlter path pos m p value
evalSelect :: forall e v t m. MonadNixEval e v t m
evalSelect :: forall v t m. MonadNixEval v t m
=> m v
-> NAttrPath (m v)
-> m (Either (v, NonEmpty Text) (m v))
@ -324,10 +324,10 @@ assembleString = \case
go = runAntiquoted "\n" (pure . Just . hackyMakeNixStringWithoutContext) (>>= fromValueMay)
buildArgument :: forall e v t m. MonadNixEval e v t m
buildArgument :: forall v t m. MonadNixEval v t m
=> Params (m v) -> m v -> m (AttrSet t)
buildArgument params arg = do
scope <- currentScopes @_ @t
scope <- currentScopes :: m (Scopes m t)
case params of
Param name -> M.singleton name <$> thunk (withScopes scope arg)
ParamSet s isVariadic m ->
@ -364,15 +364,15 @@ addSourcePositions f v@(Fix (Compose (Ann ann _))) =
local (set hasLens ann) (f v)
addStackFrames
:: forall t e m a. (Scoped e t m, Framed e m, Typeable t, Typeable m)
:: forall t e m a. (Scoped t m, Framed e m, Typeable t, Typeable m)
=> Transform NExprLocF (m a)
addStackFrames f v = do
scopes <- currentScopes @e @t
scopes <- currentScopes :: m (Scopes m t)
withFrame Info (EvaluatingExpr scopes v) (f v)
framedEvalExprLoc
:: forall t e v m.
(MonadNixEval e v t m, Framed e m, Has e SrcSpan,
(MonadNixEval v t m, Framed e m, Has e SrcSpan,
Typeable t, Typeable m)
=> NExprLoc -> m v
framedEvalExprLoc = adi (eval . annotated . getCompose)

18
src/Nix/Exec.hs
View file

@ -84,7 +84,7 @@ import GHC.DataSize
#endif
type MonadNix e m =
(Scoped e (NThunk m) m, Framed e m, Has e SrcSpan, Has e Options,
(Scoped (NThunk m) m, Framed e m, Has e SrcSpan, Has e Options,
Typeable m, MonadVar m, MonadEffects m, MonadFix m, MonadCatch m,
Alternative m)
@ -516,7 +516,7 @@ instance (MonadFix m, MonadCatch m, MonadFile m, MonadStore m, MonadVar m,
origPathExpanded <- expandHomePath origPath
absPath <- if isAbsolute origPathExpanded then pure origPathExpanded else do
cwd <- do
mres <- lookupVar @_ @(NThunk (Lazy m)) "__cur_file"
mres <- lookupVar "__cur_file"
case mres of
Nothing -> getCurrentDirectory
Just v -> force v $ \case
@ -661,7 +661,7 @@ findPathM l name = findPathBy path l name
findEnvPathM :: forall e m. MonadNix e m
=> FilePath -> m FilePath
findEnvPathM name = do
mres <- lookupVar @_ @(NThunk m) "__nixPath"
mres <- lookupVar "__nixPath"
case mres of
Nothing -> error "impossible"
Just x -> force x $ fromValue >=> \(l :: [NThunk m]) ->
@ -713,7 +713,7 @@ evalExprLoc expr = do
expr
else adi phi (addStackFrames @(NThunk m) . addSourcePositions) expr
where
phi = Eval.eval @_ @(NValue m) @(NThunk m) @m . annotated . getCompose
phi = Eval.eval . annotated . getCompose
raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x
fetchTarball :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
@ -753,8 +753,14 @@ fetchTarball v = v >>= \case
++ "url = \"" ++ Text.unpack url ++ "\"; "
++ "sha256 = \"" ++ Text.unpack sha ++ "\"; }"
exec :: (MonadExec m, Framed e m, MonadThrow m, Alternative m, MonadCatch m, MonadFix m, MonadEffects m, GEq (Ref m), MonadAtomicRef m, Typeable m, Has e (Scopes m (NThunk m)), Has e Options, Has e SrcSpan) => [String] -> m (NValue m)
exec :: (MonadExec m, Framed e m, MonadThrow m, Alternative m, MonadCatch m, MonadFix m, MonadEffects m, GEq (Ref m), MonadAtomicRef m, Typeable m, Has e Options, Has e SrcSpan, Scoped (NThunk m) m) => [String] -> m (NValue m)
exec args = either throwError evalExprLoc =<< exec' args
nixInstantiateExpr :: (MonadInstantiate m, Framed e m, MonadThrow m, Alternative m, MonadCatch m, MonadFix m, MonadEffects m, GEq (Ref m), MonadAtomicRef m, Typeable m, Has e (Scopes m (NThunk m)), Has e Options, Has e SrcSpan) => String -> m (NValue m)
nixInstantiateExpr :: (MonadInstantiate m, Framed e m, MonadThrow m, Alternative m, MonadCatch m, MonadFix m, MonadEffects m, GEq (Ref m), MonadAtomicRef m, Typeable m, Has e Options, Has e SrcSpan, Scoped (NThunk m) m) => String -> m (NValue m)
nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s
instance Monad m => Scoped (NThunk (Lazy m)) (Lazy m) where
currentScopes = currentScopesReader
clearScopes = clearScopesReader @(Lazy m) @(NThunk (Lazy m))
pushScopes = pushScopesReader
lookupVar = lookupVarReader

8
src/Nix/Lint.hs
View file

@ -117,7 +117,7 @@ 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,
type MonadLint e m = (Scoped (SThunk m) m, Framed e m, MonadVar m,
MonadCatch m)
symerr :: forall e m a. MonadLint e m => String -> m a
@ -423,3 +423,9 @@ lint opts expr = runLintM opts $
>>= (`pushScopes`
adi (Eval.eval . annotated . getCompose)
Eval.addSourcePositions expr)
instance Scoped (SThunk (Lint s)) (Lint s) where
currentScopes = currentScopesReader
clearScopes = clearScopesReader @(Lint s) @(SThunk (Lint s))
pushScopes = pushScopesReader
lookupVar = lookupVarReader

14
src/Nix/Reduce.hs
View file

@ -72,8 +72,8 @@ newtype Reducer m a = Reducer
MonadState (HashMap FilePath NExprLoc))
staticImport
:: forall e m.
(MonadIO m, Scoped e NExprLoc m,
:: forall m.
(MonadIO m, Scoped NExprLoc m,
MonadReader (Maybe FilePath, Scopes m NExprLoc) m,
MonadState (HashMap FilePath NExprLoc) m)
=> SrcSpan -> FilePath -> m NExprLoc
@ -118,8 +118,8 @@ reduceExpr mpath expr
. runReducer
$ cata reduce expr
reduce :: forall e m.
(MonadIO m, Scoped e NExprLoc m,
reduce :: forall m.
(MonadIO m, Scoped NExprLoc m,
MonadReader (Maybe FilePath, Scopes m NExprLoc) m,
MonadState (HashMap FilePath NExprLoc) m)
=> NExprLocF (m NExprLoc) -> m NExprLoc
@ -407,3 +407,9 @@ reducingEvalExpr eval mpath expr = do
return (fromMaybe nNull expr'', eres)
where
addEvalFlags k (FlaggedF (b, x)) = liftIO (writeIORef b True) *> k x
instance Monad m => Scoped NExprLoc (Reducer m) where
currentScopes = currentScopesReader
clearScopes = clearScopesReader @(Reducer m) @NExprLoc
pushScopes = pushScopesReader
lookupVar = lookupVarReader

39
src/Nix/Scope.hs
View file

@ -1,10 +1,13 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@ -49,28 +52,32 @@ 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 :: forall m v. Scopes m v
emptyScopes = Scopes [] []
currentScopes :: Scoped e v m => m (Scopes m v)
currentScopes = asks (view hasLens)
class Scoped t m | m -> t where
currentScopes :: m (Scopes m t)
clearScopes :: m a -> m a
pushScopes :: Scopes m t -> m a -> m a
lookupVar :: Text -> m (Maybe t)
clearScopes :: forall v m e r. Scoped e v m => m r -> m r
clearScopes = local (set hasLens (emptyScopes @m @v))
currentScopesReader :: forall m t e. (MonadReader e m, Has e (Scopes m t)) => m (Scopes m t)
currentScopesReader = asks (view hasLens)
pushScope :: forall v m e r. Scoped e v m => AttrSet v -> m r -> m r
clearScopesReader :: forall m t e a. (MonadReader e m, Has e (Scopes m t)) => m a -> m a
clearScopesReader = local (set hasLens (emptyScopes @m @t))
pushScope :: Scoped t m => AttrSet t -> m a -> m a
pushScope s = pushScopes (Scopes [Scope s] [])
pushWeakScope :: forall v m e r. Scoped e v m => m (AttrSet v) -> m r -> m r
pushWeakScope :: (Functor m, Scoped t m) => m (AttrSet t) -> m a -> m a
pushWeakScope s = pushScopes (Scopes [] [Scope <$> s])
pushScopes :: Scoped e v m => Scopes m v -> m r -> m r
pushScopes s = local (over hasLens (s <>))
pushScopesReader :: (MonadReader e m, Has e (Scopes m t)) => Scopes m t -> m a -> m a
pushScopesReader s = local (over hasLens (s <>))
lookupVar :: forall e v m. (Scoped e v m, Monad m) => Text -> m (Maybe v)
lookupVar k = do
lookupVarReader :: forall m t e. (MonadReader e m, Has e (Scopes m t)) => Text -> m (Maybe t)
lookupVarReader k = do
mres <- asks (scopeLookup k . lexicalScopes @m . view hasLens)
case mres of
Just sym -> return $ Just sym
@ -83,5 +90,5 @@ lookupVar k = do
Nothing -> rest)
(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
withScopes :: Scoped t m => Scopes m t -> m a -> m a
withScopes scope = clearScopes . pushScopes scope

7
src/Nix/Type/Infer.hs
View file

@ -9,6 +9,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
@ -616,3 +617,9 @@ solve cs = solve' (nextSolvable cs)
solve' (ExpInstConst t s, cs) = do
s' <- lift $ instantiate s
solve (EqConst t s' : cs)
instance Scoped (JThunk s) (Infer s) where
currentScopes = currentScopesReader
clearScopes = clearScopesReader @(Infer s) @(JThunk s)
pushScopes = pushScopesReader
lookupVar = lookupVarReader