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

Add informative backtraces on evaluation failure

This commit is contained in:
John Wiegley 2018-03-30 23:00:06 -07:00
parent 4e29e6453f
commit d08ca26da0
12 changed files with 197 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
Nix.hs
View File

@ -1,31 +1,35 @@
module Nix where
import Control.Monad.Trans.Reader
import qualified Data.Map.Lazy as Map
import Nix.Builtins
import Nix.Eval
import Nix.Expr (NExpr)
import Nix.Expr.Types.Annotated (NExprLoc, stripAnnotation)
import Nix.Lint
import Nix.Monad
import Nix.Monad.Instance
import Nix.Utils
-- | Evaluate a nix expression in the default context
evalTopLevelExpr :: MonadNixEnv m => Maybe FilePath -> NExpr -> m (NValueNF m)
evalTopLevelExpr :: MonadNixEnv m
=> Maybe FilePath -> NExprLoc -> m (NValueNF m)
evalTopLevelExpr mdir expr = do
base <- baseEnv
(normalForm =<<) $ pushScopes base $ case mdir of
Nothing -> evalExpr expr
Nothing -> contextualExprEval expr
Just dir -> do
traceM $ "Setting __cwd = " ++ show dir
ref <- valueRef $ NVLiteralPath dir
pushScope (Map.singleton "__cwd" ref) (evalExpr expr)
pushScope (Map.singleton "__cwd" ref) (contextualExprEval expr)
evalTopLevelExprIO :: Maybe FilePath -> NExpr -> IO (NValueNF (Cyclic IO))
evalTopLevelExprIO mdir expr =
runReaderT (runCyclic (evalTopLevelExpr mdir expr)) []
evalTopLevelExprIO :: Maybe FilePath -> NExprLoc -> IO (NValueNF (Cyclic IO))
evalTopLevelExprIO mdir = runCyclicIO . evalTopLevelExpr mdir
tracingEvalTopLevelExprIO :: Maybe FilePath -> NExpr
-- informativeEvalTopLevelExprIO :: Maybe FilePath -> NExpr
-- -> IO (NValueNF (Cyclic IO))
-- informativeEvalTopLevelExprIO mdir expr =
-- runReaderT (runCyclic (evalTopLevelExpr mdir expr)) []
tracingEvalTopLevelExprIO :: Maybe FilePath -> NExprLoc
-> IO (NValueNF (Cyclic IO))
tracingEvalTopLevelExprIO mdir expr = do
traced <- tracingExprEval expr
@ -39,5 +43,6 @@ tracingEvalTopLevelExprIO mdir expr = do
runCyclicIO (baseEnv >>= (`pushScopes` pushScope m traced)
>>= normalForm)
lintExpr :: NExpr -> IO ()
lintExpr expr = runCyclicIO (baseEnv >>= (`pushScopes` checkExpr expr))
lintExpr :: NExprLoc -> IO ()
lintExpr expr =
runCyclicIO (baseEnv >>= (`pushScopes` checkExpr (stripAnnotation expr)))

44
Nix/Builtins.hs
View File

