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

Use Exception rather than Frame, reduce constraints imposed by forceThunk

Browse source
This commit is contained in:
John Wiegley 2018-05-01 20:33:17 -04:00
parent c40bc0eadb
commit acda2b3337
10 changed files with 159 additions and 157 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

109
src/Nix/Builtins.hs
View file

@ -111,7 +111,7 @@ builtinsList = sequence [
, add0 Normal "nixPath" nixPath
, add TopLevel "abort" throw_ -- for now
, add2 Normal "add" add_
, add2 Normal "add" add_
, add2 Normal "all" all_
, add2 Normal "any" any_
, add Normal "attrNames" attrNames
@ -201,7 +201,8 @@ builtinsList = sequence [
arity1 f = Prim . pure . f
arity2 f = ((Prim . pure) .) . f
mkThunk n = thunk . withFrame Info ("While calling builtin " ++ Text.unpack n ++ "\n")
mkThunk n = thunk . withFrame Info
(ErrorCall $ "While calling builtin " ++ Text.unpack n ++ "\n")
add0 t n v = wrap t n <$> mkThunk n v
add t n v = wrap t n <$> mkThunk n (builtin (Text.unpack n) v)
@ -228,7 +229,7 @@ foldNixPath f z = do
go x rest = case Text.splitOn "=" x of
[p] -> f (Text.unpack p) Nothing rest
[n, p] -> f (Text.unpack p) (Just (Text.unpack n)) rest
_ -> throwError @String $ "Unexpected entry in NIX_PATH: " ++ show x
_ -> throwError $ ErrorCall $ "Unexpected entry in NIX_PATH: " ++ show x
nixPath :: MonadNix e m => m (NValue m)
nixPath = fmap nvList $ flip foldNixPath [] $ \p mn rest ->
@ -242,23 +243,22 @@ toString :: MonadNix e m => m (NValue m) -> m (NValue m)
toString str =
str >>= normalForm >>= valueText False >>= toNix @(Text, DList Text)
hasAttr :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
hasAttr x y = x >>= \x' -> y >>= \y' -> case (x', y') of
(NVStr key _, NVSet aset _) ->
return . nvConstant . NBool $ M.member key aset
(x, y) -> throwError @String $ "Invalid types for builtin.hasAttr: "
++ show (x, y)
hasAttr :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
hasAttr x y =
fromValue @Text x >>= \key ->
fromValue @(AttrSet (NThunk m), AttrSet SourcePos) y >>= \(aset, _) ->
toNix $ M.member key aset
attrsetGet :: MonadNix e m => Text -> AttrSet t -> m t
attrsetGet k s = case M.lookup k s of
Just v -> pure v
Nothing ->
throwError ("Attribute '" ++ Text.unpack k ++ "' required" :: String)
throwError $ ErrorCall $ "Attribute '" ++ Text.unpack k ++ "' required"
getAttr :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
getAttr x y = x >>= \x' -> y >>= \y' -> case (x', y') of
(NVStr key _, NVSet aset _) -> attrsetGet key aset >>= force'
(x, y) -> throwError @String $ "Invalid types for builtin.getAttr: "
(x, y) -> throwError $ ErrorCall $ "Invalid types for builtin.getAttr: "
++ show (x, y)
unsafeGetAttrPos :: forall e m. MonadNix e m
@ -266,10 +266,10 @@ unsafeGetAttrPos :: forall e m. MonadNix e m
unsafeGetAttrPos x y = x >>= \x' -> y >>= \y' -> case (x', y') of
(NVStr key _, NVSet _ apos) -> case M.lookup key apos of
Nothing ->
throwError @String $ "unsafeGetAttrPos: field '" ++ Text.unpack key
throwError $ ErrorCall $ "unsafeGetAttrPos: field '" ++ Text.unpack key
++ "' does not exist in attr set: " ++ show apos
Just delta -> toValue delta
(x, y) -> throwError @String $ "Invalid types for builtin.unsafeGetAttrPos: "
(x, y) -> throwError $ ErrorCall $ "Invalid types for builtin.unsafeGetAttrPos: "
++ show (x, y)
-- This function is a bit special in that it doesn't care about the contents
@ -340,12 +340,12 @@ foldl'_ fun z xs =
head_ :: MonadNix e m => m (NValue m) -> m (NValue m)
head_ = fromValue >=> \case
[] -> throwError @String "builtins.head: empty list"
[] -> throwError $ ErrorCall "builtins.head: empty list"
h:_ -> force' h
tail_ :: MonadNix e m => m (NValue m) -> m (NValue m)
tail_ = fromValue >=> \case
[] -> throwError @String "builtins.tail: empty list"
[] -> throwError $ ErrorCall "builtins.tail: empty list"
_:t -> return $ nvList t
data VersionComponent
@ -470,7 +470,7 @@ thunkStr s = valueThunk (nvStr (decodeUtf8 s) mempty)
substring :: MonadNix e m => Int -> Int -> Text -> Prim m Text
substring start len str = Prim $
if start < 0 --NOTE: negative values of 'len' are OK
then throwError @String $ "builtins.substring: negative start position: " ++ show start
then throwError $ ErrorCall $ "builtins.substring: negative start position: " ++ show start
else pure $ Text.take len $ Text.drop start str
attrNames :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
@ -483,7 +483,8 @@ attrValues = fromValue @(ValueSet m) >=>
map_ :: forall e m. MonadNix e m
=> m (NValue m) -> m (NValue m) -> m (NValue m)
map_ fun xs = fun >>= \f ->
toNix <=< traverse (thunk . withFrame @String Debug "While applying f in map:\n"
toNix <=< traverse (thunk . withFrame Debug
(ErrorCall "While applying f in map:\n")
. (f `callFunc`) . force')
<=< fromValue @[NThunk m] $ xs
@ -503,13 +504,13 @@ baseNameOf :: MonadNix e m => m (NValue m) -> m (NValue m)
baseNameOf x = x >>= \case
NVStr path ctx -> pure $ nvStr (Text.pack $ takeFileName $ Text.unpack path) ctx
NVPath path -> pure $ nvPath $ takeFileName path
v -> throwError @String $ "dirOf: expected string or path, got " ++ show v
v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " ++ show v
dirOf :: MonadNix e m => m (NValue m) -> m (NValue m)
dirOf x = x >>= \case
NVStr path ctx -> pure $ nvStr (Text.pack $ takeDirectory $ Text.unpack path) ctx
NVPath path -> pure $ nvPath $ takeDirectory path
v -> throwError @String $ "dirOf: expected string or path, got " ++ show v
v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " ++ show v
-- jww (2018-04-28): This should only be a string argument, and not coerced?
unsafeDiscardStringContext :: MonadNix e m => m (NValue m) -> m (NValue m)
@ -542,7 +543,7 @@ elemAt_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
elemAt_ xs n = fromValue n >>= \n' -> fromValue xs >>= \xs' ->
case elemAt xs' n' of
Just a -> force' a
Nothing -> throwError @String $ "builtins.elem: Index " ++ show n'
Nothing -> throwError $ ErrorCall $ "builtins.elem: Index " ++ show n'
++ " too large for list of length " ++ show (length xs')
genList :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
@ -550,24 +551,22 @@ genList generator = fromValue @Integer >=> \n ->
if n >= 0
then generator >>= \f ->
toNix =<< forM [0 .. n - 1] (\i -> thunk $ f `callFunc` toNix i)
else throwError @String $ "builtins.genList: Expected a non-negative number, got "
else throwError $ ErrorCall $ "builtins.genList: Expected a non-negative number, got "
++ show n
genericClosure :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
genericClosure = fromValue @(AttrSet (NThunk m)) >=> \s ->
case (M.lookup "startSet" s, M.lookup "operator" s) of
(Nothing, Nothing) ->
throwError
("builtins.genericClosure: Attributes 'startSet' and 'operator' required"
:: String)
throwError $ ErrorCall $
"builtins.genericClosure: "
++ "Attributes 'startSet' and 'operator' required"
(Nothing, Just _) ->
throwError
("builtins.genericClosure: Attribute 'startSet' required"
:: String)
throwError $ ErrorCall $
"builtins.genericClosure: Attribute 'startSet' required"
(Just _, Nothing) ->
throwError
("builtins.genericClosure: Attribute 'operator' required"
:: String)
throwError $ ErrorCall $
"builtins.genericClosure: Attribute 'operator' required"
(Just startSet, Just operator) ->
fromValue @[NThunk m] startSet >>= \ss ->
force operator $ \op ->
@ -580,8 +579,8 @@ genericClosure = fromValue @(AttrSet (NThunk m)) >=> \s ->
force t $ \v -> fromValue @(AttrSet (NThunk m)) t >>= \s ->
case M.lookup "key" s of
Nothing ->
throwError
("builtins.genericClosure: Attribute 'key' required" :: String)
throwError $ ErrorCall $
"builtins.genericClosure: Attribute 'key' required"
Just k -> force k $ \k' ->
if S.member k' ks
then go op ts ks
@ -598,8 +597,9 @@ replaceStrings tfrom tto ts =
fromNix tto >>= \(to :: [Text]) ->
fromValue ts >>= \(s :: Text) -> do
when (length from /= length to) $
throwError @String $ "'from' and 'to' arguments to 'replaceStrings'"
++ " have different lengths"
throwError $ ErrorCall $
"'from' and 'to' arguments to 'replaceStrings'"
++ " have different lengths"
let lookupPrefix s = do
(prefix, replacement) <-
find ((`Text.isPrefixOf` s) . fst) $ zip from to
@ -646,8 +646,8 @@ functionArgs fun = fun >>= \case
case p of
Param name -> M.singleton name False
ParamSet s _ _ -> isJust <$> M.fromList s
v -> throwError @String $ "builtins.functionArgs: expected function, got "
++ show v
v -> throwError $ ErrorCall $
"builtins.functionArgs: expected function, got " ++ show v
toPath :: MonadNix e m => m (NValue m) -> m (NValue m)
toPath = fromValue @Path >=> toNix @Path
@ -656,7 +656,8 @@ pathExists_ :: MonadNix e m => m (NValue m) -> m (NValue m)
pathExists_ path = path >>= \case
NVPath p -> toNix =<< pathExists p
NVStr s _ -> toNix =<< pathExists (Text.unpack s)
v -> throwError @String $ "builtins.pathExists: expected path, got " ++ show v
v -> throwError $ ErrorCall $
"builtins.pathExists: expected path, got " ++ show v
hasKind :: forall a e m. (MonadNix e m, FromValue a m (NValue m))
=> m (NValue m) -> m (NValue m)
@ -689,7 +690,7 @@ isFunction func = func >>= \case
_ -> toValue False
throw_ :: MonadNix e m => m (NValue m) -> m (NValue m)
throw_ = fromValue >=> throwError . Text.unpack
throw_ = fromValue >=> throwError . ErrorCall . Text.unpack
import_ :: MonadNix e m => m (NValue m) -> m (NValue m)
import_ = fromValue >=> importPath M.empty . getPath
@ -723,8 +724,9 @@ sort_ comparator xs = comparator >>= \comp ->
lessThan :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
lessThan ta tb = ta >>= \va -> tb >>= \vb -> do
let badType = throwError @String $ "builtins.lessThan: expected two numbers or two strings, "
++ "got " ++ show va ++ " and " ++ show vb
let badType = throwError $ ErrorCall $
"builtins.lessThan: expected two numbers or two strings, "
++ "got " ++ show va ++ " and " ++ show vb
nvConstant . NBool <$> case (va, vb) of
(NVConstant ca, NVConstant cb) -> case (ca, cb) of
(NInt a, NInt b) -> pure $ a < b
@ -746,7 +748,10 @@ listToAttrs = fromValue @[NThunk m] >=> \l ->
forM l $ fromValue @(AttrSet (NThunk m)) >=> \s ->
case (M.lookup "name" s, M.lookup "value" s) of
(Just name, Just value) -> fromValue name <&> (, value)
_ -> throwError $
_ -> throwError $ ErrorCall $
-- jww (2018-05-01): Rather than include the function name
-- in the message like this, we should add it as a frame
-- in `callFunc' before calling each builtin.
"builtins.listToAttrs: expected set with name and value, got"
++ show s
@ -757,7 +762,7 @@ hashString algo s = Prim $ do
"sha1" -> pure SHA1.hash
"sha256" -> pure SHA256.hash
"sha512" -> pure SHA512.hash
_ -> throwError @String $ "builtins.hashString: "
_ -> throwError $ ErrorCall $ "builtins.hashString: "
++ "expected \"md5\", \"sha1\", \"sha256\", or \"sha512\", got " ++ show algo
pure $ decodeUtf8 $ Base16.encode $ hash $ encodeUtf8 s
@ -766,10 +771,10 @@ absolutePathFromValue = \case
NVStr pathText _ -> do
let path = Text.unpack pathText
unless (isAbsolute path) $
throwError @String $ "string " ++ show path ++ " doesn't represent an absolute path"
throwError $ ErrorCall $ "string " ++ show path ++ " doesn't represent an absolute path"
pure path
NVPath path -> pure path
v -> throwError @String $ "expected a path, got " ++ show v
v -> throwError $ ErrorCall $ "expected a path, got " ++ show v
readFile_ :: MonadNix e m => m (NValue m) -> m (NValue m)
readFile_ path =
@ -806,7 +811,8 @@ readDir_ pathThunk = do
fromJSON :: MonadNix e m => m (NValue m) -> m (NValue m)
fromJSON = fromValue >=> \encoded ->
case A.eitherDecodeStrict' @A.Value $ encodeUtf8 encoded of
Left jsonError -> throwError @String $ "builtins.fromJSON: " ++ jsonError
Left jsonError ->
throwError $ ErrorCall $ "builtins.fromJSON: " ++ jsonError
Right v -> toValue v
toXML_ :: MonadNix e m => m (NValue m) -> m (NValue m)
@ -846,19 +852,20 @@ tryEval e = catch (onSuccess <$> e) (pure . onError)
fetchTarball :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
fetchTarball v = v >>= \case
NVSet s _ -> case M.lookup "url" s of
Nothing -> throwError @String "builtins.fetchTarball: Missing url attribute"
Nothing -> throwError $ ErrorCall
"builtins.fetchTarball: Missing url attribute"
Just url -> force url $ go (M.lookup "sha256" s)
v@NVStr {} -> go Nothing v
v@(NVConstant (NUri _)) -> go Nothing v
v -> throwError @String $ "builtins.fetchTarball: Expected URI or set, got "
++ show v
v -> throwError $ ErrorCall $
"builtins.fetchTarball: Expected URI or set, got " ++ show v
where
go :: Maybe (NThunk m) -> NValue m -> m (NValue m)
go msha = \case
NVStr uri _ -> fetch uri msha
NVConstant (NUri uri) -> fetch uri msha
v -> throwError @String $ "builtins.fetchTarball: Expected URI or string, got "
++ show v
v -> throwError $ ErrorCall $
"builtins.fetchTarball: Expected URI or string, got " ++ show v
{- jww (2018-04-11): This should be written using pipes in another module
fetch :: Text -> Maybe (NThunk m) -> m (NValue m)
@ -868,7 +875,7 @@ fetchTarball v = v >>= \case
".bz2" -> undefined
".xz" -> undefined
".tar" -> undefined
ext -> throwError @String $ "builtins.fetchTarball: Unsupported extension '"
ext -> throwError $ ErrorCall $ "builtins.fetchTarball: Unsupported extension '"
++ ext ++ "'"
-}

2
src/Nix/Convert.hs
View file

@ -440,7 +440,7 @@ instance Applicative m => ToValue Bool m (NExprF r) where
instance Applicative m => ToValue () m (NExprF r) where
toValue _ = pure . NConstant $ NNull
whileForcingThunk :: forall s e m r. (Framed e m, Frame s, Typeable m)
whileForcingThunk :: forall s e m r. (Framed e m, Exception s, Typeable m)
=> s -> m r -> m r
whileForcingThunk frame =
withFrame Debug (ForcingThunk @m) . withFrame Debug frame

22
src/Nix/Eval.hs
View file

@ -81,7 +81,7 @@ class (Show v, Monad m) => MonadEval v m | v -> m where
evalLet :: m v -> m v
-}
evalError :: Frame s => s -> m a
evalError :: Exception s => s -> m a
type MonadNixEval e v t m =
(MonadEval v m,
@ -99,7 +99,7 @@ data EvalFrame m v
| ForcingExpr (Scopes m v) NExprLoc
deriving (Show, Typeable)
instance (Typeable m, Typeable v) => Frame (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
@ -128,7 +128,7 @@ eval (NSelect aset attr alt) = do
Right v -> v
Left (s, ks) -> fromMaybe err alt
where
err = evalError @v $ "Could not look up attribute "
err = evalError @v $ ErrorCall $ "Could not look up attribute "
++ intercalate "." (map Text.unpack (NE.toList ks))
++ " in " ++ show @v s
@ -199,7 +199,7 @@ attrSetAlter :: forall e v t m. MonadNixEval e v t m
-> m v
-> m (AttrSet (m v))
attrSetAlter [] _ _ =
evalError @v ("invalid selector with no components" :: String)
evalError @v $ ErrorCall "invalid selector with no components"
attrSetAlter (p:ps) m val = case M.lookup p m of
Nothing
| null ps -> go
@ -289,8 +289,8 @@ evalBinds allowDynamic recursive binds = do
>>= \(s, _) ->
clearScopes @t $ pushScope s $ lookupVar key
case mv of
Nothing -> evalError @v $ "Inheriting unknown attribute: "
++ show (void name)
Nothing -> evalError @v $ ErrorCall $
"Inheriting unknown attribute: " ++ show (void name)
Just v -> force v pure)
buildResult :: Scopes m t
@ -356,14 +356,14 @@ evalKeyNameStatic :: forall v m. MonadEval v m
evalKeyNameStatic = \case
StaticKey k p -> pure (k, p)
DynamicKey _ ->
evalError @v ("dynamic attribute not allowed in this context" :: String)
evalError @v $ ErrorCall "dynamic attribute not allowed in this context"
evalKeyNameDynamicNotNull
:: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
=> NKeyName (m v) -> m (Text, Maybe SourcePos)
evalKeyNameDynamicNotNull = evalKeyNameDynamicNullable >=> \case
(Nothing, _) ->
evalError @v ("value is null while a string was expected" :: String)
evalError @v $ ErrorCall "value is null while a string was expected"
(Just k, p) -> pure (k, p)
-- | Evaluate a component of an attribute path in a context where we are
@ -421,12 +421,14 @@ buildArgument params arg = do
-> m t
assemble scope isVariadic k = \case
That Nothing ->
const $ evalError @v $ "Missing value for parameter: " ++ show k
const $ evalError @v $ ErrorCall $
"Missing value for parameter: " ++ show k
That (Just f) -> \args ->
thunk $ withScopes scope $ pushScope args f
This x | isVariadic -> const (pure x)
| otherwise ->
const $ evalError @v $ "Unexpected parameter: " ++ show k
const $ evalError @v $ ErrorCall $
"Unexpected parameter: " ++ show k
These x _ -> const (pure x)
addSourcePositions :: (MonadReader e m, Has e SrcSpan)

96
src/Nix/Exec.hs
View file

@ -88,9 +88,9 @@ type MonadNix e m =
data ExecFrame m = Assertion SrcSpan (NValue m)
deriving (Show, Typeable)
instance Typeable m => Frame (ExecFrame m)
instance Typeable m => Exception (ExecFrame m)
nverr :: forall s e m a. (MonadNix e m, Frame s) => s -> m a
nverr :: forall s e m a. (MonadNix e m, Exception s) => s -> m a
nverr = evalError @(NValue m)
currentPos :: forall e m. (MonadReader e m, Has e SrcSpan) => m SrcSpan
@ -109,8 +109,9 @@ instance MonadNix e m => MonadThunk (NValue m) (NThunk m) m where
-- Gather the current evaluation context at the time of thunk
-- creation, and record it along with the thunk.
let go (fromFrame -> Just (EvaluatingExpr scope
(Fix (Compose (Ann span e))))) =
let go (fromException ->
Just (EvaluatingExpr scope
(Fix (Compose (Ann span e))))) =
let e' = Compose (Ann span (Nothing <$ e))
in [Provenance scope e']
go _ = []
@ -120,11 +121,17 @@ instance MonadNix e m => MonadThunk (NValue m) (NThunk m) m where
else
fmap (NThunk [] . coerce) . buildThunk $ mv
force (NThunk ps t) f = case ps of
[] -> forceThunk t f
Provenance scope e@(Compose (Ann span _)):_ ->
withFrame Info (ForcingExpr scope (wrapExprLoc span e))
(forceThunk t f)
-- The ThunkLoop exception is thrown as an exception with MonadThrow,
-- which does not capture the current stack frame information to provide
-- it in a NixException, so we catch and re-throw it here using
-- 'throwError' from Frames.hs.
force (NThunk ps t) f = catch go (throwError @ThunkLoop)
where
go = case ps of
[] -> forceThunk t f
Provenance scope e@(Compose (Ann span _)):_ ->
withFrame Info (ForcingExpr scope (wrapExprLoc span e))
(forceThunk t f)
value = NThunk [] . coerce . valueRef
@ -140,7 +147,7 @@ prov p v = do
instance MonadNix e m => MonadEval (NValue m) m where
freeVariable var =
nverr $ "Undefined variable '" ++ Text.unpack var ++ "'"
nverr $ ErrorCall $ "Undefined variable '" ++ Text.unpack var ++ "'"
evalCurPos = do
scope <- currentScopes
@ -164,7 +171,7 @@ instance MonadNix e m => MonadEval (NValue m) m where
span <- currentPos
pure $ nvStrP (Provenance scope
(NStr_ span (DoubleQuoted [Plain s]))) s c
Nothing -> nverr ("Failed to assemble string" :: String)
Nothing -> nverr $ ErrorCall $ "Failed to assemble string"
evalLiteralPath p = do
scope <- currentScopes
@ -233,7 +240,7 @@ callFunc fun arg = case fun of
s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do
traceM "callFunc:__functor"
force f $ (`callFunc` pure s) >=> (`callFunc` arg)
x -> throwError $ "Attempt to call non-function: " ++ show x
x -> throwError $ ErrorCall $ "Attempt to call non-function: " ++ show x
execUnaryOp :: (Framed e m, MonadVar m)
=> Scopes m (NThunk m) -> SrcSpan -> NUnaryOp -> NValue m
@ -245,9 +252,9 @@ execUnaryOp scope span op arg = do
(NNeg, NInt i) -> unaryOp $ NInt (-i)
(NNeg, NFloat f) -> unaryOp $ NFloat (-f)
(NNot, NBool b) -> unaryOp $ NBool (not b)
_ -> throwError $ "unsupported argument type for unary operator "
++ show op
x -> throwError $ "argument to unary operator"
_ -> throwError $ ErrorCall $
"unsupported argument type for unary operator " ++ show op
x -> throwError $ ErrorCall $ "argument to unary operator"
++ " must evaluate to an atomic type: " ++ show x
where
unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (Just arg)))
@ -291,16 +298,16 @@ execBinaryOp scope span op lval rarg = do
(NGt, l, r) -> toBool $ l > r
(NGte, l, r) -> toBool $ l >= r
(NAnd, _, _) ->
nverr @String "should be impossible: && is handled above"
nverr $ ErrorCall "should be impossible: && is handled above"
(NOr, _, _) ->
nverr @String "should be impossible: || is handled above"
nverr $ ErrorCall "should be impossible: || is handled above"
(NPlus, l, r) -> numBinOp bin (+) l r
(NMinus, l, r) -> numBinOp bin (-) l r
(NMult, l, r) -> numBinOp bin (*) l r
(NDiv, l, r) -> numBinOp' bin div (/) l r
(NImpl,
NBool l, NBool r) -> toBool $ not l || r
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVStr ls lc, NVStr rs rc) -> case op of
NPlus -> pure $ bin nvStrP (ls `mappend` rs) (lc `mappend` rc)
@ -310,68 +317,68 @@ execBinaryOp scope span op lval rarg = do
NLte -> toBool $ ls <= rs
NGt -> toBool $ ls > rs
NGte -> toBool $ ls >= rs
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVStr _ _, NVConstant NNull) -> case op of
NEq -> toBool =<< valueEq lval (nvStr "" mempty)
NNEq -> toBool . not =<< valueEq lval (nvStr "" mempty)
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVConstant NNull, NVStr _ _) -> case op of
NEq -> toBool =<< valueEq (nvStr "" mempty) rval
NNEq -> toBool . not =<< valueEq (nvStr "" mempty) rval
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVSet ls lp, NVSet rs rp) -> case op of
NUpdate -> pure $ bin nvSetP (rs `M.union` ls) (rp `M.union` lp)
NEq -> toBool =<< valueEq lval rval
NNEq -> toBool . not =<< valueEq lval rval
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVSet ls lp, NVConstant NNull) -> case op of
NUpdate -> pure $ bin nvSetP ls lp
NEq -> toBool =<< valueEq lval (nvSet M.empty M.empty)
NNEq -> toBool . not =<< valueEq lval (nvSet M.empty M.empty)
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVConstant NNull, NVSet rs rp) -> case op of
NUpdate -> pure $ bin nvSetP rs rp
NEq -> toBool =<< valueEq (nvSet M.empty M.empty) rval
NNEq -> toBool . not =<< valueEq (nvSet M.empty M.empty) rval
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVList ls, NVList rs) -> case op of
NConcat -> pure $ bin nvListP $ ls ++ rs
NEq -> toBool =<< valueEq lval rval
NNEq -> toBool . not =<< valueEq lval rval
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVList ls, NVConstant NNull) -> case op of
NConcat -> pure $ bin nvListP ls
NEq -> toBool =<< valueEq lval (nvList [])
NNEq -> toBool . not =<< valueEq lval (nvList [])
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVConstant NNull, NVList rs) -> case op of
NConcat -> pure $ bin nvListP rs
NEq -> toBool =<< valueEq (nvList []) rval
NNEq -> toBool . not =<< valueEq (nvList []) rval
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVPath p, NVStr s _) -> case op of
NEq -> toBool $ p == Text.unpack s
NNEq -> toBool $ p /= Text.unpack s
NPlus -> bin nvPathP <$> makeAbsolutePath (p `mappend` Text.unpack s)
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVPath ls, NVPath rs) -> case op of
NPlus -> bin nvPathP <$> makeAbsolutePath (ls ++ rs)
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
_ -> case op of
NEq -> toBool False
NNEq -> toBool True
_ -> nverr $ unsupportedTypes lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
where
unsupportedTypes :: Show a => a -> a -> String
unsupportedTypes lval rval =
@ -391,7 +398,7 @@ execBinaryOp scope span op lval rarg = do
(NInt li, NFloat rf) -> toFloat $ fromInteger li `floatF` rf
(NFloat lf, NInt ri) -> toFloat $ lf `floatF` fromInteger ri
(NFloat lf, NFloat rf) -> toFloat $ lf `floatF` rf
_ -> nverr $ unsupportedTypes l r
_ -> nverr $ ErrorCall $ unsupportedTypes l r
where
toInt = pure . bin nvConstantP . NInt
toFloat = pure . bin nvConstantP . NFloat
@ -416,7 +423,7 @@ coerceToString = \case
NVSet s _ | Just p <- M.lookup "outPath" s ->
force p coerceToString
v -> throwError $ "Expected a string, but saw: " ++ show v
v -> throwError $ ErrorCall $ "Expected a string, but saw: " ++ show v
newtype Lazy m a = Lazy
{ runLazy :: ReaderT (Context (Lazy m) (NThunk (Lazy m)))
@ -448,8 +455,8 @@ instance MonadException m => MonadException (Lazy m) where
let run' = RunIO (fmap Lazy . run . runLazy)
in runLazy <$> f run'
instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m,
Alternative m, MonadPlus m, Typeable m)
instance (MonadFix m, MonadCatch m, MonadIO m, Alternative m,
MonadPlus m, Typeable m)
=> MonadEffects (Lazy m) where
addPath path = do
(exitCode, out, _) <-
@ -458,7 +465,8 @@ instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m,
ExitSuccess -> do
let dropTrailingLinefeed p = take (length p - 1) p
return $ StorePath $ dropTrailingLinefeed out
_ -> throwError $ "addPath: failed: nix-store --add " ++ show path
_ -> throwError $ ErrorCall $
"addPath: failed: nix-store --add " ++ show path
makeAbsolutePath origPath = do
origPathExpanded <- liftIO $ expandHomePath origPath
@ -469,7 +477,7 @@ instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m,
Nothing -> liftIO getCurrentDirectory
Just v -> force v $ \case
NVPath s -> return $ takeDirectory s
v -> throwError $ "when resolving relative path,"
v -> throwError $ ErrorCall $ "when resolving relative path,"
++ " __cur_file is in scope,"
++ " but is not a path; it is: "
++ show v
@ -493,7 +501,7 @@ instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m,
return $ takeDirectory p' </> path
traceM $ "Importing file " ++ path'
withFrame Info ("While importing file " ++ show path') $ do
withFrame Info (ErrorCall $ "While importing file " ++ show path') $ do
imports <- Lazy $ ReaderT $ const get
expr <- case M.lookup path' imports of
Just expr -> pure expr
@ -501,8 +509,8 @@ instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m,
eres <- Lazy $ parseNixFileLoc path'
case eres of
Failure err ->
throwError $ text "Parse during import failed:"
P.</> err
throwError $ ErrorCall . show $
text "Parse during import failed:" P.</> err
Success expr -> do
Lazy $ ReaderT $ const $
modify (M.insert origPath expr)
@ -557,11 +565,11 @@ instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m,
case exitCode of
ExitSuccess -> case parseNixTextLoc (Text.pack out) of
Failure err ->
throwError $ "Error parsing output of nix-instantiate: "
++ show err
throwError $ ErrorCall $
"Error parsing output of nix-instantiate: " ++ show err
Success v -> evalExprLoc v
status ->
throwError $ "nix-instantiate failed: " ++ show status
throwError $ ErrorCall $ "nix-instantiate failed: " ++ show status
++ ": " ++ err
getRecursiveSize =
@ -629,7 +637,7 @@ findEnvPathM name = do
foldM go Nothing l
case mpath of
Nothing ->
throwError $ "file '" ++ name
throwError $ ErrorCall $ "file '" ++ name
++ "' was not found in the Nix search path"
++ " (add it using $NIX_PATH or -I)"
Just path -> return path
@ -646,7 +654,7 @@ findEnvPathM name = do
tryPath path (Just (Text.unpack pfx))
_ -> tryPath path Nothing
Nothing ->
throwError $ "__nixPath must be a list of attr sets"
throwError $ ErrorCall $ "__nixPath must be a list of attr sets"
++ " with 'path' elements, but saw: " ++ show s
tryPath p (Just n) | n':ns <- splitDirectories name, n == n' =

30
src/Nix/Frames.hs
View file

@ -4,8 +4,8 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Nix.Frames (NixLevel(..), Frames, Framed, Frame(..), NixFrame(..),
NixException(..), SomeFrame(..), withFrame, throwError,
module Nix.Frames (NixLevel(..), Frames, Framed, NixFrame(..),
NixException(..), withFrame, throwError,
module Data.Typeable,
module Control.Exception) where
@ -14,29 +14,13 @@ import Control.Monad.Catch
import Control.Monad.Reader
import Data.Typeable hiding (typeOf)
import Nix.Utils
import Text.PrettyPrint.ANSI.Leijen (Doc)
data NixLevel = Fatal | Error | Warning | Info | Debug
deriving (Ord, Eq, Bounded, Enum, Show)
data SomeFrame = forall e. Frame e => SomeFrame e
instance Show SomeFrame where
show (SomeFrame f) = show f
class (Typeable e, Show e) => Frame e where
toFrame :: e -> SomeFrame
fromFrame :: SomeFrame -> Maybe e
toFrame = SomeFrame
fromFrame (SomeFrame e) = cast e
instance Frame [Char]
instance Frame Doc
data NixFrame = NixFrame
{ frameLevel :: NixLevel
, frame :: SomeFrame
, frame :: SomeException
}
instance Show NixFrame where
@ -52,11 +36,11 @@ newtype NixException = NixException Frames
instance Exception NixException
withFrame :: forall s e m a. (Framed e m, Frame s) => NixLevel -> s -> m a -> m a
withFrame level f = local (over hasLens (NixFrame level (toFrame f) :))
withFrame :: forall s e m a. (Framed e m, Exception s) => NixLevel -> s -> m a -> m a
withFrame level f = local (over hasLens (NixFrame level (toException f) :))
throwError :: forall s e m a. (Framed e m, Frame s, MonadThrow m) => s -> m a
throwError :: forall s e m a. (Framed e m, Exception s, MonadThrow m) => s -> m a
throwError err = do
context <- asks (view hasLens)
traceM "Throwing error..."
throwM $ NixException (NixFrame Error (toFrame err):context)
throwM $ NixException (NixFrame Error (toException err):context)

21
src/Nix/Lint.hs
View file

@ -122,7 +122,7 @@ unpackSymbolic = readVar . coerce
type MonadLint e m = (Scoped e (SThunk m) m, Framed e m, MonadVar m)
symerr :: forall e m a. MonadLint e m => String -> m a
symerr = evalError @(Symbolic m)
symerr = evalError @(Symbolic m) . ErrorCall
renderSymbolic :: MonadLint e m => Symbolic m -> m String
renderSymbolic = unpackSymbolic >=> \case
@ -182,9 +182,9 @@ merge context = go
then go xs ys
else (TSet (Just m) :) <$> go xs ys
(TClosure {}, TClosure {}) ->
throwError "Cannot unify functions"
throwError $ ErrorCall "Cannot unify functions"
(TBuiltin _ _, TBuiltin _ _) ->
throwError "Cannot unify builtin functions"
throwError $ ErrorCall "Cannot unify builtin functions"
_ | compareTypes x y == LT -> go xs (y:ys)
| compareTypes x y == GT -> go (x:xs) ys
| otherwise -> error "impossible"
@ -227,7 +227,7 @@ unify context (Symbolic x) (Symbolic y) = do
then do
-- x' <- renderSymbolic (Symbolic x)
-- y' <- renderSymbolic (Symbolic y)
throwError "Cannot unify "
throwError $ ErrorCall "Cannot unify "
-- ++ show x' ++ " with " ++ show y'
-- ++ " in context: " ++ show context
else do
@ -296,7 +296,7 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
pushWeakScope ?? body $ force s $ unpackSymbolic >=> \case
NMany [TSet (Just s')] -> return s'
NMany [TSet Nothing] -> error "NYI: with unknown"
_ -> throwError "scope must be a set in with statement"
_ -> throwError $ ErrorCall "scope must be a set in with statement"
evalIf cond t f = do
t' <- t
@ -362,7 +362,8 @@ lintApp :: forall e m. MonadLint e m
=> NExprF () -> Symbolic m -> m (Symbolic m)
-> m (HashMap VarName (Symbolic m), Symbolic m)
lintApp context fun arg = unpackSymbolic fun >>= \case
NAny -> throwError "Cannot apply something not known to be a function"
NAny -> throwError $ ErrorCall
"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
@ -372,10 +373,10 @@ lintApp context fun arg = unpackSymbolic fun >>= \case
NMany [TSet (Just _)] -> do
error "NYI"
NMany _ -> throwError "NYI: lintApp NMany not set"
TBuiltin _ _f -> throwError "NYI: lintApp builtin"
TSet _m -> throwError "NYI: lintApp Set"
_x -> throwError "Attempt to call non-function"
NMany _ -> throwError $ ErrorCall "NYI: lintApp NMany not set"
TBuiltin _ _f -> throwError $ ErrorCall "NYI: lintApp builtin"
TSet _m -> throwError $ ErrorCall "NYI: lintApp Set"
_x -> throwError $ ErrorCall "Attempt to call non-function"
y <- everyPossible
(args,) <$> foldM (unify context) y ys

2
src/Nix/Normal.hs
View file

@ -27,7 +27,7 @@ import Nix.Value
newtype NormalLoop m = NormalLoop (NValue m)
deriving Show
instance Typeable m => Frame (NormalLoop m)
instance Typeable m => Exception (NormalLoop m)
normalFormBy
:: forall e m. (Framed e m, MonadVar m, Typeable m)

15
src/Nix/Render/Frame.hs
View file

@ -61,7 +61,7 @@ renderFrames (x:xs) = do
framePos :: forall v (m :: * -> *). (Typeable m, Typeable v) => NixFrame
-> Maybe SourcePos
framePos (NixFrame _ f)
| Just (e :: EvalFrame m v) <- fromFrame f = case e of
| Just (e :: EvalFrame m v) <- fromException f = case e of
EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) ->
Just beg
_ -> Nothing
@ -72,14 +72,13 @@ renderFrame :: forall v e m.
MonadFile m, Typeable m, Typeable v)
=> NixFrame -> m [Doc]
renderFrame (NixFrame level f)
| Just (e :: EvalFrame m v) <- fromFrame f = renderEvalFrame level e
| Just (e :: ThunkLoop) <- fromFrame f = renderThunkLoop level e
| Just (e :: ValueFrame m) <- fromFrame f = renderValueFrame level e
| Just (_ :: NormalLoop m) <- fromFrame f =
| Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e
| Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e
| Just (e :: ValueFrame m) <- fromException f = renderValueFrame level e
| Just (_ :: NormalLoop m) <- fromException f =
pure [text "<<loop during normalization>>"]
| Just (e :: ExecFrame m) <- fromFrame f = renderExecFrame level e
| Just (e :: String) <- fromFrame f = pure [text e]
| Just (e :: Doc) <- fromFrame f = pure [e]
| Just (e :: ExecFrame m) <- fromException f = renderExecFrame level e
| Just (e :: ErrorCall) <- fromException f = pure [text (show e)]
| otherwise = error $ "Unrecognized frame: " ++ show f
wrapExpr :: NExprF r -> NExpr

14
src/Nix/Thunk.hs
View file

@ -15,7 +15,9 @@
module Nix.Thunk where
import Nix.Frames
import Control.Exception
import Control.Monad.Catch
import Data.Typeable
#if ENABLE_TRACING
import Data.IORef
@ -49,7 +51,7 @@ data Thunk m v
newtype ThunkLoop = ThunkLoop (Maybe Int)
deriving (Show, Typeable)
instance Frame ThunkLoop
instance Exception ThunkLoop
valueRef :: v -> Thunk m v
valueRef = Value
@ -64,7 +66,7 @@ buildThunk action =
#endif
<$> newVar False <*> newVar (Deferred action)
forceThunk :: (Framed e m, MonadVar m) => Thunk m v -> (v -> m a) -> m a
forceThunk :: (MonadVar m, MonadThrow m) => Thunk m v -> (v -> m a) -> m a
forceThunk (Value ref) k = k ref
#if ENABLE_TRACING
forceThunk (Thunk n active ref) k = do
@ -79,9 +81,9 @@ forceThunk (Thunk _ active ref) k = do
if nowActive
then
#if ENABLE_TRACING
throwError $ ThunkLoop (Just n)
throwM $ ThunkLoop (Just n)
#else
throwError $ ThunkLoop Nothing
throwM $ ThunkLoop Nothing
#endif
else do
#if ENABLE_TRACING
@ -92,7 +94,7 @@ forceThunk (Thunk _ active ref) k = do
_ <- atomicModifyVar active (False,)
k v
forceEffects :: (Framed e m, MonadVar m) => Thunk m v -> (v -> m a) -> m a
forceEffects :: MonadVar m => Thunk m v -> (v -> m a) -> m a
forceEffects (Value ref) k = k ref
forceEffects (Thunk _ active ref) k = do
nowActive <- atomicModifyVar active (True,)

5
src/Nix/Value.hs
View file

@ -182,8 +182,7 @@ instance Ord (NValue m) where
NVPath x <= NVPath y = x < y
_ <= _ = False
checkComparable :: (Framed e m, MonadThrow m, Typeable m)
=> NValue m -> NValue m -> m ()
checkComparable :: (Framed e m, Typeable m) => NValue m -> NValue m -> m ()
checkComparable x y = case (x, y) of
(NVConstant (NFloat _), NVConstant (NInt _)) -> pure ()
(NVConstant (NInt _), NVConstant (NFloat _)) -> pure ()
@ -327,4 +326,4 @@ data ValueFrame m
| Expectation ValueType (NValue m)
deriving (Show, Typeable)
instance Typeable m => Frame (ValueFrame m)
instance Typeable m => Exception (ValueFrame m)