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

Improve printing of provenance information, add more info

Browse source
This commit is contained in:
John Wiegley 2018-04-23 10:06:49 -07:00
parent 3cf02e3902
commit 4ff0c483bf
4 changed files with 170 additions and 98 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
src/Nix/Eval.hs
View file

@ -48,6 +48,7 @@ import Nix.Utils
class (Show v, Monad m) => MonadEval v m | v -> m where class (Show v, Monad m) => MonadEval v m | v -> m where
freeVariable :: Text -> m v freeVariable :: Text -> m v
evaledSym :: Text -> v -> m v
evalCurPos :: m v evalCurPos :: m v
evalConstant :: NAtom -> m v evalConstant :: NAtom -> m v
@ -64,6 +65,22 @@ class (Show v, Monad m) => MonadEval v m | v -> m where
evalApp :: v -> m v -> m v evalApp :: v -> m v -> m v
evalAbs :: Params Void -> (m v -> m v) -> m v evalAbs :: Params Void -> (m v -> m v) -> m v
{-
evalSelect :: v -> NonEmpty Text -> Maybe (m v) -> m v
evalHasAttr :: v -> NonEmpty Text -> m v
-- | This and the following methods are intended to allow things like
-- adding provenance information.
evalListElem :: [m v] -> Int -> m v -> m v
evalList :: [t] -> m v
evalSetElem :: AttrSet (m v) -> Text -> m v -> m v
evalSet :: AttrSet t -> AttrSet SourcePos -> m v
evalRecSetElem :: AttrSet (m v) -> Text -> m v -> m v
evalRecSet :: AttrSet t -> AttrSet SourcePos -> m v
evalLetElem :: Text -> m v -> m v
evalLet :: m v -> m v
-}
evalError :: String -> m a evalError :: String -> m a
type MonadNixEval e v t m = type MonadNixEval e v t m =
@ -87,7 +104,7 @@ eval :: forall e v t m. MonadNixEval e v t m => NExprF (m v) -> m v
eval (NSym "__curPos") = evalCurPos eval (NSym "__curPos") = evalCurPos
eval (NSym var) = eval (NSym var) =
maybe (freeVariable var) (force ?? pure) =<< lookupVar var lookupVar var >>= maybe (freeVariable var) (force ?? evaledSym var)
eval (NConstant x) = evalConstant x eval (NConstant x) = evalConstant x
eval (NStr str) = uncurry evalString =<< assembleString str eval (NStr str) = uncurry evalString =<< assembleString str
@ -144,7 +161,7 @@ eval (NIf cond t f) = cond >>= \v -> evalIf v t f
eval (NWith scope body) = evalWith scope body eval (NWith scope body) = evalWith scope body
eval (NAssert cond body) = cond >>= \v -> evalAssert v body eval (NAssert cond body) = cond >>= evalAssert ?? body
eval e@(NAbs params body) = do eval e@(NAbs params body) = do
-- It is the environment at the definition site, not the call site, that -- It is the environment at the definition site, not the call site, that

83
src/Nix/Exec.hs
View file

