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

Rework the way that info frames and error are handled 

There is still work to be done to render the new "typed frames", and to
convert all the current string based frame into typed frames. This will pave
the way forward to smarter error messages that can be browsed in intelligent
environments like Emacs and the browser.
This commit is contained in:
John Wiegley 2018-04-24 02:14:27 -07:00
parent 00a9c8463f
commit 9864a8c7a5
21 changed files with 524 additions and 405 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: 16beb8d29116e6049b925d6727fb8e104c6722c162db8fa745bc2ec17724da47
-- hash: 469fd512cc13754d0cd6b72f0c771fc90d48e89283e3308e564335e6b31e5e39
name: hnix
version: 0.5.0
@ -50,6 +50,7 @@ library
Nix.Expr.Shorthands
Nix.Expr.Types
Nix.Expr.Types.Annotated
Nix.Frames
Nix.Lint
Nix.Normal
Nix.Options
@ -58,8 +59,8 @@ library
Nix.Parser.Operators
Nix.Pretty
Nix.Reduce
Nix.Render
Nix.Scope
Nix.Stack
Nix.Strings
Nix.TH
Nix.Thunk
@ -92,6 +93,7 @@ library
, directory
, exceptions
, filepath
, freer-simple
, hashable
, megaparsec
, monadlist

4
main/Main.hs
View File

@ -62,7 +62,7 @@ main = do
else errorWithoutStackTrace) $ "Parse failed: " ++ show err
Success expr -> Exc.catch (process opts mpath expr) $ \case
NixEvalException msg -> errorWithoutStackTrace msg
NixException msg -> errorWithoutStackTrace "error" -- jww (2018-04-24): NYI msg
process opts mpath expr = do
-- when (check opts) $
@ -104,7 +104,7 @@ main = do
| json opts ->
TL.putStrLn $ A.encodeToLazyText (stripAnnotation expr)
| verbose opts >= Debug -> print $ stripAnnotation expr
| verbose opts >= DebugInfo -> print $ stripAnnotation expr
| cache opts, Just path <- mpath ->
writeCache (addExtension (dropExtension path) "nixc") expr

1
package.yaml
View File

@ -67,6 +67,7 @@ library:
- cryptohash
- deriving-compat >= 0.3 && < 0.5
- directory
- freer-simple
- hashable
- megaparsec
- monadlist

22
src/Nix.hs
View File