@ -85,14 +85,14 @@ mkBool = return . NVConstant . NBool
extractBool :: MonadNix m => NValue m -> m Bool
extractBool = \case
NVConstant (NBool b) -> return b
_ -> error "Not a boolean constant"
_ -> throwError "Not a boolean constant"
apply :: MonadNix m => NThunk m -> NThunk m -> m (NValue m)
apply f arg = forceThunk f >>= \case
NVFunction params pred ->
(`pushScope` (forceThunk =<< pred))
=<< buildArgument params arg
x -> error $ "Trying to call a " ++ show (() <$ x)
x -> throwError $ "Trying to call a " ++ show (() <$ x)
-- Primops
@ -105,16 +105,16 @@ hasAttr :: MonadNix m => NThunk m -> NThunk m -> m (NValue m)
hasAttr x y = (,) <$> forceThunk x <*> forceThunk y >>= \case
(NVStr key _, NVSet aset) ->
return . NVConstant . NBool $ Map.member key aset
(x, y) -> error $ "Invalid types for builtin.hasAttr: "
(x, y) -> throwError $ "Invalid types for builtin.hasAttr: "
++ show (() <$ x, () <$ y)
getAttr :: MonadNix m => NThunk m -> NThunk m -> m (NValue m)
getAttr x y = (,) <$> forceThunk x <*> forceThunk y >>= \case
(NVStr key _, NVSet aset) ->
forceThunk (Map.findWithDefault _err key aset)
where _err = error $ "hasAttr: field does not exist: "
++ Text.unpack key
(x, y) -> error $ "Invalid types for builtin.hasAttr: "
(NVStr key _, NVSet aset) -> case Map.lookup key aset of
Nothing -> throwError $ "hasAttr: field does not exist: "
++ Text.unpack key
Just action -> forceThunk action
(x, y) -> throwError $ "Invalid types for builtin.hasAttr: "
++ show (() <$ x, () <$ y)
anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
@ -128,7 +128,7 @@ any_ :: MonadNix m => NThunk m -> NThunk m -> m (NValue m)
any_ pred = forceThunk >=> \case
NVList l ->
mkBool =<< anyM extractBool =<< mapM (apply pred) l
arg -> error $ "builtins.any takes a list as second argument, not a "
arg -> throwError $ "builtins.any takes a list as second argument, not a "
++ show (() <$ arg)
allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
@ -142,14 +142,14 @@ all_ :: MonadNix m => NThunk m -> NThunk m -> m (NValue m)
all_ pred = forceThunk >=> \case
NVList l ->
mkBool =<< allM extractBool =<< mapM (apply pred) l
arg -> error $ "builtins.all takes a list as second argument, not a "
arg -> throwError $ "builtins.all takes a list as second argument, not a "
++ show (() <$ arg)
--TODO: Strictness
foldl'_ :: MonadNix m => NThunk m -> NThunk m -> NThunk m -> m (NValue m)
foldl'_ f z = forceThunk >=> \case
NVList vals -> forceThunk =<< foldlM go z vals
arg -> error $ "builtins.foldl' takes a list as third argument, not a "
arg -> throwError $ "builtins.foldl' takes a list as third argument, not a "
++ show (() <$ arg)
where
go b a = do
@ -159,16 +159,16 @@ foldl'_ f z = forceThunk >=> \case
head_ :: MonadNix m => NThunk m -> m (NValue m)
head_ = forceThunk >=> \case
NVList vals -> case vals of
[] -> error "builtins.head: empty list"
[] -> throwError "builtins.head: empty list"
h:_ -> forceThunk h
_ -> error "builtins.head: not a list"
_ -> throwError "builtins.head: not a list"
tail_ :: MonadNix m => NThunk m -> m (NValue m)
tail_ = forceThunk >=> \case
NVList vals -> case vals of
[] -> error "builtins.tail: empty list"
[] -> throwError "builtins.tail: empty list"
_:t -> return $ NVList t
_ -> error "builtins.tail: not a list"
_ -> throwError "builtins.tail: not a list"
data VersionComponent
= VersionComponent_Pre -- ^ The string "pre"
@ -207,7 +207,7 @@ splitVersion_ = forceThunk >=> \case
vals <- forM (splitVersion s) $ \c ->
valueRef $ NVStr (versionComponentToString c) mempty
return $ NVList vals
_ -> error "builtins.splitVersion: not a string"
_ -> throwError "builtins.splitVersion: not a string"
compareVersions :: Text -> Text -> Ordering
compareVersions s1 s2 =
@ -226,7 +226,7 @@ compareVersions_ t1 t2 = do
LT -> -1
EQ -> 0
GT -> 1
_ -> error "builtins.splitVersion: not a string"
_ -> throwError "builtins.splitVersion: not a string"
splitDrvName :: Text -> (Text, Text)
splitDrvName s =
@ -290,16 +290,18 @@ instance (MonadNix m, ToNix a) => ToBuiltin m (Prim m a) where
toBuiltin _ p = toValue =<< runPrim p
instance (MonadNix m, FromNix a, ToBuiltin m b) => ToBuiltin m (a -> b) where
toBuiltin name f = return $ NVBuiltin name $ \a -> toBuiltin name . f =<< fromThunk a
toBuiltin name f =
return $ NVBuiltin name $ \a -> toBuiltin name . f =<< fromThunk a
class FromNix a where
--TODO: Get rid of the HasCallStack - it should be captured by whatever error reporting mechanism we add
--TODO: Get rid of the HasCallStack - it should be captured by whatever
--error reporting mechanism we add
fromThunk :: (HasCallStack, MonadNix m) => NThunk m -> m a
instance FromNix Text where
fromThunk = forceThunk >=> \case
NVStr s _ -> pure s
v -> error $ "fromThunk: Expected string, got " ++ show (void v)
v -> throwError $ "fromThunk: Expected string, got " ++ show (void v)
instance FromNix Int where
fromThunk = fmap fromInteger . fromThunk
@ -307,4 +309,4 @@ instance FromNix Int where
instance FromNix Integer where
fromThunk = forceThunk >=> \case
NVConstant (NInt n) -> pure n
v -> error $ "fromThunk: Expected number, got " ++ show (void v)
v -> throwError $ "fromThunk: Expected number, got " ++ show (void v)