@ -44,6 +44,7 @@ import Data.List.Split
import Data.Maybe (mapMaybe) import Data.Maybe (mapMaybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Void
import Nix.Atoms import Nix.Atoms
import Nix.Context import Nix.Context
import Nix.Convert import Nix.Convert
@ -92,30 +93,38 @@ instance MonadNix e m => MonadEval (NValue m) m where
nverr $ "Undefined variable '" ++ Text.unpack var ++ "'" nverr $ "Undefined variable '" ++ Text.unpack var ++ "'"
evalCurPos = do evalCurPos = do
SrcSpan delta _ <- currentPos
toValue delta
evalConstant c = do
scope <- currentScopes scope <- currentScopes
span <- currentPos span <- currentPos
pure $ nvConstantP (Provenance scope (NConstant_ span c)) c SrcSpan delta _ <- currentPos
changeProvenance scope (\_ -> NSym_ span "__curPos") <$> toValue delta
evaledSym name val = do
span <- currentPos
pure $ provenanceContext (NSym_ span name) val
evalConstant c = do
scope <- currentScopes
span <- currentPos
pure $ nvConstantP (Provenance scope (NConstant_ span c) Nothing) c
evalString s d = do evalString s d = do
scope <- currentScopes scope <- currentScopes
span <- currentPos span <- currentPos
-- jww (2018-04-22): Determine full provenance for the string? -- jww (2018-04-22): Determine full provenance for the string?
pure $ nvStrP (Provenance scope (NStr_ span (DoubleQuoted [Plain s]))) s d pure $ nvStrP (Provenance scope (NStr_ span (DoubleQuoted [Plain s]))
Nothing) s d
evalLiteralPath p = do evalLiteralPath p = do
scope <- currentScopes scope <- currentScopes
span <- currentPos span <- currentPos
fmap (nvPathP (Provenance scope (NLiteralPath_ span p))) fmap (nvPathP (Provenance scope (NLiteralPath_ span p) Nothing))
(makeAbsolutePath p) (makeAbsolutePath p)
evalEnvPath p = do evalEnvPath p = do
scope <- currentScopes scope <- currentScopes
span <- currentPos span <- currentPos
fmap (nvPathP (Provenance scope (NEnvPath_ span p))) (findEnvPath p) fmap (nvPathP (Provenance scope (NEnvPath_ span p) Nothing))
(findEnvPath p)
evalUnary op arg = do evalUnary op arg = do
scope <- currentScopes scope <- currentScopes
@ -128,31 +137,41 @@ instance MonadNix e m => MonadEval (NValue m) m where
execBinaryOp scope span op larg rarg execBinaryOp scope span op larg rarg
evalWith c b = do evalWith c b = do
_scope <- currentScopes @_ @(NThunk m) span <- currentPos
_span <- currentPos -- jww (2018-04-23): What about the arguments to with? All this
-- jww (2018-04-22): This one needs more work. -- preserves right now is the location.
-- addProvenance scope (\b -> NWith_ span (Just c) (Just (pure b))) <$> provenanceContext (NWith_ span Nothing Nothing)
evalWithAttrSet c b <$> evalWithAttrSet c b
evalIf c t f = do evalIf c t f = do
scope <- currentScopes scope <- currentScopes
span <- currentPos span <- currentPos
fromValue c >>= \b -> fromValue c >>= \b ->
if b if b
then addProvenance scope (\t -> NIf_ span (Just c) (Just t) Nothing) <$> t then changeProvenance scope
else addProvenance scope (\f -> NIf_ span (Just c) Nothing (Just f)) <$> f (\t -> NIf_ span (Just c) (Just t) Nothing) <$> t
else changeProvenance scope
(\f -> NIf_ span (Just c) Nothing (Just f)) <$> f
evalAssert c body = do evalAssert c body = fromValue c >>= \b ->
if b
then do
scope <- currentScopes
span <- currentPos
changeProvenance scope
(\b -> NAssert_ span (Just c) (Just b)) <$> body
else nverr $ "assertion failed: " ++ show c
evalApp f x = do
span <- currentPos
provenanceContext (NBinary_ span NApp (Just f) Nothing)
<$> callFunc f x
evalAbs p b = do
scope <- currentScopes scope <- currentScopes
span <- currentPos span <- currentPos
fromValue c >>= \b -> pure $ nvClosureP (Provenance scope (NAbs_ span (fmap absurd p) Nothing)
if b Nothing) p b
then addProvenance scope (\b -> NAssert_ span (Just c) (Just b)) <$> body
else nverr $ "assertion failed, value provenance: "
++ show (provenance c)
evalApp = callFunc
evalAbs = (pure .) . nvClosure -- jww (2018-04-22): NYI
evalError = throwError evalError = throwError
@ -168,9 +187,7 @@ callFunc fun arg = case fun of
s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do
traceM "callFunc:__functor" traceM "callFunc:__functor"
force f $ (`callFunc` pure s) >=> (`callFunc` arg) force f $ (`callFunc` pure s) >=> (`callFunc` arg)
x -> arg >>= \arg' -> x -> throwError $ "Attempt to call non-function: " ++ show x
throwError $ "Attempt to call non-function '" ++ show x
++ "' with arg: " ++ show arg'
execUnaryOp :: (Framed e m, MonadVar m, MonadFile m) execUnaryOp :: (Framed e m, MonadVar m, MonadFile m)
=> Scopes m (NThunk m) -> SrcSpan -> NUnaryOp -> NValue m => Scopes m (NThunk m) -> SrcSpan -> NUnaryOp -> NValue m
@ -193,7 +210,8 @@ execUnaryOp scope span op arg = do
throwError $ "argument to unary operator" throwError $ "argument to unary operator"
++ " must evaluate to an atomic type: " ++ show x ++ " must evaluate to an atomic type: " ++ show x
where where
unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (Just arg))) unaryOp = pure . nvConstantP
(Provenance scope (NUnary_ span op (Just arg)) Nothing)
execBinaryOp execBinaryOp
:: forall e m. (MonadNix e m, MonadEval (NValue m) m) :: forall e m. (MonadNix e m, MonadEval (NValue m) m)
@ -210,7 +228,8 @@ execBinaryOp scope span NOr larg rarg = fromNix larg >>= \l ->
else rarg >>= \rval -> fromNix @Bool rval >>= orOp (Just rval) else rarg >>= \rval -> fromNix @Bool rval >>= orOp (Just rval)
where where
orOp r b = pure $ orOp r b = pure $
nvConstantP (Provenance scope (NBinary_ span NOr (Just larg) r)) (NBool b) nvConstantP (Provenance scope (NBinary_ span NOr (Just larg) r) Nothing)
(NBool b)
execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l -> execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l ->
if l if l
@ -218,14 +237,16 @@ execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l ->
else andOp Nothing False else andOp Nothing False
where where
andOp r b = pure $ andOp r b = pure $
nvConstantP (Provenance scope (NBinary_ span NAnd (Just larg) r)) (NBool b) nvConstantP (Provenance scope (NBinary_ span NAnd (Just larg) r) Nothing)
(NBool b)
-- jww (2018-04-08): Refactor so that eval (NBinary ..) *always* dispatches -- jww (2018-04-08): Refactor so that eval (NBinary ..) *always* dispatches
-- based on operator first -- based on operator first
execBinaryOp scope span op lval rarg = do execBinaryOp scope span op lval rarg = do
rval <- rarg rval <- rarg
let bin :: (Provenance m -> a) -> a let bin :: (Provenance m -> a) -> a
bin f = f (Provenance scope (NBinary_ span op (Just lval) (Just rval))) bin f = f (Provenance scope (NBinary_ span op (Just lval) (Just rval))
Nothing)
toBool = pure . bin nvConstantP . NBool toBool = pure . bin nvConstantP . NBool
case (lval, rval) of case (lval, rval) of
(NVConstant lc, NVConstant rc) -> case (op, lc, rc) of (NVConstant lc, NVConstant rc) -> case (op, lc, rc) of