@ -7,12 +7,12 @@
module Nix (module Nix.Cache,
module Nix.Exec,
module Nix.Expr,
module Nix.Frames,
module Nix.Normal,
module Nix.Options,
module Nix.Parser,
module Nix.Pretty,
module Nix.Reduce,
module Nix.Stack,
module Nix.Thunk,
module Nix.Value,
module Nix.XML,
@ -45,14 +45,15 @@ import Nix.Parser.Library (Result(..))
import Nix.Pretty
import Nix.Reduce
import Nix.Scope
import Nix.Stack hiding (readFile)
import Nix.Frames
import Nix.Thunk
import Nix.Utils
import Nix.Value
import Nix.XML
-- | Evaluate a nix expression in the default context
withNixContext :: forall e m r. MonadNix e m => Maybe FilePath -> m r -> m r
withNixContext :: forall e m r. (MonadNix e m, Has e Options)
=> Maybe FilePath -> m r -> m r
withNixContext mpath action = do
base <- builtins
opts :: Options <- asks (view hasLens)
@ -70,17 +71,17 @@ withNixContext mpath action = do
-- | This is the entry point for all evaluations, whatever the expression tree
-- type. It sets up the common Nix environment and applies the
-- transformations, allowing them to be easily composed.
nixEval :: (MonadNix e m, Functor f)
nixEval :: (MonadNix e m, Has e Options, Functor f)
=> Maybe FilePath -> Transform f (m a) -> Alg f (m a) -> Fix f -> m a
nixEval mpath xform alg = withNixContext mpath . adi alg xform
-- | Evaluate a nix expression in the default context
nixEvalExpr :: forall e m. MonadNix e m
nixEvalExpr :: forall e m. (MonadNix e m, Has e Options)
=> Maybe FilePath -> NExpr -> m (NValue m)
nixEvalExpr mpath = nixEval mpath id Eval.eval
-- | Evaluate a nix expression in the default context
nixEvalExprLoc :: MonadNix e m
nixEvalExprLoc :: (MonadNix e m, Has e Options)
=> Maybe FilePath -> NExprLoc -> m (NValue m)
nixEvalExprLoc mpath =
nixEval mpath Eval.addStackFrames (Eval.eval . annotated . getCompose)
@ -90,12 +91,13 @@ nixEvalExprLoc mpath =
-- 'tracing' is set to 'True' in the Options structure (accessible through
-- 'MonadNix'). All this function does is provide the right type class
-- context.
nixTracingEvalExprLoc :: forall e m. (MonadNix e m, MonadIO m, Alternative m)
=> Maybe FilePath -> NExprLoc -> m (NValue m)
nixTracingEvalExprLoc
:: forall e m. (MonadNix e m, Has e Options, MonadIO m, Alternative m)
=> Maybe FilePath -> NExprLoc -> m (NValue m)
nixTracingEvalExprLoc mpath = withNixContext mpath . evalExprLoc
evaluateExpression
:: MonadNix e m
:: (MonadNix e m, Has e Options)
=> Maybe FilePath
-> (Maybe FilePath -> NExprLoc -> m (NValue m))
-> (NValue m -> m a)
@ -122,7 +124,7 @@ evaluateExpression mpath evaluator handler expr = do
NVClosure _ g -> g args
_ -> pure f
processResult :: forall e m a. MonadNix e m
processResult :: forall e m a. (MonadNix e m, Has e Options)
=> (NValue m -> m a) -> NValue m -> m a
processResult h val = do
opts :: Options <- asks (view hasLens)

70
src/Nix/Builtins.hs
View File

@ -59,10 +59,11 @@ import qualified Nix.Eval as Eval
import Nix.Exec
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Frames
import Nix.Normal
import Nix.Parser
import Nix.Render
import Nix.Scope
import Nix.Stack
import Nix.Thunk
import Nix.Utils
import Nix.Value
@ -187,8 +188,7 @@ builtinsList = sequence [
arity1 f = Prim . pure . f
arity2 f = ((Prim . pure) .) . f
mkThunk n = thunk
. withStringContext ("While calling builtin " ++ Text.unpack n ++ "\n")
mkThunk n = thunk . withFrame Info ("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)
@ -215,7 +215,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 $ "Unexpected entry in NIX_PATH: " ++ show x
_ -> throwError @String $ "Unexpected entry in NIX_PATH: " ++ show x
nixPath :: MonadNix e m => m (NValue m)
nixPath = fmap nvList $ flip foldNixPath [] $ \p mn rest ->
@ -233,16 +233,16 @@ 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 $ "Invalid types for builtin.hasAttr: "
(x, y) -> throwError @String $ "Invalid types for builtin.hasAttr: "
++ show (x, y)
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 _) -> case M.lookup key aset of
Nothing -> throwError $ "getAttr: field does not exist: "
Nothing -> throwError @String $ "getAttr: field does not exist: "
++ Text.unpack key
Just action -> force' action
(x, y) -> throwError $ "Invalid types for builtin.getAttr: "
(x, y) -> throwError @String $ "Invalid types for builtin.getAttr: "
++ show (x, y)
unsafeGetAttrPos :: forall e m. MonadNix e m
@ -250,10 +250,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 $ "unsafeGetAttrPos: field '" ++ Text.unpack key
throwError @String $ "unsafeGetAttrPos: field '" ++ Text.unpack key
++ "' does not exist in attr set: " ++ show apos
Just delta -> toValue delta
(x, y) -> throwError $ "Invalid types for builtin.unsafeGetAttrPos: "
(x, y) -> throwError @String $ "Invalid types for builtin.unsafeGetAttrPos: "
++ show (x, y)
-- This function is a bit special in that it doesn't care about the contents
@ -295,12 +295,12 @@ foldl'_ fun z xs =
head_ :: MonadNix e m => m (NValue m) -> m (NValue m)
head_ = fromValue >=> \case
[] -> throwError "builtins.head: empty list"
[] -> throwError @String "builtins.head: empty list"
h:_ -> force' h
tail_ :: MonadNix e m => m (NValue m) -> m (NValue m)
tail_ = fromValue >=> \case
[] -> throwError "builtins.tail: empty list"
[] -> throwError @String "builtins.tail: empty list"
_:t -> return $ nvList t
data VersionComponent
@ -380,7 +380,7 @@ parseDrvName = fromValue >=> \(s :: Text) -> do
let (name :: Text, version :: Text) = splitDrvName s
-- jww (2018-04-15): There should be an easier way to write this.
(toValue =<<) $ sequence $ M.fromList
[ ("name" :: Text, thunk (toValue name))
[ ("name" :: Text, thunk (toValue @_ @_ @(NValue m) name))
, ("version", thunk (toValue version)) ]
match_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
@ -427,7 +427,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 $ "builtins.substring: negative start position: " ++ show start
then throwError @String $ "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)
@ -440,7 +440,7 @@ 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 . withStringContext "While applying f in map:\n"
toNix <=< traverse (thunk . withFrame @String Debug "While applying f in map:\n"
. (f `callFunc`) . force')
<=< fromValue @[NThunk m] $ xs
@ -461,14 +461,14 @@ baseNameOf x = x >>= \case
--TODO: Only allow strings that represent absolute paths
NVStr path ctx -> pure $ nvStr (Text.pack $ takeFileName $ Text.unpack path) ctx
NVPath path -> pure $ nvPath $ takeFileName path
v -> throwError $ "dirOf: expected string or path, got " ++ show v
v -> throwError @String $ "dirOf: expected string or path, got " ++ show v
dirOf :: MonadNix e m => m (NValue m) -> m (NValue m)
dirOf x = x >>= \case
--TODO: Only allow strings that represent absolute paths
NVStr path ctx -> pure $ nvStr (Text.pack $ takeDirectory $ Text.unpack path) ctx
NVPath path -> pure $ nvPath $ takeDirectory path
v -> throwError $ "dirOf: expected string or path, got " ++ show v
v -> throwError @String $ "dirOf: expected string or path, got " ++ show v
unsafeDiscardStringContext :: MonadNix e m => m (NValue m) -> m (NValue m)
unsafeDiscardStringContext = fromNix @Text >=> toNix
@ -500,7 +500,7 @@ elemAt_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
elemAt_ xs n = fromNix n >>= \n' -> fromValue xs >>= \xs' ->
case elemAt xs' n' of
Just a -> force' a
Nothing -> throwError $ "builtins.elem: Index " ++ show n'
Nothing -> throwError @String $ "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)
@ -508,7 +508,7 @@ genList generator = fromNix @Integer >=> \n ->
if n >= 0
then generator >>= \f ->
toNix =<< forM [0 .. n - 1] (\i -> thunk $ f `callFunc` toNix i)
else throwError $ "builtins.genList: Expected a non-negative number, got "
else throwError @String $ "builtins.genList: Expected a non-negative number, got "
++ show n
--TODO: Preserve string context
@ -518,7 +518,7 @@ replaceStrings tfrom tto ts =
fromNix tto >>= \(to :: [Text]) ->
fromNix ts >>= \(s :: Text) -> do
when (length from /= length to) $
throwError $ "'from' and 'to' arguments to 'replaceStrings'"
throwError @String $ "'from' and 'to' arguments to 'replaceStrings'"
++ " have different lengths"
let lookupPrefix s = do
(prefix, replacement) <-
@ -569,7 +569,7 @@ functionArgs fun = fun >>= \case
case p of
Param name -> M.singleton name False
ParamSet s _ _ -> isJust <$> M.fromList s
v -> throwError $ "builtins.functionArgs: expected function, got "
v -> throwError @String $ "builtins.functionArgs: expected function, got "
++ show v
toPath :: MonadNix e m => m (NValue m) -> m (NValue m)
@ -580,9 +580,9 @@ pathExists_ path = path >>= \case
NVPath p -> toNix =<< pathExists p
-- jww (2018-04-13): Should this ever be a string?
NVStr s _ -> toNix =<< pathExists (Text.unpack s)
v -> throwError $ "builtins.pathExists: expected path, got " ++ show v
v -> throwError @String $ "builtins.pathExists: expected path, got " ++ show v
hasKind :: forall a e m. (MonadNix e m, FromNix a m (NValueF m (NThunk m)))
hasKind :: forall a e m. (MonadNix e m, FromNix a m (NValue m))
=> m (NValue m) -> m (NValue m)
hasKind = fromNixMay >=> toNix . \case Just (_ :: a) -> True; _ -> False
@ -647,7 +647,7 @@ 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 $ "builtins.lessThan: expected two numbers or two strings, "
let badType = throwError @String $ "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
@ -681,7 +681,7 @@ hashString algo s = Prim $ do
"sha1" -> pure SHA1.hash
"sha256" -> pure SHA256.hash
"sha512" -> pure SHA512.hash
_ -> throwError $ "builtins.hashString: "
_ -> throwError @String $ "builtins.hashString: "
++ "expected \"md5\", \"sha1\", \"sha256\", or \"sha512\", got " ++ show algo
pure $ decodeUtf8 $ Base16.encode $ hash $ encodeUtf8 s
@ -690,15 +690,15 @@ absolutePathFromValue = \case
NVStr pathText _ -> do
let path = Text.unpack pathText
unless (isAbsolute path) $
throwError $ "string " ++ show path ++ " doesn't represent an absolute path"
throwError @String $ "string " ++ show path ++ " doesn't represent an absolute path"
pure path
NVPath path -> pure path
v -> throwError $ "expected a path, got " ++ show v
v -> throwError @String $ "expected a path, got " ++ show v
--TODO: Move all liftIO things into MonadNixEnv or similar
readFile_ :: MonadNix e m => m (NValue m) -> m (NValue m)
readFile_ path =
path >>= absolutePathFromValue >>= Nix.Stack.readFile >>= toNix
path >>= absolutePathFromValue >>= Nix.Render.readFile >>= toNix
data FileType
= FileTypeRegular
@ -707,7 +707,7 @@ data FileType
| FileTypeUnknown
deriving (Show, Read, Eq, Ord)
instance Applicative m => ToNix FileType m (NValueF m r) where
instance Applicative m => ToNix FileType m (NValue m) where
toNix = toNix . \case
FileTypeRegular -> "regular" :: Text
FileTypeDirectory -> "directory"
@ -731,7 +731,7 @@ 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 $ "builtins.fromJSON: " ++ jsonError
Left jsonError -> throwError @String $ "builtins.fromJSON: " ++ jsonError
Right v -> toValue v
toXML_ :: MonadNix e m => m (NValue m) -> m (NValue m)
@ -771,18 +771,18 @@ 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 "builtins.fetchTarball: Missing url attribute"
Nothing -> throwError @String "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 $ "builtins.fetchTarball: Expected URI or set, got "
v -> throwError @String $ "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 $ "builtins.fetchTarball: Expected URI or string, got "
v -> throwError @String $ "builtins.fetchTarball: Expected URI or string, got "
++ show v
{- jww (2018-04-11): This should be written using pipes in another module
@ -793,7 +793,7 @@ fetchTarball v = v >>= \case
".bz2" -> undefined
".xz" -> undefined
".tar" -> undefined
ext -> throwError $ "builtins.fetchTarball: Unsupported extension '"
ext -> throwError @String $ "builtins.fetchTarball: Unsupported extension '"
++ ext ++ "'"
-}
@ -832,10 +832,10 @@ newtype Prim m a = Prim { runPrim :: m a }
class ToBuiltin m a | a -> m where
toBuiltin :: String -> a -> m (NValue m)
instance (MonadNix e m, ToNix a m (NValueF m (NThunk m)))
instance (MonadNix e m, ToNix a m (NValue m))
=> ToBuiltin m (Prim m a) where
toBuiltin _ p = toNix =<< runPrim p
instance (MonadNix e m, FromNix a m (NValueF m (NThunk m)), ToBuiltin m b)
instance (MonadNix e m, FromNix a m (NValue m), ToBuiltin m b)
=> ToBuiltin m (a -> b) where
toBuiltin name f = return $ nvBuiltin name (fromNix >=> toBuiltin name . f)

2
src/Nix/Context.hs
View File

@ -6,7 +6,7 @@ module Nix.Context where
import Nix.Options
import Nix.Scope
import Nix.Stack
import Nix.Frames
import Nix.Utils
data Context m v = Context

374
src/Nix/Convert.hs
View File

@ -1,8 +1,10 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
@ -39,8 +41,8 @@ import Nix.Atoms
import Nix.Effects
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Frames
import Nix.Normal
import Nix.Stack
import Nix.Thunk
import Nix.Utils
import Nix.Value
@ -49,7 +51,7 @@ class FromValue a m v where
fromValue :: v -> m a
fromValueMay :: v -> m (Maybe a)
type Convertible e m = (Framed e m, MonadVar m, MonadFile m)
type Convertible e m = (Framed e m, MonadVar m, Typeable m)
instance Convertible e m => FromValue () m (NValueNF m) where
fromValueMay = \case
@ -57,16 +59,16 @@ instance Convertible e m => FromValue () m (NValueNF m) where
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a null, but saw: " ++ show v
_ -> throwError $ ExpectationNF TNull v
instance (Convertible e m, Show (NValueF m r))
=> FromValue () m (NValueF m r) where
instance Convertible e m
=> FromValue () m (NValue m) where
fromValueMay = \case
NVConstantF NNull -> pure $ Just ()
NVConstant NNull -> pure $ Just ()
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a null, but saw: " ++ show v
_ -> throwError $ Expectation TNull v
instance Convertible e m
=> FromValue Bool m (NValueNF m) where
@ -75,16 +77,16 @@ instance Convertible e m
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a bool, but saw: " ++ show v
_ -> throwError $ ExpectationNF TBool v
instance (Convertible e m, Show (NValueF m r))
=> FromValue Bool m (NValueF m r) where
instance Convertible e m
=> FromValue Bool m (NValue m) where
fromValueMay = \case
NVConstantF (NBool b) -> pure $ Just b
NVConstant (NBool b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a bool, but saw: " ++ show v
_ -> throwError $ Expectation TBool v
instance Convertible e m
=> FromValue Int m (NValueNF m) where
@ -93,16 +95,16 @@ instance Convertible e m
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected an integer, but saw: " ++ show v
_ -> throwError $ ExpectationNF TInt v
instance (Convertible e m, Show (NValueF m r))
=> FromValue Int m (NValueF m r) where
instance Convertible e m
=> FromValue Int m (NValue m) where
fromValueMay = \case
NVConstantF (NInt b) -> pure $ Just (fromInteger b)
NVConstant (NInt b) -> pure $ Just (fromInteger b)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected an integer, but saw: " ++ show v
_ -> throwError $ Expectation TInt v
instance Convertible e m
=> FromValue Integer m (NValueNF m) where
@ -111,16 +113,16 @@ instance Convertible e m
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected an integer, but saw: " ++ show v
_ -> throwError $ ExpectationNF TInt v
instance (Convertible e m, Show (NValueF m r))
=> FromValue Integer m (NValueF m r) where
instance Convertible e m
=> FromValue Integer m (NValue m) where
fromValueMay = \case
NVConstantF (NInt b) -> pure $ Just b
NVConstant (NInt b) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected an integer, but saw: " ++ show v
_ -> throwError $ Expectation TInt v
instance Convertible e m
=> FromValue Float m (NValueNF m) where
@ -130,17 +132,17 @@ instance Convertible e m
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a float, but saw: " ++ show v
_ -> throwError $ ExpectationNF TFloat v
instance (Convertible e m, Show (NValueF m r))
=> FromValue Float m (NValueF m r) where
instance Convertible e m
=> FromValue Float m (NValue m) where
fromValueMay = \case
NVConstantF (NFloat b) -> pure $ Just b
NVConstantF (NInt i) -> pure $ Just (fromInteger i)
NVConstant (NFloat b) -> pure $ Just b
NVConstant (NInt i) -> pure $ Just (fromInteger i)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a float, but saw: " ++ show v
_ -> throwError $ Expectation TFloat v
instance (Convertible e m, MonadEffects m)
=> FromValue Text m (NValueNF m) where
@ -154,22 +156,21 @@ instance (Convertible e m, MonadEffects m)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a string, but saw: " ++ show v
_ -> throwError $ ExpectationNF TString v
instance (Convertible e m, MonadEffects m,
FromValue Text m r, Show (NValueF m r))
=> FromValue Text m (NValueF m r) where
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, MonadEffects m)
=> FromValue Text m (NValue m) where
fromValueMay = \case
NVConstantF (NUri u) -> pure $ Just u
NVStrF t _ -> pure $ Just t
NVPathF p -> Just . Text.pack . unStorePath <$> addPath p
NVSetF s _ -> case M.lookup "outPath" s of
NVConstant (NUri u) -> pure $ Just u
NVStr t _ -> pure $ Just t
NVPath p -> Just . Text.pack . unStorePath <$> addPath p
NVSet s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Text p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a string, but saw: " ++ show v
_ -> throwError $ Expectation TString v
instance (Convertible e m, MonadEffects m)
=> FromValue (Text, DList Text) m (NValueNF m) where
@ -183,22 +184,21 @@ instance (Convertible e m, MonadEffects m)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a string, but saw: " ++ show v
_ -> throwError $ ExpectationNF TString v
instance (Convertible e m, MonadEffects m,
FromValue Text m r, Show (NValueF m r))
=> FromValue (Text, DList Text) m (NValueF m r) where
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, MonadEffects m)
=> FromValue (Text, DList Text) m (NValue m) where
fromValueMay = \case
NVConstantF (NUri u) -> pure $ Just (u, mempty)
NVStrF t d -> pure $ Just (t, d)
NVPathF p -> Just . (,mempty) . Text.pack . unStorePath <$> addPath p
NVSetF s _ -> case M.lookup "outPath" s of
NVConstant (NUri u) -> pure $ Just (u, mempty)
NVStr t d -> pure $ Just (t, d)
NVPath p -> Just . (,mempty) . Text.pack . unStorePath <$> addPath p
NVSet s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fmap (,mempty) <$> fromValueMay @Text p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a string, but saw: " ++ show v
_ -> throwError $ Expectation TString v
instance Convertible e m
=> FromValue ByteString m (NValueNF m) where
@ -207,22 +207,21 @@ instance Convertible e m
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a string, but saw: " ++ show v
_ -> throwError $ ExpectationNF TString v
instance (Convertible e m, Show (NValueF m r))
=> FromValue ByteString m (NValueF m r) where
instance Convertible e m
=> FromValue ByteString m (NValue m) where
fromValueMay = \case
NVStrF t _ -> pure $ Just (encodeUtf8 t)
NVStr t _ -> pure $ Just (encodeUtf8 t)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a string, but saw: " ++ show v
_ -> throwError $ Expectation TString v
newtype Path = Path { getPath :: FilePath }
deriving Show
instance Convertible e m
=> FromValue Path m (NValueNF m) where
instance Convertible e m => FromValue Path m (NValueNF m) where
fromValueMay = \case
Fix (NVConstantF (NUri u)) -> pure $ Just (Path (Text.unpack u))
Fix (NVPathF p) -> pure $ Just (Path p)
@ -233,21 +232,21 @@ instance Convertible e m
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a path, but saw: " ++ show v
_ -> throwError $ ExpectationNF TPath v
instance (Convertible e m, FromValue Path m r, Show (NValueF m r))
=> FromValue Path m (NValueF m r) where
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m)
=> FromValue Path m (NValue m) where
fromValueMay = \case
NVConstantF (NUri u) -> pure $ Just (Path (Text.unpack u))
NVPathF p -> pure $ Just (Path p)
NVStrF s _ -> pure $ Just (Path (Text.unpack s))
NVSetF s _ -> case M.lookup "outPath" s of
NVConstant (NUri u) -> pure $ Just (Path (Text.unpack u))
NVPath p -> pure $ Just (Path p)
NVStr s _ -> pure $ Just (Path (Text.unpack s))
NVSet s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Path p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a path, but saw: " ++ show v
_ -> throwError $ Expectation TPath v
instance (Convertible e m,
FromValue a m (NValueNF m), Show a)
@ -257,16 +256,15 @@ instance (Convertible e m,
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected an attrset, but saw: " ++ show v
_ -> throwError $ ExpectationNF TList v
instance (Convertible e m, Show (NValueF m r))
=> FromValue [r] m (NValueF m r) where
instance Convertible e m => FromValue [NThunk m] m (NValue m) where
fromValueMay = \case
NVListF l -> pure $ Just l
NVList l -> pure $ Just l
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected an attrset, but saw: " ++ show v
_ -> throwError $ Expectation TList v
instance Convertible e m
=> FromValue (HashMap Text (NValueNF m)) m (NValueNF m) where
@ -275,16 +273,16 @@ instance Convertible e m
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected an attrset, but saw: " ++ show v
_ -> throwError $ ExpectationNF TSet v
instance (Convertible e m, Show (NValueF m r))
=> FromValue (HashMap Text r) m (NValueF m r) where
instance Convertible e m
=> FromValue (HashMap Text (NThunk m)) m (NValue m) where
fromValueMay = \case
NVSetF s _ -> pure $ Just s
NVSet s _ -> pure $ Just s
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected an attrset, but saw: " ++ show v
_ -> throwError $ Expectation TSet v
instance Convertible e m
=> FromValue (HashMap Text (NValueNF m),
@ -294,40 +292,34 @@ instance Convertible e m
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected an attrset, but saw: " ++ show v
_ -> throwError $ ExpectationNF TSet v
instance (Convertible e m, Show (NValueF m r))
=> FromValue (HashMap Text r,
HashMap Text SourcePos) m (NValueF m r) where
instance Convertible e m
=> FromValue (HashMap Text (NThunk m),
HashMap Text SourcePos) m (NValue m) where
fromValueMay = \case
NVSetF s p -> pure $ Just (s, p)
NVSet s p -> pure $ Just (s, p)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected an attrset, but saw: " ++ show v
_ -> throwError $ Expectation TSet v
instance (MonadThunk (NValue m) (NThunk m) m, Convertible e m)
=> FromValue (NThunk m) m (NValueF m (NThunk m)) where
fromValueMay = pure . Just . value @_ @_ @m . NValue Nothing
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m)
=> FromValue (NThunk m) m (NValue m) where
fromValueMay = pure . Just . value @_ @_ @m
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected a thunk, but saw: " ++ show v
_ -> error "Impossible, see fromValueMay"
instance (Monad m, FromValue a m v) => FromValue a m (m v) where
fromValueMay = (>>= fromValueMay)
fromValue = (>>= fromValue)
instance (MonadThunk (NValue m) (NThunk m) m,
FromValue a m (NValueF m (NThunk m)))
instance (MonadThunk (NValue m) (NThunk m) m, FromValue a m (NValue m))
=> FromValue a m (NThunk m) where
fromValueMay = force ?? fromValueMay
fromValue = force ?? fromValue
instance FromValue a m (NValueF m (NThunk m))
=> FromValue a m (NValue m) where
fromValueMay = fromValueMay . baseValue
fromValue = fromValue . baseValue
instance (Convertible e m, MonadEffects m)
=> FromValue A.Value m (NValueNF m) where
fromValueMay = \case
@ -346,7 +338,7 @@ instance (Convertible e m, MonadEffects m)
Fix (NVBuiltinF _ _) -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ "Cannot convert value to JSON: " ++ show v
_ -> throwError $ CoercionToJsonNF v
class ToValue a m v where
toValue :: a -> m v
@ -354,90 +346,90 @@ class ToValue a m v where
instance Applicative m => ToValue () m (NValueNF m) where
toValue _ = pure . Fix . NVConstantF $ NNull
instance Applicative m => ToValue () m (NValueF m r) where
toValue _ = pure . NVConstantF $ NNull
instance Applicative m => ToValue () m (NValue m) where
toValue _ = pure . nvConstant $ NNull
instance Applicative m => ToValue Bool m (NValueNF m) where
toValue = pure . Fix . NVConstantF . NBool
instance Applicative m => ToValue Bool m (NValueF m r) where
toValue = pure . NVConstantF . NBool
instance Applicative m => ToValue Bool m (NValue m) where
toValue = pure . nvConstant . NBool
instance Applicative m => ToValue Int m (NValueNF m) where
toValue = pure . Fix . NVConstantF . NInt . toInteger
instance Applicative m => ToValue Int m (NValueF m r) where
toValue = pure . NVConstantF . NInt . toInteger
instance Applicative m => ToValue Int m (NValue m) where
toValue = pure . nvConstant . NInt . toInteger
instance Applicative m => ToValue Integer m (NValueNF m) where
toValue = pure . Fix . NVConstantF . NInt
instance Applicative m => ToValue Integer m (NValueF m r) where
toValue = pure . NVConstantF . NInt
instance Applicative m => ToValue Integer m (NValue m) where
toValue = pure . nvConstant . NInt
instance Applicative m => ToValue Float m (NValueNF m) where
toValue = pure . Fix . NVConstantF . NFloat
instance Applicative m => ToValue Float m (NValueF m r) where
toValue = pure . NVConstantF . NFloat
instance Applicative m => ToValue Float m (NValue m) where
toValue = pure . nvConstant . NFloat
instance Applicative m => ToValue Text m (NValueNF m) where
toValue = pure . Fix . flip NVStrF mempty
instance Applicative m => ToValue Text m (NValueF m r) where
toValue = pure . flip NVStrF mempty
instance Applicative m => ToValue Text m (NValue m) where
toValue = pure . flip nvStr mempty
instance Applicative m => ToValue (Text, DList Text) m (NValueNF m) where
toValue = pure . Fix . uncurry NVStrF
instance Applicative m => ToValue (Text, DList Text) m (NValueF m r) where
toValue = pure . uncurry NVStrF
instance Applicative m => ToValue (Text, DList Text) m (NValue m) where
toValue = pure . uncurry nvStr
instance Applicative m => ToValue ByteString m (NValueNF m) where
toValue = pure . Fix . flip NVStrF mempty . decodeUtf8
instance Applicative m => ToValue ByteString m (NValueF m r) where
toValue = pure . flip NVStrF mempty . decodeUtf8
instance Applicative m => ToValue ByteString m (NValue m) where
toValue = pure . flip nvStr mempty . decodeUtf8
instance Applicative m => ToValue Path m (NValueNF m) where
toValue = pure . Fix . NVPathF . getPath
instance Applicative m => ToValue Path m (NValueF m r) where
toValue = pure . NVPathF . getPath
instance Applicative m => ToValue Path m (NValue m) where
toValue = pure . nvPath . getPath
instance MonadThunk (NValue m) (NThunk m) m
=> ToValue SourcePos m (NValueF m (NThunk m)) where
=> ToValue SourcePos m (NValue m) where
toValue (SourcePos f l c) = do
f' <- NValue Nothing <$> toValue (Text.pack f)
l' <- NValue Nothing <$> toValue (unPos l)
c' <- NValue Nothing <$> toValue (unPos c)
f' <- toValue (Text.pack f)
l' <- toValue (unPos l)
c' <- toValue (unPos c)
let pos = M.fromList
[ ("file" :: Text, value @_ @_ @m f')
, ("line", value @_ @_ @m l')
, ("column", value @_ @_ @m c') ]
pure $ NVSetF pos mempty
pure $ nvSet pos mempty
instance (ToValue a m (NValueNF m), Applicative m)
=> ToValue [a] m (NValueNF m) where
toValue = fmap (Fix . NVListF) . traverse toValue
instance Applicative m => ToValue [r] m (NValueF m r) where
toValue = pure . NVListF
instance Applicative m => ToValue [NThunk m] m (NValue m) where
toValue = pure . nvList
instance Applicative m
=> ToValue (HashMap Text (NValueNF m)) m (NValueNF m) where
toValue = pure . Fix . flip NVSetF M.empty
instance Applicative m => ToValue (HashMap Text r) m (NValueF m r) where
toValue = pure . flip NVSetF M.empty
instance Applicative m => ToValue (HashMap Text (NThunk m)) m (NValue m) where
toValue = pure . flip nvSet M.empty
instance Applicative m => ToValue (HashMap Text (NValueNF m),
HashMap Text SourcePos) m (NValueNF m) where
toValue (s, p) = pure $ Fix $ NVSetF s p
instance Applicative m => ToValue (HashMap Text r,
HashMap Text SourcePos) m (NValueF m r) where
toValue (s, p) = pure $ NVSetF s p
instance Applicative m => ToValue (HashMap Text (NThunk m),
HashMap Text SourcePos) m (NValue m) where
toValue (s, p) = pure $ nvSet s p
instance (MonadThunk (NValue m) (NThunk m) m, ToValue a m (NValue m))
=> ToValue a m (NThunk m) where
@ -449,26 +441,23 @@ instance Applicative m => ToValue Bool m (NExprF r) where
instance Applicative m => ToValue () m (NExprF r) where
toValue _ = pure . NConstant $ NNull
instance (Framed e m, MonadThunk (NValue m) (NThunk m) m)
=> ToValue A.Value m (NValueF m (NThunk m)) where
whileForcingThunk :: (Framed e m, Frame s) => s -> m r -> m r
whileForcingThunk frame = withFrame Debug ForcingThunk . withFrame Debug frame
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m)
=> ToValue A.Value m (NValue m) where
toValue = \case
A.Object m -> flip NVSetF M.empty
<$> traverse (thunk . fmap (NValue Nothing)
. toValue @_ @_ @(NValueF m (NThunk m))) m
A.Array l -> NVListF <$>
traverse (thunk . withStringContext "While coercing to a JSON value"
. toValue) (V.toList l)
A.String s -> pure $ NVStrF s mempty
A.Number n -> pure $ NVConstantF $ case floatingOrInteger n of
A.Object m -> flip nvSet M.empty
<$> traverse (thunk . toValue @_ @_ @(NValue m)) m
A.Array l -> nvList <$>
traverse (\x -> thunk . whileForcingThunk (CoercionFromJson x)
. toValue $ x) (V.toList l)
A.String s -> pure $ nvStr s mempty
A.Number n -> pure $ nvConstant $ case floatingOrInteger n of
Left r -> NFloat r
Right i -> NInt i
A.Bool b -> pure $ NVConstantF $ NBool b
A.Null -> pure $ NVConstantF NNull
instance (MonadThunk (NValue m) (NThunk m) m,
ToValue a m (NValueF m (NThunk m)))
=> ToValue a m (NValue m) where
toValue = fmap (NValue Nothing) . toValue
A.Bool b -> pure $ nvConstant $ NBool b
A.Null -> pure $ nvConstant NNull
class FromNix a m v where
fromNix :: v -> m a
@ -480,56 +469,53 @@ class FromNix a m v where
fromNixMay = fromValueMay
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m,
FromNix a m (NValueF m (NThunk m)), Show a)
=> FromNix [a] m (NValueF m (NThunk m)) where
FromNix a m (NValue m))
=> FromNix [a] m (NValue m) where
fromNixMay = \case
NVListF l -> sequence <$> traverse (`force` fromNixMay . baseValue) l
NVList l -> sequence <$> traverse (`force` fromNixMay) l
_ -> pure Nothing
fromNix v = fromNixMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected an attrset, but saw: " ++ show v
_ -> throwError $ Expectation TList v
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m,
FromNix a m (NValueF m (NThunk m)), Show a)
=> FromNix (HashMap Text a) m (NValueF m (NThunk m)) where
FromNix a m (NValue m))
=> FromNix (HashMap Text a) m (NValue m) where
fromNixMay = \case
NVSetF s _ -> sequence <$> traverse (`force` fromNixMay . baseValue) s
NVSet s _ -> sequence <$> traverse (`force` fromNixMay) s
_ -> pure Nothing
fromNix v = fromNixMay v >>= \case
Just b -> pure b
_ -> throwError $ "Expected an attrset, but saw: " ++ show v
_ -> throwError $ Expectation TSet v
instance Convertible e m => FromNix () m (NValueNF m) where
instance (Convertible e m, Show (NValueF m r)) => FromNix () m (NValueF m r) where
instance Convertible e m => FromNix () m (NValue m) where
instance Convertible e m => FromNix Bool m (NValueNF m) where
instance (Convertible e m, Show (NValueF m r)) => FromNix Bool m (NValueF m r) where
instance Convertible e m => FromNix Bool m (NValue m) where
instance Convertible e m => FromNix Int m (NValueNF m) where
instance (Convertible e m, Show (NValueF m r)) => FromNix Int m (NValueF m r) where
instance Convertible e m => FromNix Int m (NValue m) where
instance Convertible e m => FromNix Integer m (NValueNF m) where
instance (Convertible e m, Show (NValueF m r)) => FromNix Integer m (NValueF m r) where
instance Convertible e m => FromNix Integer m (NValue m) where
instance Convertible e m => FromNix Float m (NValueNF m) where
instance (Convertible e m, Show (NValueF m r)) => FromNix Float m (NValueF m r) where
instance Convertible e m => FromNix Float m (NValue m) where
instance (Convertible e m, MonadEffects m) => FromNix Text m (NValueNF m) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m, FromValue Text m r, Show (NValueF m r)) => FromNix Text m (NValueF m r) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix Text m (NValue m) where
instance (Convertible e m, MonadEffects m) => FromNix (Text, DList Text) m (NValueNF m) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m, FromValue Text m r, Show (NValueF m r)) => FromNix (Text, DList Text) m (NValueF m r) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix (Text, DList Text) m (NValue m) where
instance Convertible e m => FromNix ByteString m (NValueNF m) where
instance (Convertible e m, Show (NValueF m r)) => FromNix ByteString m (NValueF m r) where
instance Convertible e m => FromNix ByteString m (NValue m) where
instance Convertible e m => FromNix Path m (NValueNF m) where
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m) => FromNix Path m (NValueF m (NThunk m)) where
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m) => FromNix Path m (NValue m) where
instance (Convertible e m, FromValue a m (NValueNF m), Show a) => FromNix [a] m (NValueNF m) where
instance Convertible e m => FromNix (HashMap Text (NValueNF m)) m (NValueNF m) where
instance Convertible e m => FromNix (HashMap Text (NValueNF m), HashMap Text SourcePos) m (NValueNF m) where
instance (Convertible e m, Show (NValueF m r)) => FromNix (HashMap Text r, HashMap Text SourcePos) m (NValueF m r) where
instance Convertible e m => FromNix (HashMap Text (NThunk m), HashMap Text SourcePos) m (NValue m) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix A.Value m (NValueNF m) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix A.Value m (NValueF m (NThunk m)) where
fromNixMay = fromNixMay <=< normalForm . NValue Nothing
fromNix = fromNix <=< normalForm . NValue Nothing
instance FromNix a m (NValueF m (NThunk m)) => FromNix a m (NValue m) where
fromNixMay = fromNixMay . baseValue
fromNix = fromNix . baseValue
instance (Convertible e m, MonadEffects m,
MonadThunk (NValue m) (NThunk m) m) => FromNix A.Value m (NValue m) where
fromNixMay = fromNixMay <=< normalForm
fromNix = fromNix <=< normalForm
instance (Monad m, FromNix a m v) => FromNix a m (m v) where
fromNixMay = (>>= fromNixMay)
@ -541,70 +527,60 @@ instance (MonadThunk (NValue m) (NThunk m) m, FromNix a m (NValue m))
fromNix = force ?? fromNix
instance MonadThunk (NValue m) (NThunk m) m
=> FromNix (NThunk m) m (NValueF m (NThunk m)) where
fromNixMay = pure . Just . value . NValue Nothing
fromNix = pure . value . NValue Nothing
=> FromNix (NThunk m) m (NValue m) where
fromNixMay = pure . Just . value
fromNix = pure . value
class ToNix a m v where
toNix :: a -> m v
default toNix :: ToValue a m v => a -> m v
toNix = toValue
instance (Framed e m, MonadThunk (NValue m) (NThunk m) m,
ToNix a m (NValueF m (NThunk m)))
=> ToNix [a] m (NValueF m (NThunk m)) where
toNix = fmap NVListF
. traverse (thunk . withStringContext "While coercing to a list"
. fmap (NValue Nothing)
. toNix)
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m,
ToNix a m (NValue m))
=> ToNix [a] m (NValue m) where
toNix = fmap nvList
. traverse (thunk . ((\v -> whileForcingThunk (ConcerningValue v) (pure v))
<=< toNix))
instance (Framed e m, MonadThunk (NValue m) (NThunk m) m,
ToNix a m (NValueF m (NThunk m)))
=> ToNix (HashMap Text a) m (NValueF m (NThunk m)) where
toNix = fmap (flip NVSetF M.empty)
. traverse (thunk . withStringContext "While coercing to a set"
. fmap (NValue Nothing)
. toNix)
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m,
ToNix a m (NValue m))
=> ToNix (HashMap Text a) m (NValue m) where
toNix = fmap (flip nvSet M.empty)
. traverse (thunk . ((\v -> whileForcingThunk (ConcerningValue v) (pure v))
<=< toNix))
instance Applicative m => ToNix () m (NValueNF m) where
instance Applicative m => ToNix () m (NValueF m r) where
instance Applicative m => ToNix () m (NValue m) where
instance Applicative m => ToNix Bool m (NValueNF m) where
instance Applicative m => ToNix Bool m (NValueF m r) where
instance Applicative m => ToNix Bool m (NValue m) where
instance Applicative m => ToNix Int m (NValueNF m) where
instance Applicative m => ToNix Int m (NValueF m r) where
instance Applicative m => ToNix Int m (NValue m) where
instance Applicative m => ToNix Integer m (NValueNF m) where
instance Applicative m => ToNix Integer m (NValueF m r) where
instance Applicative m => ToNix Integer m (NValue m) where
instance Applicative m => ToNix Float m (NValueNF m) where
instance Applicative m => ToNix Float m (NValueF m r) where
instance Applicative m => ToNix Float m (NValue m) where
instance Applicative m => ToNix Text m (NValueNF m) where
instance Applicative m => ToNix Text m (NValueF m r) where
instance Applicative m => ToNix Text m (NValue m) where
instance Applicative m => ToNix (Text, DList Text) m (NValueNF m) where
instance Applicative m => ToNix (Text, DList Text) m (NValueF m r) where
instance Applicative m => ToNix (Text, DList Text) m (NValue m) where
instance Applicative m => ToNix ByteString m (NValueNF m) where
instance Applicative m => ToNix ByteString m (NValueF m r) where
instance Applicative m => ToNix ByteString m (NValue m) where
instance Applicative m => ToNix Path m (NValueNF m) where
instance Applicative m => ToNix Path m (NValueF m r) where
instance Applicative m => ToNix Path m (NValue m) where
instance Applicative m => ToNix (HashMap Text (NValueNF m)) m (NValueNF m) where
instance Applicative m => ToNix (HashMap Text (NValueNF m), HashMap Text SourcePos) m (NValueNF m) where
instance Applicative m => ToNix (HashMap Text r, HashMap Text SourcePos) m (NValueF m r) where
instance (Framed e m, MonadThunk (NValue m) (NThunk m) m) => ToNix A.Value m (NValueF m (NThunk m)) where
instance Applicative m => ToNix (HashMap Text (NThunk m), HashMap Text SourcePos) m (NValue m) where
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m) => ToNix A.Value m (NValue m) where
instance Applicative m => ToNix Bool m (NExprF r) where
instance Applicative m => ToNix () m (NExprF r) where
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValueF m (NThunk m)))
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValue m))
=> ToNix a m (NThunk m) where
toNix = thunk . fmap (NValue Nothing) . toNix
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValueF m (NThunk m)))
=> ToNix a m (NValue m) where
toNix = fmap (NValue Nothing) . toNix
toNix = thunk . toNix
instance (Applicative m, ToNix a m (NValueNF m)) => ToNix [a] m (NValueNF m) where
toNix = fmap (Fix . NVListF) . traverse toNix
instance MonadThunk (NValue m) (NThunk m) m => ToNix (NThunk m) m (NValue m) where
toNix = force ?? pure
instance MonadThunk (NValue m) (NThunk m) m
=> ToNix (NThunk m) m (NValueF m (NThunk m)) where
toNix = force ?? (pure . baseValue)

