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

Implement builtins.tryEval

Browse source
This commit is contained in:
John Wiegley 2018-04-07 14:33:15 -07:00
parent 935c7c5ee1
commit ea6a98f602
8 changed files with 84 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
hnix.cabal
View file

@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: 75114131aa7bcf0c3bfa2a43f01bf0942b2c922ce7caa94d7103bc24aee13b61
-- hash: 429fc2370bb078161c283b1238eb797ca1c03c46e4c1a2f68ac80937a901bb79
name: hnix
version: 0.5.0
@ -73,6 +73,7 @@ library
, deepseq
, deriving-compat >=0.3 && <0.5
, directory
, exceptions
, filepath
, insert-ordered-containers >=0.2.2 && <0.3
, monadlist
@ -115,6 +116,7 @@ executable hnix
, containers
, data-fix
, deepseq
, exceptions
, hnix
, insert-ordered-containers >=0.2.2 && <0.3
, mtl
@ -143,6 +145,7 @@ test-suite hnix-tests
, base >=4.9 && <5
, containers
, data-fix
, exceptions
, filepath
, hnix
, insert-ordered-containers >=0.2.2 && <0.3
@ -175,6 +178,7 @@ benchmark hnix-benchmarks
, containers
, criterion
, data-fix
, exceptions
, hnix
, insert-ordered-containers >=0.2.2 && <0.3
, mtl

2
package.yaml
View file

@ -24,7 +24,7 @@ dependencies:
- ansi-wl-pprint
- containers
- data-fix
# - exceptions
- exceptions
- insert-ordered-containers >= 0.2.2 && < 0.3
- mtl
- template-haskell

12
src/Nix.hs
View file

@ -12,7 +12,9 @@
module Nix (eval, evalLoc, tracingEvalLoc, lint, runLintM) where
import Control.Applicative
import Control.Exception
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Reader (MonadReader)
@ -50,7 +52,7 @@ evalTopLevelExpr mpath expr = do
pushScope (M.singleton "__cur_file" ref)
(Eval.evalExpr expr)
eval :: (MonadFix m, MonadIO m)
eval :: (MonadFix m, MonadThrow m, MonadCatch m, MonadIO m)
=> Maybe FilePath -> NExpr -> m (NValueNF (Lazy m))
eval mpath = runLazyM . evalTopLevelExpr mpath
@ -67,11 +69,12 @@ evalTopLevelExprLoc mpath expr = do
pushScope (M.singleton "__cur_file" ref)
(framedEvalExpr Eval.eval expr)
evalLoc :: (MonadFix m, MonadIO m)
evalLoc :: (MonadFix m, MonadThrow m, MonadCatch m, MonadIO m)
=> Maybe FilePath -> NExprLoc -> m (NValueNF (Lazy m))
evalLoc mpath = runLazyM . evalTopLevelExprLoc mpath
tracingEvalLoc :: forall m. (MonadFix m, MonadIO m, Alternative m)
tracingEvalLoc
:: forall m. (MonadFix m, MonadThrow m, MonadCatch m, MonadIO m, Alternative m)
=> Maybe FilePath -> NExprLoc -> m (NValueNF (Lazy m))
tracingEvalLoc mpath expr = do
traced <- tracingEvalExpr Eval.eval expr
@ -104,6 +107,9 @@ instance MonadVar (Lint s) where
instance MonadFile (Lint s) where
readFile x = Lint $ ReaderT $ \_ -> unsafeIOToST $ BS.readFile x
instance MonadThrow (Lint s) where
throwM e = Lint $ ReaderT $ \_ -> unsafeIOToST $ throw e
instance Eval.MonadExpr (SThunk (Lint s))
(STRef s (NSymbolicF (NTypeF (Lint s) (SThunk (Lint s)))))
(Lint s) where

41
src/Nix/Builtins.hs
View file