145
src/Nix/Pretty.hs
View file

@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
@ -142,66 +143,76 @@ prettyAtom :: NAtom -> NixDoc
prettyAtom atom = simpleExpr $ text $ unpack $ atomText atom prettyAtom atom = simpleExpr $ text $ unpack $ atomText atom
prettyNix :: NExpr -> Doc prettyNix :: NExpr -> Doc
prettyNix = withoutParens . cata phi where prettyNix = withoutParens . cata exprFNixDoc
phi :: NExprF NixDoc -> NixDoc
phi (NConstant atom) = prettyAtom atom prettyOriginExpr :: NExprLocF (Maybe (NValue m)) -> Doc
phi (NStr str) = simpleExpr $ prettyString str prettyOriginExpr = withoutParens . go
phi (NList []) = simpleExpr $ lbracket <> rbracket where
phi (NList xs) = simpleExpr $ group $ go = exprFNixDoc . annotated . getCompose . fmap render
nest 2 (vsep $ lbracket : map (wrapParens appOpNonAssoc) xs) <$> rbracket
phi (NSet []) = simpleExpr $ lbrace <> rbrace render Nothing = simpleExpr $ text "_"
phi (NSet xs) = simpleExpr $ group $ render (Just (NValue Nothing _)) = simpleExpr $ text "?"
nest 2 (vsep $ lbrace : map prettyBind xs) <$> rbrace render (Just (NValue (Just expr) _)) = go (originExpr expr)
phi (NRecSet []) = simpleExpr $ recPrefix <> lbrace <> rbrace
phi (NRecSet xs) = simpleExpr $ group $ exprFNixDoc :: NExprF NixDoc -> NixDoc
nest 2 (vsep $ recPrefix <> lbrace : map prettyBind xs) <$> rbrace exprFNixDoc = \case
phi (NAbs args body) = leastPrecedence $ NConstant atom -> prettyAtom atom
nest 2 ((prettyParams args <> colon) <$> withoutParens body) NStr str -> simpleExpr $ prettyString str
phi (NBinary NApp fun arg) NList [] -> simpleExpr $ lbracket <> rbracket
= NixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp NList xs -> simpleExpr $ group $
phi (NBinary op r1 r2) = flip NixDoc opInfo $ hsep nest 2 (vsep $ lbracket : map (wrapParens appOpNonAssoc) xs) <$> rbracket
[ wrapParens (f NAssocLeft) r1 NSet [] -> simpleExpr $ lbrace <> rbrace
, text $ unpack $ operatorName opInfo NSet xs -> simpleExpr $ group $
, wrapParens (f NAssocRight) r2 nest 2 (vsep $ lbrace : map prettyBind xs) <$> rbrace
] NRecSet [] -> simpleExpr $ recPrefix <> lbrace <> rbrace
where NRecSet xs -> simpleExpr $ group $
opInfo = getBinaryOperator op nest 2 (vsep $ recPrefix <> lbrace : map prettyBind xs) <$> rbrace
f x NAbs args body -> leastPrecedence $
| associativity opInfo /= x = opInfo { associativity = NAssocNone } nest 2 ((prettyParams args <> colon) <$> withoutParens body)
| otherwise = opInfo NBinary NApp fun arg ->
phi (NUnary op r1) = NixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp
NixDoc (text (unpack (operatorName opInfo)) <> wrapParens opInfo r1) opInfo NBinary op r1 r2 -> flip NixDoc opInfo $ hsep
where opInfo = getUnaryOperator op [ wrapParens (f NAssocLeft) r1
phi (NSelect r attr o) = , text $ unpack $ operatorName opInfo
, wrapParens (f NAssocRight) r2
]
where
opInfo = getBinaryOperator op
f x | associativity opInfo /= x = opInfo { associativity = NAssocNone }
| otherwise = opInfo
NUnary op r1 ->
NixDoc (text (unpack (operatorName opInfo)) <> wrapParens opInfo r1) opInfo
where opInfo = getUnaryOperator op
NSelect r attr o ->
(if isJust o then leastPrecedence else flip NixDoc selectOp) $ (if isJust o then leastPrecedence else flip NixDoc selectOp) $
wrapParens selectOp r <> dot <> prettySelector attr <> ordoc wrapParens selectOp r <> dot <> prettySelector attr <> ordoc
where ordoc = maybe empty (((space <> text "or") <+>) . wrapParens selectOp) o where ordoc = maybe empty (((space <> text "or") <+>) . wrapParens selectOp) o
phi (NHasAttr r attr) NHasAttr r attr ->
= NixDoc (wrapParens hasAttrOp r <+> text "?" <+> prettySelector attr) hasAttrOp NixDoc (wrapParens hasAttrOp r <+> text "?" <+> prettySelector attr) hasAttrOp
phi (NEnvPath p) = simpleExpr $ text ("<" ++ p ++ ">") NEnvPath p -> simpleExpr $ text ("<" ++ p ++ ">")
phi (NLiteralPath p) = simpleExpr $ text $ case p of NLiteralPath p -> simpleExpr $ text $ case p of
"./" -> "./." "./" -> "./."
"../" -> "../." "../" -> "../."
".." -> "../." ".." -> "../."
txt | "/" `isPrefixOf` txt -> txt txt | "/" `isPrefixOf` txt -> txt
| "~/" `isPrefixOf` txt -> txt | "~/" `isPrefixOf` txt -> txt
| "./" `isPrefixOf` txt -> txt | "./" `isPrefixOf` txt -> txt
| "../" `isPrefixOf` txt -> txt | "../" `isPrefixOf` txt -> txt
| otherwise -> "./" ++ txt | otherwise -> "./" ++ txt
phi (NSym name) = simpleExpr $ text (unpack name) NSym name -> simpleExpr $ text (unpack name)
phi (NLet binds body) = leastPrecedence $ group $ text "let" <$> indent 2 ( NLet binds body -> leastPrecedence $ group $ text "let" <$> indent 2 (
vsep (map prettyBind binds)) <$> text "in" <+> withoutParens body vsep (map prettyBind binds)) <$> text "in" <+> withoutParens body
phi (NIf cond trueBody falseBody) = leastPrecedence $ NIf cond trueBody falseBody -> leastPrecedence $
group $ nest 2 $ (text "if" <+> withoutParens cond) <$> group $ nest 2 $ (text "if" <+> withoutParens cond) <$>
( align (text "then" <+> withoutParens trueBody) ( align (text "then" <+> withoutParens trueBody)
<$> align (text "else" <+> withoutParens falseBody) <$> align (text "else" <+> withoutParens falseBody)
) )
phi (NWith scope body) = leastPrecedence $ NWith scope body -> leastPrecedence $
text "with" <+> withoutParens scope <> semi <$> align (withoutParens body) text "with" <+> withoutParens scope <> semi <$> align (withoutParens body)
phi (NAssert cond body) = leastPrecedence $ NAssert cond body -> leastPrecedence $
text "assert" <+> withoutParens cond <> semi <$> align (withoutParens body) text "assert" <+> withoutParens cond <> semi <$> align (withoutParens body)
where
recPrefix = text "rec" <> space recPrefix = text "rec" <> space
prettyNixValue :: Functor m => NValueNF m -> Doc prettyNixValue :: Functor m => NValueNF m -> Doc
prettyNixValue = prettyNix . valueToExpr prettyNixValue = prettyNix . valueToExpr
@ -237,15 +248,27 @@ removeEffects = Fix . fmap dethunk . baseValue
dethunk (NThunk (Value v)) = removeEffects v dethunk (NThunk (Value v)) = removeEffects v
dethunk (NThunk _) = Fix $ NVStrF "<thunk>" mempty dethunk (NThunk _) = Fix $ NVStrF "<thunk>" mempty
removeEffectsIO :: MonadVar m => NValue m -> m (NValueNF m)
removeEffectsIO = fmap Fix . traverse dethunk . baseValue
where
dethunk (NThunk (Value v)) = removeEffectsIO v
dethunk (NThunk (Thunk
#if ENABLE_TRACING
_
#endif
_ t)) = readVar t >>= \case
Computed v -> removeEffectsIO v
_ -> pure $ Fix $ NVStrF "<thunk>" mempty
instance Functor m => Show (NValueF m (NThunk m)) where instance Functor m => Show (NValueF m (NThunk m)) where
show = show . prettyNixValue . removeEffects . NValue Nothing show = show . prettyNixValue . removeEffects . NValue Nothing
instance Functor m => Show (NValue m) where instance Functor m => Show (NValue m) where
show (NValue p v) = "(" ++ show v ++ " from " ++ show p ++ ")" show (NValue Nothing v) = show v
show (NValue (Just p) v) =
-- jww (2018-04-23): Need to display the contextExpr as well.
show v ++ " (from: " ++ show (prettyOriginExpr (originExpr p)) ++ ")"
instance Functor m => Show (NThunk m) where instance Functor m => Show (NThunk m) where
show (NThunk (Value v)) = show v show (NThunk (Value v)) = show v
show (NThunk _) = "<thunk>" show (NThunk _) = "<thunk>"
instance Functor m => Show (Provenance m) where
show (Provenance _ (Compose (Ann _ expr))) = show expr