7
src/Nix/Effects.hs
View File

@ -1,14 +1,15 @@
module Nix.Effects where
import Data.Text (Text)
import System.Posix.Files
import Nix.Value
import Nix.Render
import Nix.Utils
import Nix.Value
import System.Posix.Files
-- | A path into the nix store
newtype StorePath = StorePath { unStorePath :: FilePath }
class MonadEffects m where
class MonadFile m => MonadEffects m where
-- | Import a path into the nix store, and return the resulting path
addPath :: FilePath -> m StorePath

21
src/Nix/Eval.hs
View File

@ -3,6 +3,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@ -39,9 +40,8 @@ import Data.Void
import Nix.Atoms
import Nix.Convert
import Nix.Expr
import Nix.Pretty
import Nix.Frames
import Nix.Scope
import Nix.Stack
import Nix.Strings (runAntiquoted)
import Nix.Thunk
import Nix.Utils
@ -85,19 +85,24 @@ class (Show v, Monad m) => MonadEval v m | v -> m where
type MonadNixEval e v t m =
(MonadEval v m, Scoped e t m, MonadThunk v t m, MonadFix m,
Framed e m, MonadFile m, MonadVar m,
Framed e m, MonadVar m,
ToValue Bool m v, ToValue [t] m v,
FromValue (Text, DList Text) m v,
ToValue (AttrSet t) m v, FromValue (AttrSet t) m v,
ToValue (AttrSet t, AttrSet SourcePos) m v,
FromValue (AttrSet t, AttrSet SourcePos) m v)
newtype ExprContext = ExprContext NExpr
newtype EvaluatingExpr = EvaluatingExpr NExprLoc
instance Frame ExprContext
instance Frame EvaluatingExpr
wrapExpr :: NExprF (m v) -> NExpr
wrapExpr x = Fix (Fix (NSym "<?>") <$ x)
exprFContext :: (Framed e m) => NExprF (m v) -> m r -> m r
exprFContext e = withStringContext $
"While forcing thunk for: " ++ show (prettyNix (wrapExpr e)) ++ "\n"
exprFContext :: Framed e m => NExprF (m v) -> m r -> m r
exprFContext e = withFrame Debug (ExprContext (wrapExpr e))
eval :: forall e v t m. MonadNixEval e v t m => NExprF (m v) -> m v
@ -429,7 +434,7 @@ buildArgument e params arg = do
These x _ -> const (pure x)
addStackFrames :: Framed e m => Transform NExprLocF (m a)
addStackFrames f v = withExprContext v (f v)
addStackFrames f v = withFrame Info (EvaluatingExpr v) (f v)
framedEvalExprLoc :: MonadNixEval e v t m => NExprLoc -> m v
framedEvalExprLoc :: forall e v t m. MonadNixEval e v t m => NExprLoc -> m v
framedEvalExprLoc = adi (eval . annotated . getCompose) addStackFrames