@ -17,6 +17,7 @@
module Nix.Builtins (MonadBuiltins, baseEnv) where
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Fix
import Control.Monad.ListM (sortByM)
import Control.Monad.Reader
@ -69,7 +70,8 @@ import System.Posix.Files
import Text.Regex.TDFA
type MonadBuiltins e m =
(MonadEval e m, MonadNix m, MonadFix m, MonadFile m, MonadVar m)
(MonadEval e m, MonadNix m, MonadFix m, MonadCatch m,
MonadFile m, MonadVar m)
baseEnv :: MonadBuiltins e m => m (Scopes m (NThunk m))
baseEnv = do
@ -166,6 +168,7 @@ builtinsList = sequence [
, add Normal "typeOf" typeOf
, add2 Normal "partition" partition_
, add0 Normal "currentSystem" currentSystem
, add Normal "tryEval" tryEval
]
where
wrap t n f = Builtin t (n, f)
@ -407,33 +410,33 @@ match_ pat str = force pat $ \pat' -> force str $ \str' ->
throwError $ "builtins.match: expected a regex"
++ " and a string, but got: " ++ show (p, s)
substring :: Applicative m => Int -> Int -> Text -> Prim m Text
substring start len =
substring :: MonadBuiltins e m => Int -> Int -> Text -> Prim m Text
substring start len str = Prim $
if start < 0 --NOTE: negative values of 'len' are OK
then error $ "builtins.substring: negative start position: " ++ show start
else Prim . pure . Text.take len . Text.drop start
then throwError $ "builtins.substring: negative start position: " ++ show start
else pure $ Text.take len $ Text.drop start str
attrNames :: MonadBuiltins e m => NThunk m -> m (NValue m)
attrNames = flip force $ \case
NVSet m _ -> toValue $ sort $ M.keys m
v -> error $ "builtins.attrNames: Expected attribute set, got "
v -> throwError $ "builtins.attrNames: Expected attribute set, got "
++ showValue v
attrValues :: MonadBuiltins e m => NThunk m -> m (NValue m)
attrValues = flip force $ \case
NVSet m _ -> return $ NVList $ fmap snd $ sortOn fst $ M.toList m
v -> error $ "builtins.attrValues: Expected attribute set, got "
v -> throwError $ "builtins.attrValues: Expected attribute set, got "
++ showValue v
map_ :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
map_ f = flip force $ \case
NVList l -> NVList <$> traverse (fmap valueThunk . apply f) l
v -> error $ "map: Expected list, got " ++ showValue v
v -> throwError $ "map: Expected list, got " ++ showValue v
filter_ :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
filter_ f = flip force $ \case
NVList l -> NVList <$> filterM (extractBool <=< apply f) l
v -> error $ "map: Expected list, got " ++ showValue v
v -> throwError $ "map: Expected list, got " ++ showValue v
catAttrs :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
catAttrs attrName lt = force lt $ \case
@ -635,7 +638,7 @@ getEnv_ = flip force $ \case
return $ case mres of
Nothing -> NVStr "" mempty
Just v -> NVStr (Text.pack v) mempty
p -> error $ "Unexpected argument to getEnv: " ++ show (void p)
p -> throwError $ "Unexpected argument to getEnv: " ++ show (void p)
sort_ :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
sort_ comparator list = force list $ \case
@ -771,18 +774,32 @@ typeOf t = force t $ \v -> toValue @Text $ case v of
NVEnvPath _ -> "path"
NVBuiltin _ _ -> "lambda"
tryEval :: forall e m. MonadBuiltins e m => NThunk m -> m (NValue m)
tryEval e = catch (force e (pure . onSuccess)) (pure . onError)
where
onSuccess v = flip NVSet M.empty $ M.fromList
[ ("success", valueThunk (NVConstant (NBool True)))
, ("value", valueThunk v)
]
onError :: SomeException -> NValue m
onError _ = flip NVSet M.empty $ M.fromList
[ ("success", valueThunk (NVConstant (NBool False)))
, ("value", valueThunk (NVConstant (NBool False)))
]
partition_ :: MonadBuiltins e m => NThunk m -> NThunk m -> m (NValue m)
partition_ f = flip force $ \case
NVList l -> do
let match t = apply f t >>= \case
NVConstant (NBool b) -> return (b, t)
v -> error $ "partition: Expected boolean, got " ++ showValue v
v -> throwError $ "partition: Expected boolean, got " ++ showValue v
selection <- traverse match l
let (right, wrong) = partition fst selection
let makeSide = valueThunk . NVList . map snd
return $ flip NVSet M.empty $
M.fromList [("right", makeSide right), ("wrong", makeSide wrong)]
v -> error $ "partition: Expected list, got " ++ showValue v
v -> throwError $ "partition: Expected list, got " ++ showValue v
currentSystem :: MonadNix m => m (NValue m)
currentSystem = do

12
src/Nix/Monad/Instance.hs
View file

@ -17,6 +17,7 @@
module Nix.Monad.Instance where
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Reader (MonadReader)
@ -72,7 +73,7 @@ removeDotDotIndirections = intercalate "/" . go [] . splitOn "/"
go (_:s) ("..":rest) = go s rest
go s (this:rest) = go (this:s) rest
instance (MonadFix m, MonadNix (Lazy m), MonadIO m)
instance (MonadFix m, MonadNix (Lazy m), MonadThrow m, MonadIO m)
=> MonadExpr (NThunk (Lazy m)) (NValue (Lazy m)) (Lazy m) where
embedSet = return . flip NVSet M.empty
projectSet = \case
@ -103,7 +104,14 @@ instance MonadIO m => MonadVar (Lazy m) where
instance MonadIO m => MonadFile (Lazy m) where
readFile = liftIO . BS.readFile
instance (MonadFix m, MonadIO m) => MonadNix (Lazy m) where
instance MonadCatch m => MonadCatch (Lazy m) where
catch (Lazy (ReaderT m)) f = Lazy $ ReaderT $ \e ->
catch (m e) ((`runReaderT` e) . runLazy . f)
instance MonadThrow m => MonadThrow (Lazy m) where
throwM = Lazy . throwM
instance (MonadFix m, MonadThrow m, MonadIO m) => MonadNix (Lazy m) where
addPath path = liftIO $ do
(exitCode, out, _) <-
readProcessWithExitCode "nix-store" ["--add", path] ""