92
Nix/Eval.hs
View File

@ -2,19 +2,24 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Nix.Eval
(evalExpr, tracingExprEval, evalBinds, exprNormalForm, normalForm,
builtin, builtin2, builtin3, atomText, valueText, buildArgument) where
builtin, builtin2, builtin3, atomText, valueText, buildArgument,
contextualExprEval
) where
import Control.Monad hiding (mapM, sequence)
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Data.Align.Key
import Data.Fix
import Data.Functor.Compose
import Data.Functor.Identity
import Data.List (intercalate)
import qualified Data.Map.Lazy as Map
@ -37,7 +42,10 @@ eval :: MonadNix m => NExprF (m (NValue m)) -> m (NValue m)
eval (NSym var) = do
traceM $ "NSym..1: var = " ++ show var
fromMaybe (error $ "Undefined variable: " ++ show var) <$> lookupVar var
mres <- lookupVar var
case mres of
Nothing -> throwError $ "Undefined variable: " ++ show var
Just v -> return v
eval (NConstant x) = return $ NVConstant x
eval (NStr str) = evalString str
@ -45,12 +53,12 @@ eval (NLiteralPath p) = return $ NVLiteralPath p
eval (NEnvPath p) = return $ NVEnvPath p
eval (NUnary op arg) = arg >>= \case
NVConstant c -> return $ NVConstant $ case (op, c) of
(NNeg, NInt i) -> NInt (-i)
(NNot, NBool b) -> NBool (not b)
_ -> error $ "unsupported argument type for unary operator "
NVConstant c -> case (op, c) of
(NNeg, NInt i) -> return $ NVConstant $ NInt (-i)
(NNot, NBool b) -> return $ NVConstant $ NBool (not b)
_ -> throwError $ "unsupported argument type for unary operator "
++ show op
_ -> error "argument to unary operator must evaluate to an atomic type"
_ -> throwError "argument to unary operator must evaluate to an atomic type"
eval (NBinary op larg rarg) = do
lval <- larg
@ -76,34 +84,34 @@ eval (NBinary op larg rarg) = do
(NMinus, NInt l, NInt r) -> valueRefInt $ l - r
(NMult, NInt l, NInt r) -> valueRefInt $ l * r
(NDiv, NInt l, NInt r) -> valueRefInt $ l `div` r
_ -> error unsupportedTypes
_ -> throwError unsupportedTypes
(NVStr ls lc, NVStr rs rc) -> case op of
NPlus -> return $ NVStr (ls `mappend` rs) (lc `mappend` rc)
NEq -> valueRefBool =<< valueEq lval rval
NNEq -> valueRefBool . not =<< valueEq lval rval
_ -> error unsupportedTypes
_ -> throwError unsupportedTypes
(NVSet ls, NVSet rs) -> case op of
NUpdate -> return $ NVSet $ rs `Map.union` ls
_ -> error unsupportedTypes
_ -> throwError unsupportedTypes
(NVList ls, NVList rs) -> case op of
NConcat -> return $ NVList $ ls ++ rs
NEq -> valueRefBool =<< valueEq lval rval
_ -> error unsupportedTypes
_ -> throwError unsupportedTypes
(NVLiteralPath ls, NVLiteralPath rs) -> case op of
-- TODO: Canonicalise path
NPlus -> return $ NVLiteralPath $ ls ++ rs
_ -> error unsupportedTypes
_ -> throwError unsupportedTypes
(NVLiteralPath ls, NVStr rs rc) -> case op of
-- TODO: Canonicalise path
NPlus -> return $ NVStr (Text.pack ls `mappend` rs) rc
_ -> error unsupportedTypes
_ -> throwError unsupportedTypes
_ -> error unsupportedTypes
_ -> throwError unsupportedTypes
eval (NSelect aset attr alternative) = do
aset' <- aset
@ -115,7 +123,7 @@ eval (NSelect aset attr alternative) = do
pure v
Nothing -> fromMaybe err alternative
where
err = error $ "could not look up attribute "
err = throwError $ "could not look up attribute "
++ intercalate "." (map Text.unpack ks)
++ " in " ++ show (() <$ aset')
where
@ -131,8 +139,8 @@ eval (NHasAttr aset attr) = aset >>= \case
NVSet s -> evalSelector True attr >>= \case
[keyName] ->
return $ NVConstant $ NBool $ keyName `Map.member` s
_ -> error "attr name argument to hasAttr is not a single-part name"
_ -> error "argument to hasAttr has wrong type"
_ -> throwError "attr name argument to hasAttr is not a single-part name"
_ -> throwError "argument to hasAttr has wrong type"
eval (NList l) = do
scope <- currentScope
@ -159,16 +167,16 @@ eval (NLet binds e) = do
eval (NIf cond t f) = cond >>= \case
NVConstant (NBool True) -> t
NVConstant (NBool False) -> f
_ -> error "condition must be a boolean"
_ -> throwError "condition must be a boolean"
eval (NWith scope e) = scope >>= \case
NVSet s -> pushWeakScope s e
_ -> error "scope must be a set in with statement"
_ -> throwError "scope must be a set in with statement"
eval (NAssert cond e) = cond >>= \case
NVConstant (NBool True) -> e
NVConstant (NBool False) -> error "assertion failed"
_ -> error "assertion condition must be boolean"
NVConstant (NBool False) -> throwError "assertion failed"
_ -> throwError "assertion condition must be boolean"
eval (NApp fun arg) = fun >>= \case
NVFunction params f -> do
@ -177,7 +185,7 @@ eval (NApp fun arg) = fun >>= \case
++ show (newScope args)
clearScopes (pushScope args (forceThunk =<< f))
NVBuiltin _ f -> f =<< buildThunk arg
_ -> error "Attempt to call non-function"
_ -> throwError "Attempt to call non-function"
eval (NAbs params body) = do
-- It is the environment at the definition site, not the call site, that
@ -225,7 +233,7 @@ buildArgument params arg = case params of
res <- loebM (alignWithKey (assemble isVariadic) args s)
maybe (pure res) (selfInject res) m
x -> error $ "Expected set in function call, received: "
x -> throwError $ "Expected set in function call, received: "
++ show (() <$ x)
selfInject :: ValueSet m -> Text -> m (ValueSet m)
@ -239,7 +247,8 @@ buildArgument params arg = case params of
-> ValueSet m
-> m (NThunk m)
assemble isVariadic k = \case
That Nothing -> error $ "Missing value for parameter: " ++ show k
That Nothing ->
const $ throwError $ "Missing value for parameter: " ++ show k
That (Just f) -> \args -> do
scope <- currentScope
traceM $ "Deferring default argument in scope: " ++ show scope
@ -248,7 +257,8 @@ buildArgument params arg = case params of
++ show (newScope args)
pushScopes scope $ pushScope args $ forceThunk =<< f
This x | isVariadic -> const (pure x)
| otherwise -> error $ "Unexpected parameter: " ++ show k
| otherwise ->
const $ throwError $ "Unexpected parameter: " ++ show k
These x _ -> const (pure x)
attrSetAlter :: MonadNix m
@ -256,14 +266,14 @@ attrSetAlter :: MonadNix m
-> Map.Map Text (m (NValue m))
-> m (NValue m)
-> m (Map.Map Text (m (NValue m)))
attrSetAlter [] _ _ = error "invalid selector with no components"
attrSetAlter [] _ _ = throwError "invalid selector with no components"
attrSetAlter (p:ps) m val = case Map.lookup p m of
Nothing | null ps -> go
| otherwise -> recurse Map.empty
Just v | null ps -> go
| otherwise -> v >>= \case
NVSet s -> recurse (fmap forceThunk s)
_ -> error $ "attribute " ++ attr ++ " is not a set"
_ -> throwError $ "attribute " ++ attr ++ " is not a set"
where
attr = show (Text.intercalate "." (p:ps))
@ -294,11 +304,11 @@ evalBinds allowDynamic recursive = buildResult . concat <=< mapM go
Nothing -> lookupVar key
Just s -> s >>= \case
NVSet s -> pushScope s (lookupVar key)
x -> error
x -> throwError
$ "First argument to inherit should be a set, saw: "
++ show (() <$ x)
case mv of
Nothing -> error $ "Inheriting unknown attribute: "
Nothing -> throwError $ "Inheriting unknown attribute: "
++ show (() <$ name)
Just v -> return v)
@ -335,18 +345,26 @@ evalKeyName dyn (DynamicKey k)
| dyn = do
v <- runAntiquoted evalString id k
valueTextNoContext =<< normalForm v
| otherwise = error "dynamic attribute not allowed in this context"
| otherwise =
throwError "dynamic attribute not allowed in this context"
tracingExprEval :: MonadNix m => NExpr -> IO (m (NValue m))
tracingExprEval =
flip runReaderT (0 :: Int)
. fmap (runIdentity . snd)
. adiM @() (pure <$> eval) psi
contextualExprEval :: forall m. MonadNix m => NExprLoc -> m (NValue m)
contextualExprEval =
runIdentity . snd . adi @() (eval . annotated . getCompose) psi
where
psi k v@(Fix x) = fmap (fmap (withExprContext (() <$ x))) (k v)
tracingExprEval :: MonadNix m => NExprLoc -> IO (m (NValue m))
tracingExprEval = flip runReaderT (0 :: Int)
. fmap (runIdentity . snd)
. adiM @() (pure <$> eval . annotated . getCompose) psi
where
psi k v@(Fix x) = do
depth <- ask
liftIO $ putStrLn $ "eval: " ++ replicate (depth * 2) ' ' ++ show x
res <- local succ $ k v
liftIO $ putStrLn $ "eval: " ++ replicate (depth * 2) ' '
++ show (stripAnnotation v)
res <- local succ $
fmap (fmap (fmap (withExprContext (() <$ x)))) (k v)
liftIO $ putStrLn $ "eval: " ++ replicate (depth * 2) ' ' ++ "."
return res