25
src/Nix/Exec.hs
View File

@ -44,6 +44,7 @@ import Data.List.Split
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable
import Data.Void
import Nix.Atoms
import Nix.Context
@ -51,12 +52,13 @@ import Nix.Convert
import Nix.Effects
import Nix.Eval as Eval
import Nix.Expr
import Nix.Frames
import Nix.Normal
import Nix.Options
import Nix.Parser
import Nix.Pretty
import Nix.Render
import Nix.Scope
import Nix.Stack
import Nix.Thunk
import Nix.Utils
import Nix.Value
@ -70,7 +72,7 @@ import System.Process (readProcessWithExitCode)
import Text.PrettyPrint.ANSI.Leijen (text)
type MonadNix e m =
(Scoped e (NThunk m) m, Framed e m, MonadVar m, MonadFile m,
(Scoped e (NThunk m) m, Framed e m, Typeable m, MonadVar m,
MonadEffects m, MonadFix m, MonadCatch m, Alternative m)
nverr :: forall e m a. MonadNix e m => String -> m a
@ -84,8 +86,8 @@ instance MonadNix e m => MonadThunk (NValue m) (NThunk m) m where
currentPos :: Framed e m => m SrcSpan
currentPos = do
frames <- asks (view @_ @Frames hasLens)
let Fix (Compose (Ann span _)) : _ =
mapMaybe (either (const Nothing) Just) frames
let EvaluatingExpr (Fix (Compose (Ann span _))) : _ =
mapMaybe (fromFrame . frame) frames
return span
instance MonadNix e m => MonadEval (NValue m) m where
@ -189,7 +191,7 @@ callFunc fun arg = case fun of
force f $ (`callFunc` pure s) >=> (`callFunc` arg)
x -> throwError $ "Attempt to call non-function: " ++ show x
execUnaryOp :: (Framed e m, MonadVar m, MonadFile m)
execUnaryOp :: (Framed e m, MonadVar m)
=> Scopes m (NThunk m) -> SrcSpan -> NUnaryOp -> NValue m
-> m (NValue m)
execUnaryOp scope span op arg = do
@ -372,7 +374,7 @@ instance MonadIO m => MonadVar (Lazy m) where
writeVar = (liftIO .) . writeIORef
atomicModifyVar = (liftIO .) . atomicModifyIORef
instance MonadIO m => MonadFile (Lazy m) where
instance (MonadIO m, Monad m) => MonadFile m where
readFile = liftIO . BS.readFile
instance MonadCatch m => MonadCatch (Lazy m) where
@ -382,7 +384,8 @@ instance MonadCatch m => MonadCatch (Lazy m) where
instance MonadThrow m => MonadThrow (Lazy m) where
throwM = Lazy . throwM
instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m, Alternative m)
instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m,
Alternative m, Typeable m)
=> MonadEffects (Lazy m) where
addPath path = do
(exitCode, out, _) <-
@ -428,7 +431,7 @@ instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m, Alternative m)
traceM $ "Importing file " ++ path'
withStringContext ("While importing file " ++ show path') $ do
withFrame Info ("While importing file " ++ show path') $ do
eres <- Lazy $ parseNixFileLoc path'
case eres of
Failure err -> error $ "Parse failed: " ++ show err
@ -460,7 +463,7 @@ instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m, Alternative m)
=<< toValue @(ValueSet (Lazy m)) . M.fromList
=<< mapMaybeM
(\(k, v) -> fmap (k,) <$> case k of
"args" -> fmap Just . thunk . fmap (NValue Nothing) $
"args" -> fmap Just . thunk $
toNix =<< fromNix @[Text] v
"__ignoreNulls" -> pure Nothing
_ -> force v $ \case
@ -587,7 +590,7 @@ findEnvPathM name = do
nixFilePath $ p <///> joinPath ns
tryPath p _ = nixFilePath $ p <///> name
addTracing :: (MonadNix e m, MonadIO m,
addTracing :: (MonadNix e m, Has e Options, MonadIO m,
MonadReader Int n, Alternative n)
=> Alg NExprLocF (m a) -> Alg NExprLocF (n (m a))
addTracing k v = do
@ -608,7 +611,7 @@ addTracing k v = do
liftIO $ putStrLn $ msg (rendered ++ " ...done")
return res
evalExprLoc :: forall e m. (MonadNix e m, MonadIO m)
evalExprLoc :: forall e m. (MonadNix e m, Has e Options, MonadIO m)
=> NExprLoc -> m (NValue m)
evalExprLoc expr = do
opts :: Options <- asks (view hasLens)

58
src/Nix/Frames.hs Normal file
View File

@ -0,0 +1,58 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Nix.Frames (NixLevel(..), Frames, Framed, Frame(..), NixFrame(..),
NixException(..), withFrame, throwError,
module Data.Typeable,
module Control.Exception) where
import Control.Exception hiding (catch, evaluate)
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
class Typeable 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
}
instance Show NixFrame where
show (NixFrame level _) = "Nix frame at level " ++ show level
type Frames = [NixFrame]
type Framed e m = (MonadReader e m, Has e Frames, MonadThrow m)
newtype NixException = NixException Frames
deriving Show
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) :))
throwError :: forall s e m a. (Framed e m, Frame s, MonadThrow m) => s -> m a
throwError err = do
context <- asks (view hasLens)
traceM "Throwing error..."
throwM $ NixException (NixFrame Error (toFrame err):context)