19
src/Nix/Value.hs
View file

@ -81,6 +81,11 @@ type ValueSet m = AttrSet (NThunk m)
data Provenance m = Provenance data Provenance m = Provenance
{ lexicalScope :: Scopes m (NThunk m) { lexicalScope :: Scopes m (NThunk m)
, originExpr :: NExprLocF (Maybe (NValue m)) , originExpr :: NExprLocF (Maybe (NValue m))
, contextExpr :: Maybe (NExprLocF (Maybe (NValue m)))
-- ^ When calling the function x: x + 2 with argument x = 3, the
-- 'originExpr' for the resulting value will be 3 + 2, while the
-- 'contextExpr' will be @(x: x + 2) 3@, preserving not only the
-- result of the call, but what was called and with what arguments.
} }
-- jww (2018-04-22): Tracking value provenance may need to be a compile-time -- jww (2018-04-22): Tracking value provenance may need to be a compile-time
@ -90,10 +95,16 @@ data NValue m = NValue
, baseValue :: NValueF m (NThunk m) , baseValue :: NValueF m (NThunk m)
} }
addProvenance :: Scopes m (NThunk m) changeProvenance :: Scopes m (NThunk m)
-> (NValue m -> NExprLocF (Maybe (NValue m))) -> (NValue m -> NExprLocF (Maybe (NValue m)))
-> NValue m -> NValue m -> NValue m -> NValue m
addProvenance s f l@(NValue _ v) = NValue (Just (Provenance s (f l))) v changeProvenance s f l@(NValue _ v) =
NValue (Just (Provenance s (f l) Nothing)) v
provenanceContext :: NExprLocF (Maybe (NValue m))
-> NValue m -> NValue m
provenanceContext c (NValue p v) =
NValue (fmap (\x -> x { contextExpr = Just c }) p) v
pattern NVConstant x <- NValue _ (NVConstantF x) pattern NVConstant x <- NValue _ (NVConstantF x)