2
Nix/Lint.hs
View File

@ -20,7 +20,7 @@ checkExpr = cata check
check :: MonadNix m => NExprF (m ()) -> m ()
check (NSym var) = lookupVar var >>= \case
Nothing -> error $ "Undefined variable: " ++ show var
Nothing -> error $ "lint: Undefined variable: " ++ show var
Just _ -> return ()
check (NSet binds) =

13
Nix/Monad.hs
View File

@ -13,6 +13,7 @@ import Data.Typeable (Typeable)
import GHC.Generics
import Nix.Atoms
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Utils
-- | An 'NValue' is the most reduced form of an 'NExpr' after evaluation
@ -84,13 +85,13 @@ valueText = cata phi where
phi :: NValueF m (m (Text, DList Text)) -> m (Text, DList Text)
phi (NVConstant a) = pure (atomText a, mempty)
phi (NVStr t c) = pure (t, c)
phi (NVList _) = error "Cannot coerce a list to a string"
phi (NVList _) = throwError "Cannot coerce a list to a string"
phi (NVSet set)
| Just asString <-
-- TODO: Should this be run through valueText recursively?
Map.lookup "__asString" set = asString
| otherwise = error "Cannot coerce a set to a string"
phi (NVFunction _ _) = error "Cannot coerce a function to a string"
| otherwise = throwError "Cannot coerce a set to a string"
phi (NVFunction _ _) = throwError "Cannot coerce a function to a string"
phi (NVLiteralPath originalPath) = do
-- TODO: Capture and use the path of the file being processed as the
-- base path
@ -99,7 +100,7 @@ valueText = cata phi where
phi (NVEnvPath p) =
-- TODO: Ensure this is a store path
pure (Text.pack p, mempty)
phi (NVBuiltin _ _) = error "Cannot coerce a function to a string"
phi (NVBuiltin _ _) = throwError "Cannot coerce a function to a string"
valueTextNoContext :: MonadNix m => NValueNF m -> m Text
valueTextNoContext = fmap fst . valueText
@ -123,6 +124,10 @@ newtype StorePath = StorePath { unStorePath :: FilePath }
class (Show (NScopes m), MonadFix m) => MonadNix m where
data NScopes m :: *
withExprContext :: NExprLocF () -> m r -> m r
withStringContext :: String -> m r -> m r
throwError :: String -> m a
currentScope :: m (NScopes m)
clearScopes :: m r -> m r
pushScope :: ValueSet m -> m r -> m r