33
src/Nix/Lint.hs
View File

@ -1,15 +1,17 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
@ -29,7 +31,7 @@ import Control.Monad.Reader (MonadReader)
import Control.Monad.ST
import Control.Monad.ST.Unsafe
import Control.Monad.Trans.Reader
import qualified Data.ByteString as BS
-- import qualified Data.ByteString as BS
import Data.Coerce
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
@ -44,9 +46,9 @@ import Nix.Convert
import Nix.Eval (MonadEval(..))
import qualified Nix.Eval as Eval
import Nix.Expr
import Nix.Frames
import Nix.Options
import Nix.Scope
import Nix.Stack
import Nix.Thunk
-- import Nix.Type.Infer
import Nix.Utils
@ -117,8 +119,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, MonadFile m)
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)
@ -208,7 +209,7 @@ merge context = go
-}
-- | unify raises an error if the result is would be 'NMany []'.
unify :: MonadLint e m
unify :: forall e m. MonadLint e m
=> NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify context (Symbolic x) (Symbolic y) = do
x' <- readVar x
@ -224,11 +225,11 @@ unify context (Symbolic x) (Symbolic y) = do
m <- merge context xs ys
if null m
then do
x' <- renderSymbolic (Symbolic x)
y' <- renderSymbolic (Symbolic y)
throwError $ "Cannot unify "
++ show x' ++ " with " ++ show y'
++ " in context: " ++ show context
-- x' <- renderSymbolic (Symbolic x)
-- y' <- renderSymbolic (Symbolic y)
throwError "Cannot unify "
-- ++ show x' ++ " with " ++ show y'
-- ++ " in context: " ++ show context
else do
writeVar x (NMany m)
writeVar y (NMany m)
@ -268,9 +269,9 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
mkSymbolic [TSet (Just (M.fromList (go f l c)))]
where
go f l c =
[ ("file", f)
, ("line", l)
, ("col", c) ]
[ (Text.pack "file", f)
, (Text.pack "line", l)
, (Text.pack "col", c) ]
evalConstant c = mkSymbolic [TConstant [go c]]
where
@ -400,8 +401,8 @@ instance MonadVar (Lint s) where
_ <- modifySTRef x (fst . f)
return res
instance MonadFile (Lint s) where
readFile x = Lint $ ReaderT $ \_ -> unsafeIOToST $ BS.readFile x
-- 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