15
src/Nix/Stack.hs
View file

@ -7,6 +7,8 @@
module Nix.Stack where
import Control.Exception
import Control.Monad.Catch
import Control.Monad.Reader
import Data.ByteString (ByteString)
import Data.Fix
@ -21,9 +23,14 @@ import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
import Text.Trifecta.Rendering
import Text.Trifecta.Result
data NixException = NixEvalException String
deriving Show
instance Exception NixException
type Frames = [Either String (NExprLocF ())]
type Framed e m = (MonadReader e m, Has e Frames)
type Framed e m = (MonadReader e m, Has e Frames, MonadThrow m)
withExprContext :: Framed e m => NExprLocF () -> m r -> m r
withExprContext expr = local (over hasLens (Right @String expr :))
@ -50,10 +57,10 @@ renderFrame :: MonadFile 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)))
(prettyNix (Fix (Fix (NSym "<?>") <$ expr)))
throwError :: (Framed e m, MonadFile m) => String -> m a
throwError :: (Framed e m, MonadFile m, MonadThrow m) => String -> m a
throwError str = do
context <- asks (reverse . view hasLens)
infos <- mapM renderFrame context
errorWithoutStackTrace $ unlines (infos ++ ["hnix: "++ str])
throwM $ NixEvalException $ unlines $ infos ++ [str]

5
src/Nix/Stack.hs-boot
View file

@ -3,6 +3,7 @@
module Nix.Stack where
import Control.Monad.Catch
import Control.Monad.Reader
import Data.ByteString (ByteString)
import Nix.Expr.Types.Annotated
@ -11,7 +12,7 @@ import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
type Frames = [Either String (NExprLocF ())]
type Framed e m = (MonadReader e m, Has e Frames)
type Framed e m = (MonadReader e m, Has e Frames, MonadThrow m)
withExprContext :: Framed e m => NExprLocF () -> m r -> m r
@ -24,4 +25,4 @@ renderLocation :: MonadFile m => SrcSpan -> Doc -> m Doc
renderFrame :: MonadFile m => Either String (NExprLocF ()) -> m String
throwError :: (Framed e m, MonadFile m) => String -> m a
throwError :: (Framed e m, MonadFile m, MonadThrow m) => String -> m a

29
tests/NixLanguageTests.hs
View file

@ -20,6 +20,7 @@ import Nix.Monad.Instance
import Nix.Parser
import Nix.Pretty
import Nix.Utils
import Nix.Stack
import Nix.Value
import Nix.XML
import System.Environment
@ -104,22 +105,24 @@ assertLangOkXml file = do
assertEqual "" expected $ Text.pack actual
assertEval :: [FilePath] -> Assertion
assertEval files =
case delete ".nix" $ sort $ map takeExtensions files of
[] -> assertLangOkXml name
[".exp"] -> assertLangOk name
[".exp.disabled"] -> return ()
[".exp-disabled"] -> return ()
[".exp", ".flags"] ->
assertFailure $ "Support for flags not implemented (needed by "
++ name ++ ".nix)."
_ -> assertFailure $ "Unknown test type " ++ show files
assertEval files = catch go $ \case
NixEvalException str -> error $ "Evaluation error: " ++ str
where
name = "data/nix/tests/lang/"
++ the (map (takeFileName . dropExtensions) files)
go = case delete ".nix" $ sort $ map takeExtensions files of
[] -> assertLangOkXml name
[".exp"] -> assertLangOk name
[".exp.disabled"] -> return ()
[".exp-disabled"] -> return ()
[".exp", ".flags"] ->
assertFailure $ "Support for flags not implemented (needed by "
++ name ++ ".nix)."
_ -> assertFailure $ "Unknown test type " ++ show files
where
name = "data/nix/tests/lang/"
++ the (map (takeFileName . dropExtensions) files)
assertEvalFail :: FilePath -> Assertion
assertEvalFail file = catch ?? (\(ErrorCall _) -> return ()) $ do
assertEvalFail file = catch ?? (\(_ :: SomeException) -> return ()) $ do
evalResult <- printNix <$> nixEvalFile file
evalResult `seq` assertFailure $
file ++ " should not evaluate.\nThe evaluation result was `"