77
Nix/Monad/Instance.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
@ -9,22 +11,57 @@ import Control.Monad
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import qualified Data.ByteString as BS
import Data.Fix
import Data.Functor.Compose
import Data.IORef
import qualified Data.Map.Lazy as Map
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Nix.Eval
import Nix.Expr
import Nix.Monad
import Nix.Parser
import Nix.Pretty
import Nix.Scope
import Nix.Utils
import System.Environment
import System.Exit (ExitCode (ExitSuccess))
import System.FilePath
import System.Process (readProcessWithExitCode)
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (</>))
import Text.Trifecta.Rendering
import Text.Trifecta.Result
data Context m = Context
{ scopes :: NScopes m
, frames :: [Either String (NExprLocF ())]
}
mapScopes :: (NScopes m -> NScopes m) -> Context m -> Context m
mapScopes f (Context scopes frames) = Context (f scopes) frames
mapFrames :: ([Either String (NExprLocF ())] -> [Either String (NExprLocF ())])
-> Context m -> Context m
mapFrames f (Context scopes frames) = Context scopes (f frames)
renderLocation :: MonadIO m => SrcSpan -> Doc -> m Doc
renderLocation (SrcSpan beg@(Directed path _ _ _ _) end) msg = do
contents <- liftIO $ BS.readFile (Text.unpack (Text.decodeUtf8 path))
return $ explain (addSpan beg end (rendered beg contents))
(Err (Just msg) [] mempty [])
renderLocation (SrcSpan beg end) msg =
return $ explain (addSpan beg end emptyRendering)
(Err (Just msg) [] mempty [])
renderFrame :: MonadIO m => Either String (NExprLocF ()) -> m String
renderFrame (Left str) = return str
renderFrame (Right (Compose (Ann ann expr))) =
show <$> renderLocation ann
(prettyNix (Fix (const (Fix (NSym "<?>")) <$> expr)))
newtype Cyclic m a = Cyclic
{ runCyclic :: ReaderT [Scope (NThunk (Cyclic m))] m a }
{ runCyclic :: ReaderT (Context (Cyclic m)) m a }
deriving (Functor, Applicative, Monad, MonadFix, MonadIO)
data Deferred m
@ -33,23 +70,41 @@ data Deferred m
| ComputedValue (NValue m)
instance Show (NScopes (Cyclic IO)) where
show (NestedScopes xs) = show xs
show (Scopes xs) = show xs
instance MonadNix (Cyclic IO) where
newtype NScopes (Cyclic IO) = NestedScopes [Scope (NThunk (Cyclic IO))]
newtype NScopes (Cyclic IO) =
Scopes { getS :: [Scope (NThunk (Cyclic IO))] }
pushScopes (NestedScopes s) = Cyclic . local (s ++) . runCyclic
pushScopes (Scopes s) =
Cyclic . local (mapScopes (Scopes . (s ++) . getS))
. runCyclic
pushScope s = Cyclic . local (Scope s False:) . runCyclic
pushWeakScope s = Cyclic . local (Scope s True:) . runCyclic
pushScope s =
Cyclic . local (mapScopes (Scopes . (Scope s False:) . getS))
. runCyclic
pushWeakScope s =
Cyclic . local (mapScopes (Scopes . (Scope s True:) . getS))
. runCyclic
clearScopes = Cyclic . local (const []) . runCyclic
currentScope = Cyclic $ NestedScopes <$> ask
clearScopes =
Cyclic . local (mapScopes (Scopes . const [] . getS)) . runCyclic
currentScope = Cyclic $ scopes <$> ask
withExprContext expr =
Cyclic . local (mapFrames (Right expr :)) . runCyclic
withStringContext str =
Cyclic . local (mapFrames (Left str :)) . runCyclic
throwError str = Cyclic $ do
context <- reverse . frames <$> ask
infos <- liftIO $ mapM renderFrame context
error $ unlines (infos ++ ["hnix: "++ str])
-- If a variable is being asked for, it's needed in head normal form.
lookupVar k = Cyclic $ do
scope <- ask
case scopeLookup k scope of
env <- ask
case scopeLookup k (getS (scopes env)) of
Nothing -> return Nothing
Just v -> runCyclic $ Just <$> forceThunk v
@ -117,4 +172,4 @@ instance MonadNixEnv (Cyclic IO) where
p -> error $ "Unexpected argument to getEnv: " ++ show (() <$ p)
runCyclicIO :: Cyclic IO a -> IO a
runCyclicIO = flip runReaderT [] . runCyclic
runCyclicIO = flip runReaderT (Context (Scopes []) []) . runCyclic