50
src/Nix/Normal.hs
View File

@ -1,10 +1,14 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Nix.Normal where
@ -15,19 +19,23 @@ import Data.Text (Text)
import qualified Data.Text as Text
import Nix.Atoms
import Nix.Effects
import Nix.Stack
import Nix.Frames
import Nix.Thunk
import Nix.Utils
import Nix.Value
normalFormBy :: (Framed e m, MonadVar m, MonadFile m)
=> (forall r. NThunk m -> (NValue m -> m r) -> m r)
-> Int
-> NValue m
-> m (NValueNF m)
newtype NormalLoop m = NormalLoop (NValue m)
instance Typeable m => Frame (NormalLoop m)
normalFormBy
:: forall e m. (Framed e m, MonadVar m, Typeable m)
=> (forall r. NThunk m -> (NValue m -> m r) -> m r)
-> Int
-> NValue m
-> m (NValueNF m)
normalFormBy k n v = do
traceM $ replicate n ' ' ++ "normalFormBy: " ++ show v
when (n > 2000) $ throwError "<<loop during normalization>>"
when (n > 2000) $ throwError $ NormalLoop v
case v of
NVConstant a -> return $ Fix $ NVConstantF a
NVStr t s -> return $ Fix $ NVStrF t s
@ -44,8 +52,8 @@ normalFormBy k n v = do
NVBuiltin name f -> return $ Fix $ NVBuiltinF name f
_ -> error "Pattern synonyms mask complete matches"
normalForm :: (Framed e m, MonadVar m, MonadFile m,
MonadThunk (NValue m) (NThunk m) m)
normalForm :: (Framed e m, MonadVar m, Typeable m,
MonadThunk (NValue m) (NThunk m) m)
=> NValue m -> m (NValueNF m)
normalForm = normalFormBy force 0
@ -62,20 +70,20 @@ embed (Fix x) = case x of
NVPathF fp -> return $ nvPath fp
NVBuiltinF name f -> return $ nvBuiltin name f
valueText :: forall e m. (Framed e m, MonadFile m, MonadEffects m)
valueText :: forall e m. (Framed e m, MonadEffects m)
=> Bool -> NValueNF m -> m (Text, DList Text)
valueText addPathsToStore = cata phi
where
phi :: NValueF m (m (Text, DList Text)) -> m (Text, DList Text)
phi (NVConstantF a) = pure (atomText a, mempty)
phi (NVStrF t c) = pure (t, c)
phi (NVListF _) = throwError "Cannot coerce a list to a string"
phi (NVSetF s _)
phi (NVConstantF a) = pure (atomText a, mempty)
phi (NVStrF t c) = pure (t, c)
phi v@(NVListF _) = coercionFailed v
phi v@(NVSetF s _)
| Just asString <-
-- TODO: Should this be run through valueText recursively?
M.lookup "__asString" s = asString
| otherwise = throwError "Cannot coerce a set to a string"
phi NVClosureF {} = throwError "Cannot coerce a function to a string"
| otherwise = coercionFailed v
phi v@NVClosureF {} = coercionFailed v
phi (NVPathF originalPath)
| addPathsToStore = do
-- TODO: Capture and use the path of the file being processed as the
@ -83,8 +91,10 @@ valueText addPathsToStore = cata phi
storePath <- addPath originalPath
pure (Text.pack $ unStorePath storePath, mempty)
| otherwise = pure (Text.pack originalPath, mempty)
phi (NVBuiltinF _ _) = throwError "Cannot coerce a function to a string"
phi v@(NVBuiltinF _ _) = coercionFailed v
valueTextNoContext :: (Framed e m, MonadFile m, MonadEffects m)
=> Bool -> NValueNF m -> m Text
coercionFailed v =
throwError $ Coercion (valueType v) TString
valueTextNoContext :: (Framed e m, MonadEffects m) => Bool -> NValueNF m -> m Text
valueTextNoContext addPathsToStore = fmap fst . valueText addPathsToStore