3
default.nix
View File

@ -9,7 +9,7 @@ let
, parsers, regex-tdfa, regex-tdfa-text, semigroups, split, stdenv
, tasty, tasty-hunit, tasty-th, text, transformers, trifecta
, unordered-containers, these, optparse-applicative, interpolate
, process
, process, exceptions, bytestring
}:
mkDerivation {
pname = "hnix";
@ -21,6 +21,7 @@ let
ansi-wl-pprint base containers data-fix deepseq deriving-compat
parsers regex-tdfa regex-tdfa-text semigroups text transformers
trifecta unordered-containers these process directory filepath
exceptions bytestring
];
executableHaskellDepends = [
ansi-wl-pprint base containers data-fix deepseq optparse-applicative

6
hnix.cabal
View File

@ -35,10 +35,10 @@ Library
Nix.Pretty
Nix.Parser.Operators
Nix.StringOperations
Other-modules:
Nix.Parser.Library
Nix.Expr.Types
Nix.Expr.Types.Annotated
Other-modules:
Nix.Parser.Library
Nix.Expr.Shorthands
Nix.Utils
Default-extensions:
@ -62,11 +62,13 @@ Library
, containers
, deriving-compat >= 0.3 && < 0.5
, text
, bytestring
, transformers
, parsers >= 0.10
, unordered-containers
, data-fix
, deepseq
, exceptions
, process
, directory
, filepath

17
main/Main.hs
View File

@ -3,8 +3,8 @@
module Main where
import Control.Monad
import Nix
import Nix.Expr.Types.Annotated (stripAnnotation)
import Nix.Parser
import Nix.Pretty
import Options.Applicative hiding (ParserResult(..))
@ -50,16 +50,16 @@ main :: IO ()
main = do
opts <- execParser optsDef
(eres, mdir) <- case expression opts of
Just s -> return (parseNixString s, Nothing)
Just s -> return (parseNixStringLoc s, Nothing)
Nothing -> case filePath opts of
Nothing -> (, Nothing) . parseNixString <$> getContents
Just "-" -> (, Nothing) . parseNixString <$> getContents
Just path -> (, Just (takeDirectory path)) <$> parseNixFile path
Nothing -> (, Nothing) . parseNixStringLoc <$> getContents
Just "-" -> (, Nothing) . parseNixStringLoc <$> getContents
Just path -> (, Just (takeDirectory path)) <$> parseNixFileLoc path
case eres of
Failure err -> hPutStrLn stderr $ "Parse failed: " ++ show err
Success expr -> do
when (check opts) $ lintExpr expr
-- when (check opts) $ lintExpr expr
if | evaluate opts, debug opts ->
print =<< tracingEvalTopLevelExprIO mdir expr
| evaluate opts ->
@ -67,7 +67,10 @@ main = do
| debug opts ->
print expr
| otherwise ->
displayIO stdout $ renderPretty 0.4 80 (prettyNix expr)
displayIO stdout
. renderPretty 0.4 80
. prettyNix
. stripAnnotation $ expr
where
optsDef :: ParserInfo Options
optsDef = info (helper <*> mainOptions)

9
tests/EvalTests.hs
View File

@ -65,6 +65,9 @@ case_function_recursive_sets =
}; s = 100; in [ x.v.t x.z.w ]
|]
case_nested_with =
constantEqualStr "2" "with { x = 1; }; with { x = 2; }; x"
-----------------------
tests :: TestTree
@ -76,7 +79,7 @@ instance (Show r, Eq r) => Eq (NValueF m r) where
x == y = error $ "Need to add comparison for values: "
++ show x ++ " == " ++ show y
constantEqual :: NExpr -> NExpr -> Assertion
constantEqual :: NExprLoc -> NExprLoc -> Assertion
constantEqual a b = do
a' <- tracingEvalTopLevelExprIO Nothing a
b' <- tracingEvalTopLevelExprIO Nothing b
@ -84,6 +87,6 @@ constantEqual a b = do
constantEqualStr :: String -> String -> Assertion
constantEqualStr a b =
let Success a' = parseNixString a
Success b' = parseNixString b
let Success a' = parseNixStringLoc a
Success b' = parseNixStringLoc b
in constantEqual a' b'