4
src/Nix/Options.hs
View File

@ -71,7 +71,7 @@ data Verbosity
| Informational
| Talkative
| Chatty
| Debug
| DebugInfo
| Vomit
deriving (Eq, Ord, Enum, Bounded, Show)
@ -80,7 +80,7 @@ decodeVerbosity 0 = ErrorsOnly
decodeVerbosity 1 = Informational
decodeVerbosity 2 = Talkative
decodeVerbosity 3 = Chatty
decodeVerbosity 4 = Debug
decodeVerbosity 4 = DebugInfo
decodeVerbosity _ = Vomit
argPair :: Mod OptionFields (Text, Text) -> Parser (Text, Text)

4
src/Nix/Reduce.hs
View File

@ -53,10 +53,10 @@ import Data.Text (Text)
import Nix.Atoms
import Nix.Exec
import Nix.Expr
import Nix.Frames
import Nix.Options (Options, reduceSets, reduceLists)
import Nix.Parser
import Nix.Scope
import Nix.Stack
import Nix.Utils
import System.Directory
import System.FilePath
@ -335,7 +335,7 @@ pruneTree opts = cataM $ \(FlaggedF (b, Compose x)) -> do
Just (Inherit (join m) (map pruneKeyName xs))
reducingEvalExpr
:: (Framed e m, Exception r, MonadCatch m, MonadIO m)
:: (Framed e m, Has e Options, Exception r, MonadCatch m, MonadIO m)
=> (NExprLocF (m a) -> m a)
-> Maybe FilePath
-> NExprLoc

84
src/Nix/Stack.hs → src/Nix/Render.hs
View File