7
tests/NixLanguageTests.hs
View File

@ -67,15 +67,16 @@ genTests = do
["parse", "fail"] -> assertParseFail $ the files
["eval", "okay"] -> assertEval files
["eval", "fail"] -> assertEvalFail $ the files
_ -> error $ "Unexpected: " ++ show kind
assertParse :: FilePath -> Assertion
assertParse file = parseNixFile file >>= \case
assertParse file = parseNixFileLoc file >>= \case
Success expr -> lintExpr expr
Failure err -> assertFailure $ "Failed to parse " ++ file ++ ":\n" ++ show err
assertParseFail :: FilePath -> Assertion
assertParseFail file = do
eres <- parseNixFile file
eres <- parseNixFileLoc file
catch (case eres of
Success expr -> do
lintExpr expr
@ -115,7 +116,7 @@ assertEvalFail file = catch eval (\(ErrorCall _) -> return ())
nixEvalFile :: FilePath -> IO (NValueNF (Cyclic IO))
nixEvalFile file = do
parseResult <- parseNixFile file
parseResult <- parseNixFileLoc file
case parseResult of
Failure err ->
error $ "Parsing failed for file `" ++ file ++ "`.\n" ++ show err

2
tests/files/with.nix
View File

@ -1 +1 @@
with { x = 1; }; with { x = 2; }; x
with { x = 1; }; with { x = 2; }; y