@ -1,44 +1,21 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Nix.Stack where
module Nix.Render where
import Control.Exception
import Control.Monad.Catch
import Control.Monad.Reader
import Data.ByteString (ByteString)
import Data.Fix
import Data.Functor.Compose
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as Set
import Data.Void
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Options
import Nix.Parser.Library
import Nix.Pretty
import Nix.Utils
newtype NixException = NixEvalException String
deriving Show
instance Exception NixException
type Frames = [Either String NExprLoc]
type Framed e m = (MonadReader e m, Has e Frames, Has e Options, MonadThrow m)
withExprContext :: Framed e m => NExprLoc -> m r -> m r
withExprContext expr = local (over hasLens (Right @String expr :))
withStringContext :: Framed e m => String -> m r -> m r
withStringContext str = local (over hasLens (Left @_ @NExprLoc str :))
class Monad m => MonadFile m where
readFile :: FilePath -> m ByteString
@ -48,16 +25,16 @@ posAndMsg beg msg =
FancyError (beg :| [])
(Set.fromList [ErrorFail (show msg) :: ErrorFancy Void])
renderLocation :: (Framed e m, MonadFile m) => SrcSpan -> Doc -> m Doc
renderLocation :: MonadFile m => SrcSpan -> Doc -> m Doc
renderLocation (SrcSpan beg@(SourcePos "<string>" _ _) _) msg =
return $ text $ parseErrorPretty @Char (posAndMsg beg msg)
renderLocation (SrcSpan beg@(SourcePos path _ _) _) msg = do
contents <- Nix.Stack.readFile path
contents <- Nix.Render.readFile path
return $ text $ parseErrorPretty' contents (posAndMsg beg msg)
renderFrame :: (Framed e m, MonadFile m)
=> Either String NExprLoc -> m String
{-
renderFrame :: MonadFile m => Either String NExprLoc -> m String
renderFrame (Left str) = return str
renderFrame (Right expr@(Fix (Compose (Ann ann x)))) = do
opts :: Options <- asks (view hasLens)
@ -71,8 +48,10 @@ renderFrame (Right expr@(Fix (Compose (Ann ann x)))) = do
++ "\n<<<<<<<<"
else "Expression: " ++ rendered
show <$> renderLocation ann (text msg)
-}
throwError :: (Framed e m, MonadFile m, MonadThrow m) => String -> m a
{-
throwError :: (Framed e m r, MonadFile m, MonadThrow m) => String -> m a
throwError str = do
opts :: Options <- asks (view hasLens)
context <- asks (reverse . view hasLens)
@ -94,3 +73,44 @@ throwError str = do
justPos (Left _) = []
justPos (Right (Fix (Compose (Ann (SrcSpan beg _) _)))) = [beg]
-}
{-
renderNormalError :: Eff (NormalError ': r) a
-> Eff r a
renderNormalError = interpret $ \case
NormalLoop _ -> pure $ text "<<loop during normalization>>"
renderThunkError :: Eff (ThunkError ': r) a
-> Eff r a
renderThunkError = interpret $ \case
ThunkLoop Nothing -> pure $ text "<<loop>>"
ThunkLoop (Just n) ->
pure $ text $ "<<loop forcing thunk #" ++ show n ++ ">>"
-}
{-
renderEvalFrame :: NixLevel
-> Eff (EvalFrame ': r) a
-> Eff r a
renderEvalFrame lvl = interpret $ \case
EvalutingExpr x y ->
pure $ text "While evaluating <> describeValue x
<> text " to " <> describeValue y
where
desc | lvl <= Error = "Cannot coerce "
| otherwise = "While coercing "
-}
{-
renderValueFrame :: NixLevel
-> Eff (ValueFrame ': r) a
-> Eff r a
renderValueFrame lvl = interpret $ \case
Coercion x y ->
pure $ text desc <> describeValue x
<> text " to " <> describeValue y
where
desc | lvl <= Error = "Cannot coerce "
| otherwise = "While coercing "
-}

29
src/Nix/Stack.hs-boot
View File

@ -1,29 +0,0 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module Nix.Stack where
import Control.Monad.Catch
import Control.Monad.Reader
import Data.ByteString (ByteString)
import Nix.Expr.Types.Annotated
import Nix.Options
import Nix.Utils
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
type Frames = [Either String NExprLoc]
type Framed e m = (MonadReader e m, Has e Frames, Has e Options, MonadThrow m)
withExprContext :: Framed e m => NExprLoc -> m r -> m r
withStringContext :: Framed e m => String -> m r -> m r
class Monad m => MonadFile m where
readFile :: FilePath -> m ByteString
renderLocation :: (Framed e m, MonadFile m) => SrcSpan -> Doc -> m Doc
renderFrame :: (Framed e m, MonadFile m) => Either String NExprLoc -> m String
throwError :: (Framed e m, MonadFile m, MonadThrow m) => String -> m a

19
src/Nix/Thunk.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
@ -16,7 +15,7 @@
module Nix.Thunk where
import {-# SOURCE #-} Nix.Stack
import Nix.Frames
#if ENABLE_TRACING
import Data.IORef
@ -40,7 +39,7 @@ class Monad m => MonadVar m where
writeVar :: Var m a -> a -> m ()
atomicModifyVar :: Var m a -> (a -> (a, b)) -> m b
class Monad m => MonadThunk v t m | m -> v, v -> m, v -> t where
class Monad m => MonadThunk v t m | v -> m, v -> t, t -> v where
thunk :: m v -> m t
force :: t -> (v -> m r) -> m r
value :: v -> t
@ -53,6 +52,10 @@ data Thunk m v
#endif
(Var m Bool) (Var m (Deferred m v))
newtype ThunkLoop = ThunkLoop (Maybe Int)
instance Frame ThunkLoop
valueRef :: v -> Thunk m v
valueRef = Value
@ -66,8 +69,7 @@ buildThunk action =
#endif
<$> newVar False <*> newVar (Deferred action)
forceThunk :: (Framed e m, MonadFile m, MonadVar m)
=> Thunk m v -> (v -> m r) -> m r
forceThunk :: (Framed e m, MonadVar 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
@ -82,9 +84,9 @@ forceThunk (Thunk active ref) k = do
if nowActive
then
#if ENABLE_TRACING
throwError $ "<<loop forcing thunk #" ++ show n ++ ">>"
throwError $ ThunkLoop (Just n)
#else
throwError "<<loop>>"
throwError $ ThunkLoop Nothing
#endif
else do
#if ENABLE_TRACING
@ -95,8 +97,7 @@ forceThunk (Thunk active ref) k = do
_ <- atomicModifyVar active (False,)
k v
forceEffects :: (Framed e m, MonadFile m, MonadVar m)
=> Thunk m v -> (v -> m r) -> m r
forceEffects :: (Framed e m, MonadVar m) => Thunk m v -> (v -> m a) -> m a
forceEffects (Value ref) k = k ref
#if ENABLE_TRACING
forceEffects (Thunk _ active ref) k = do

107
src/Nix/Value.hs
View File

@ -1,12 +1,14 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
@ -14,6 +16,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-}
@ -23,6 +26,7 @@ module Nix.Value where
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import qualified Data.Aeson as A
import Data.Align
import Data.Fix
import qualified Data.HashMap.Lazy as M
@ -35,12 +39,14 @@ import GHC.Generics
import Nix.Atoms
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Frames
import Nix.Scope
import Nix.Thunk
import Nix.Utils
-- | An 'NValue' is the most reduced form of an 'NExpr' after evaluation
-- is completed.
-- | An 'NValue' is the most reduced form of an 'NExpr' after evaluation is
-- completed. 's' is related to the type of errors that might occur during
-- construction or use of a value.
data NValueF m r
= NVConstantF NAtom
-- | A string has a value and a context, which can be used to record what a
@ -101,8 +107,8 @@ changeProvenance :: Scopes m (NThunk m)
changeProvenance s f l@(NValue _ v) =
NValue (Just (Provenance s (f l) [])) v
provenanceContext :: NExprLocF (Maybe (NValue m))
-> NValue m -> NValue m
provenanceContext :: NExprLocF (Maybe (NValue m)) -> NValue m
-> NValue m
provenanceContext c (NValue p v) =
NValue (fmap (\x -> x { contextExpr = c : contextExpr x }) p) v
@ -143,13 +149,13 @@ nvBuiltinP p name f = NValue (Just p) (NVBuiltinF name f)
instance Show (NValueF m (Fix (NValueF m))) where
showsPrec = flip go where
go (NVConstantF atom) = showsCon1 "NVConstant" atom
go (NVStrF text context) = showsCon2 "NVStr" text (appEndo context [])
go (NVListF list) = showsCon1 "NVList" list
go (NVSetF attrs _) = showsCon1 "NVSet" attrs
go (NVClosureF p _) = showsCon1 "NVClosure" p
go (NVPathF p) = showsCon1 "NVPath" p
go (NVBuiltinF name _) = showsCon1 "NVBuiltin" name
go (NVConstantF atom) = showsCon1 "NVConstant" atom
go (NVStrF txt ctxt) = showsCon2 "NVStr" txt (appEndo ctxt [])
go (NVListF lst) = showsCon1 "NVList" lst
go (NVSetF attrs _) = showsCon1 "NVSet" attrs
go (NVClosureF p _) = showsCon1 "NVClosure" p
go (NVPathF p) = showsCon1 "NVPath" p
go (NVBuiltinF name _) = showsCon1 "NVBuiltin" name
showsCon1 :: Show a => String -> a -> Int -> String -> String
showsCon1 con a d =
@ -164,15 +170,18 @@ instance Show (NValueF m (Fix (NValueF m))) where
. showString " "
. showsPrec 11 b
builtin :: Monad m => String -> (m (NValue m) -> m (NValue m)) -> m (NValue m)
builtin :: Monad m
=> String -> (m (NValue m) -> m (NValue m)) -> m (NValue m)
builtin name f = return $ nvBuiltin name f
builtin2 :: Monad m
=> String -> (m (NValue m) -> m (NValue m) -> m (NValue m)) -> m (NValue m)
=> String -> (m (NValue m) -> m (NValue m) -> m (NValue m))
-> m (NValue m)
builtin2 name f = builtin name (builtin name . f)
builtin3 :: Monad m
=> String -> (m (NValue m) -> m (NValue m) -> m (NValue m) -> m (NValue m))
=> String
-> (m (NValue m) -> m (NValue m) -> m (NValue m) -> m (NValue m))
-> m (NValue m)
builtin3 name f =
builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c
@ -195,7 +204,7 @@ alignEqM
-> f b
-> m Bool
alignEqM eq fa fb = fmap (either (const False) (const True)) $ runExceptT $ do
pairs <- forM (align fa fb) $ \case
pairs <- forM (Data.Align.align fa fb) $ \case
These a b -> return (a, b)
_ -> throwE ()
forM_ pairs $ \(a, b) -> guard =<< lift (eq a b)
@ -227,3 +236,61 @@ valueEq l r = case (l, r) of
_ -> compareAttrs
(NVPath lp, NVPath rp) -> pure $ lp == rp
_ -> pure False
data ValueType
= TInt
| TFloat
| TBool
| TUri
| TNull
| TString
| TList
| TSet
| TClosure
| TPath
| TBuiltin
deriving Show
valueType :: NValueF m r -> ValueType
valueType = \case
NVConstantF (NInt _) -> TInt
NVConstantF (NFloat _) -> TFloat
NVConstantF (NBool _) -> TBool
NVConstantF (NUri _) -> TUri
NVConstantF NNull -> TNull
NVStrF {} -> TString
NVListF {} -> TList
NVSetF {} -> TSet
NVClosureF {} -> TClosure
NVPathF {} -> TPath
NVBuiltinF {} -> TBuiltin
describeValue :: ValueType -> String
describeValue = \case
TInt -> "an integer"
TFloat -> "a float"
TBool -> "a boolean"
TUri -> "a URI"
TNull -> "a null"
TString -> "a string"
TList -> "a list"
TSet -> "an attr set"
TClosure -> "a function"
TPath -> "a path"
TBuiltin -> "a builtin function"
data ForcingThunk = ForcingThunk
data ConcerningValue m = ConcerningValue (NValue m)
data Coercion = Coercion ValueType ValueType
data CoercionToJsonNF m = CoercionToJsonNF (NValueNF m)
data CoercionFromJson = CoercionFromJson A.Value
data ExpectationNF m = ExpectationNF ValueType (NValueNF m)
data Expectation m = Expectation ValueType (NValue m)
instance Frame ForcingThunk
instance Typeable m => Frame (ConcerningValue m)
instance Frame Coercion
instance Typeable m => Frame (CoercionToJsonNF m)
instance Frame CoercionFromJson
instance Typeable m => Frame (ExpectationNF m)
instance Typeable m => Frame (Expectation m)

4
tests/Main.hs
View File

@ -16,9 +16,9 @@ import qualified EvalTests
import qualified Nix
import Nix.Exec
import Nix.Expr.Types
import Nix.Frames
import Nix.Options
import Nix.Parser
import Nix.Stack
import Nix.Value
import qualified NixLanguageTests
import qualified ParserTests
@ -73,7 +73,7 @@ ensureNixpkgsCanParse =
Failure err -> errorWithoutStackTrace $
"Parsing " ++ path ++ " failed: " ++ show err
Success expr -> Exc.catch (k expr) $ \case
NixEvalException msg -> errorWithoutStackTrace msg
NixException msg -> errorWithoutStackTrace "error! NYI!" -- jww (2018-04-24): msg
main :: IO ()
main = do

5
tests/NixLanguageTests.hs
View File

@ -15,11 +15,11 @@ import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import GHC.Exts
import Nix.Frames
import Nix.Lint
import Nix.Options
import Nix.Parser
import Nix.Pretty
import Nix.Stack
import Nix.Utils
import Nix.XML
import qualified Options.Applicative as Opts
@ -106,7 +106,8 @@ assertLangOkXml opts file = do
assertEval :: [FilePath] -> Assertion
assertEval files = catch go $ \case
NixEvalException str -> error $ "Evaluation error: " ++ str
NixException frames -> error $ "Evaluation error: NYI rendering NYI"
-- NixException frames -> error $ "Evaluation error: " ++ str
where
go = case delete ".nix" $ sort $ map takeExtensions files of
[] -> assertLangOkXml defaultOptions name