Improve printing of provenance information, add more info
This commit is contained in:
John Wiegley
parent
3cf02e3902
commit
4ff0c483bf
|
|
@ -48,6 +48,7 @@ import Nix.Utils
|
|||
|
||||
class (Show v, Monad m) => MonadEval v m | v -> m where
|
||||
freeVariable :: Text -> m v
|
||||
evaledSym :: Text -> v -> m v
|
||||
|
||||
evalCurPos :: 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
|
||||
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
|
||||
|
||||
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 var) =
|
||||
maybe (freeVariable var) (force ?? pure) =<< lookupVar var
|
||||
lookupVar var >>= maybe (freeVariable var) (force ?? evaledSym var)
|
||||
|
||||
eval (NConstant x) = evalConstant x
|
||||
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 (NAssert cond body) = cond >>= \v -> evalAssert v body
|
||||
eval (NAssert cond body) = cond >>= evalAssert ?? body
|
||||
|
||||
eval e@(NAbs params body) = do
|
||||
-- It is the environment at the definition site, not the call site, that
|
||||
|
|
|
|||
|
|
@ -44,6 +44,7 @@ import Data.List.Split
|
|||
import Data.Maybe (mapMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Void
|
||||
import Nix.Atoms
|
||||
import Nix.Context
|
||||
import Nix.Convert
|
||||
|
|
@ -92,30 +93,38 @@ instance MonadNix e m => MonadEval (NValue m) m where
|
|||
nverr $ "Undefined variable '" ++ Text.unpack var ++ "'"
|
||||
|
||||
evalCurPos = do
|
||||
SrcSpan delta _ <- currentPos
|
||||
toValue delta
|
||||
|
||||
evalConstant c = do
|
||||
scope <- currentScopes
|
||||
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
|
||||
scope <- currentScopes
|
||||
span <- currentPos
|
||||
-- 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
|
||||
scope <- currentScopes
|
||||
span <- currentPos
|
||||
fmap (nvPathP (Provenance scope (NLiteralPath_ span p)))
|
||||
fmap (nvPathP (Provenance scope (NLiteralPath_ span p) Nothing))
|
||||
(makeAbsolutePath p)
|
||||
|
||||
evalEnvPath p = do
|
||||
scope <- currentScopes
|
||||
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
|
||||
scope <- currentScopes
|
||||
|
|
@ -128,31 +137,41 @@ instance MonadNix e m => MonadEval (NValue m) m where
|
|||
execBinaryOp scope span op larg rarg
|
||||
|
||||
evalWith c b = do
|
||||
_scope <- currentScopes @_ @(NThunk m)
|
||||
_span <- currentPos
|
||||
-- jww (2018-04-22): This one needs more work.
|
||||
-- addProvenance scope (\b -> NWith_ span (Just c) (Just (pure b))) <$>
|
||||
evalWithAttrSet c b
|
||||
span <- currentPos
|
||||
-- jww (2018-04-23): What about the arguments to with? All this
|
||||
-- preserves right now is the location.
|
||||
provenanceContext (NWith_ span Nothing Nothing)
|
||||
<$> evalWithAttrSet c b
|
||||
|
||||
evalIf c t f = do
|
||||
scope <- currentScopes
|
||||
span <- currentPos
|
||||
fromValue c >>= \b ->
|
||||
if b
|
||||
then addProvenance scope (\t -> NIf_ span (Just c) (Just t) Nothing) <$> t
|
||||
else addProvenance scope (\f -> NIf_ span (Just c) Nothing (Just f)) <$> f
|
||||
then changeProvenance scope
|
||||
(\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
|
||||
span <- currentPos
|
||||
fromValue c >>= \b ->
|
||||
if 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
|
||||
pure $ nvClosureP (Provenance scope (NAbs_ span (fmap absurd p) Nothing)
|
||||
Nothing) p b
|
||||
|
||||
evalError = throwError
|
||||
|
||||
|
|
@ -168,9 +187,7 @@ callFunc fun arg = case fun of
|
|||
s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do
|
||||
traceM "callFunc:__functor"
|
||||
force f $ (`callFunc` pure s) >=> (`callFunc` arg)
|
||||
x -> arg >>= \arg' ->
|
||||
throwError $ "Attempt to call non-function '" ++ show x
|
||||
++ "' with arg: " ++ show arg'
|
||||
x -> throwError $ "Attempt to call non-function: " ++ show x
|
||||
|
||||
execUnaryOp :: (Framed e m, MonadVar m, MonadFile m)
|
||||
=> Scopes m (NThunk m) -> SrcSpan -> NUnaryOp -> NValue m
|
||||
|
|
@ -193,7 +210,8 @@ execUnaryOp scope span op arg = do
|
|||
throwError $ "argument to unary operator"
|
||||
++ " must evaluate to an atomic type: " ++ show x
|
||||
where
|
||||
unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (Just arg)))
|
||||
unaryOp = pure . nvConstantP
|
||||
(Provenance scope (NUnary_ span op (Just arg)) Nothing)
|
||||
|
||||
execBinaryOp
|
||||
:: 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)
|
||||
where
|
||||
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 ->
|
||||
if l
|
||||
|
|
@ -218,14 +237,16 @@ execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l ->
|
|||
else andOp Nothing False
|
||||
where
|
||||
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
|
||||
-- based on operator first
|
||||
execBinaryOp scope span op lval rarg = do
|
||||
rval <- rarg
|
||||
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
|
||||
case (lval, rval) of
|
||||
(NVConstant lc, NVConstant rc) -> case (op, lc, rc) of
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
|
@ -142,66 +143,76 @@ prettyAtom :: NAtom -> NixDoc
|
|||
prettyAtom atom = simpleExpr $ text $ unpack $ atomText atom
|
||||
|
||||
prettyNix :: NExpr -> Doc
|
||||
prettyNix = withoutParens . cata phi where
|
||||
phi :: NExprF NixDoc -> NixDoc
|
||||
phi (NConstant atom) = prettyAtom atom
|
||||
phi (NStr str) = simpleExpr $ prettyString str
|
||||
phi (NList []) = simpleExpr $ lbracket <> rbracket
|
||||
phi (NList xs) = simpleExpr $ group $
|
||||
nest 2 (vsep $ lbracket : map (wrapParens appOpNonAssoc) xs) <$> rbracket
|
||||
phi (NSet []) = simpleExpr $ lbrace <> rbrace
|
||||
phi (NSet xs) = simpleExpr $ group $
|
||||
nest 2 (vsep $ lbrace : map prettyBind xs) <$> rbrace
|
||||
phi (NRecSet []) = simpleExpr $ recPrefix <> lbrace <> rbrace
|
||||
phi (NRecSet xs) = simpleExpr $ group $
|
||||
nest 2 (vsep $ recPrefix <> lbrace : map prettyBind xs) <$> rbrace
|
||||
phi (NAbs args body) = leastPrecedence $
|
||||
nest 2 ((prettyParams args <> colon) <$> withoutParens body)
|
||||
phi (NBinary NApp fun arg)
|
||||
= NixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp
|
||||
phi (NBinary op r1 r2) = flip NixDoc opInfo $ hsep
|
||||
[ wrapParens (f NAssocLeft) r1
|
||||
, text $ unpack $ operatorName opInfo
|
||||
, wrapParens (f NAssocRight) r2
|
||||
]
|
||||
where
|
||||
opInfo = getBinaryOperator op
|
||||
f x
|
||||
| associativity opInfo /= x = opInfo { associativity = NAssocNone }
|
||||
| otherwise = opInfo
|
||||
phi (NUnary op r1) =
|
||||
NixDoc (text (unpack (operatorName opInfo)) <> wrapParens opInfo r1) opInfo
|
||||
where opInfo = getUnaryOperator op
|
||||
phi (NSelect r attr o) =
|
||||
prettyNix = withoutParens . cata exprFNixDoc
|
||||
|
||||
prettyOriginExpr :: NExprLocF (Maybe (NValue m)) -> Doc
|
||||
prettyOriginExpr = withoutParens . go
|
||||
where
|
||||
go = exprFNixDoc . annotated . getCompose . fmap render
|
||||
|
||||
render Nothing = simpleExpr $ text "_"
|
||||
render (Just (NValue Nothing _)) = simpleExpr $ text "?"
|
||||
render (Just (NValue (Just expr) _)) = go (originExpr expr)
|
||||
|
||||
exprFNixDoc :: NExprF NixDoc -> NixDoc
|
||||
exprFNixDoc = \case
|
||||
NConstant atom -> prettyAtom atom
|
||||
NStr str -> simpleExpr $ prettyString str
|
||||
NList [] -> simpleExpr $ lbracket <> rbracket
|
||||
NList xs -> simpleExpr $ group $
|
||||
nest 2 (vsep $ lbracket : map (wrapParens appOpNonAssoc) xs) <$> rbracket
|
||||
NSet [] -> simpleExpr $ lbrace <> rbrace
|
||||
NSet xs -> simpleExpr $ group $
|
||||
nest 2 (vsep $ lbrace : map prettyBind xs) <$> rbrace
|
||||
NRecSet [] -> simpleExpr $ recPrefix <> lbrace <> rbrace
|
||||
NRecSet xs -> simpleExpr $ group $
|
||||
nest 2 (vsep $ recPrefix <> lbrace : map prettyBind xs) <$> rbrace
|
||||
NAbs args body -> leastPrecedence $
|
||||
nest 2 ((prettyParams args <> colon) <$> withoutParens body)
|
||||
NBinary NApp fun arg ->
|
||||
NixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp
|
||||
NBinary op r1 r2 -> flip NixDoc opInfo $ hsep
|
||||
[ wrapParens (f NAssocLeft) r1
|
||||
, 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) $
|
||||
wrapParens selectOp r <> dot <> prettySelector attr <> ordoc
|
||||
where ordoc = maybe empty (((space <> text "or") <+>) . wrapParens selectOp) o
|
||||
phi (NHasAttr r attr)
|
||||
= NixDoc (wrapParens hasAttrOp r <+> text "?" <+> prettySelector attr) hasAttrOp
|
||||
phi (NEnvPath p) = simpleExpr $ text ("<" ++ p ++ ">")
|
||||
phi (NLiteralPath p) = simpleExpr $ text $ case p of
|
||||
"./" -> "./."
|
||||
"../" -> "../."
|
||||
".." -> "../."
|
||||
txt | "/" `isPrefixOf` txt -> txt
|
||||
| "~/" `isPrefixOf` txt -> txt
|
||||
| "./" `isPrefixOf` txt -> txt
|
||||
| "../" `isPrefixOf` txt -> txt
|
||||
| otherwise -> "./" ++ txt
|
||||
phi (NSym name) = simpleExpr $ text (unpack name)
|
||||
phi (NLet binds body) = leastPrecedence $ group $ text "let" <$> indent 2 (
|
||||
where ordoc = maybe empty (((space <> text "or") <+>) . wrapParens selectOp) o
|
||||
NHasAttr r attr ->
|
||||
NixDoc (wrapParens hasAttrOp r <+> text "?" <+> prettySelector attr) hasAttrOp
|
||||
NEnvPath p -> simpleExpr $ text ("<" ++ p ++ ">")
|
||||
NLiteralPath p -> simpleExpr $ text $ case p of
|
||||
"./" -> "./."
|
||||
"../" -> "../."
|
||||
".." -> "../."
|
||||
txt | "/" `isPrefixOf` txt -> txt
|
||||
| "~/" `isPrefixOf` txt -> txt
|
||||
| "./" `isPrefixOf` txt -> txt
|
||||
| "../" `isPrefixOf` txt -> txt
|
||||
| otherwise -> "./" ++ txt
|
||||
NSym name -> simpleExpr $ text (unpack name)
|
||||
NLet binds body -> leastPrecedence $ group $ text "let" <$> indent 2 (
|
||||
vsep (map prettyBind binds)) <$> text "in" <+> withoutParens body
|
||||
phi (NIf cond trueBody falseBody) = leastPrecedence $
|
||||
group $ nest 2 $ (text "if" <+> withoutParens cond) <$>
|
||||
( align (text "then" <+> withoutParens trueBody)
|
||||
<$> align (text "else" <+> withoutParens falseBody)
|
||||
)
|
||||
phi (NWith scope body) = leastPrecedence $
|
||||
text "with" <+> withoutParens scope <> semi <$> align (withoutParens body)
|
||||
phi (NAssert cond body) = leastPrecedence $
|
||||
text "assert" <+> withoutParens cond <> semi <$> align (withoutParens body)
|
||||
|
||||
recPrefix = text "rec" <> space
|
||||
NIf cond trueBody falseBody -> leastPrecedence $
|
||||
group $ nest 2 $ (text "if" <+> withoutParens cond) <$>
|
||||
( align (text "then" <+> withoutParens trueBody)
|
||||
<$> align (text "else" <+> withoutParens falseBody)
|
||||
)
|
||||
NWith scope body -> leastPrecedence $
|
||||
text "with" <+> withoutParens scope <> semi <$> align (withoutParens body)
|
||||
NAssert cond body -> leastPrecedence $
|
||||
text "assert" <+> withoutParens cond <> semi <$> align (withoutParens body)
|
||||
where
|
||||
recPrefix = text "rec" <> space
|
||||
|
||||
prettyNixValue :: Functor m => NValueNF m -> Doc
|
||||
prettyNixValue = prettyNix . valueToExpr
|
||||
|
|
@ -237,15 +248,27 @@ removeEffects = Fix . fmap dethunk . baseValue
|
|||
dethunk (NThunk (Value v)) = removeEffects v
|
||||
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
|
||||
show = show . prettyNixValue . removeEffects . NValue Nothing
|
||||
|
||||
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
|
||||
show (NThunk (Value v)) = show v
|
||||
show (NThunk _) = "<thunk>"
|
||||
|
||||
instance Functor m => Show (Provenance m) where
|
||||
show (Provenance _ (Compose (Ann _ expr))) = show expr
|
||||
|
|
|
|||
|
|
@ -81,6 +81,11 @@ type ValueSet m = AttrSet (NThunk m)
|
|||
data Provenance m = Provenance
|
||||
{ lexicalScope :: Scopes m (NThunk 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
|
||||
|
|
@ -90,10 +95,16 @@ data NValue m = NValue
|
|||
, baseValue :: NValueF m (NThunk m)
|
||||
}
|
||||
|
||||
addProvenance :: Scopes m (NThunk m)
|
||||
-> (NValue m -> NExprLocF (Maybe (NValue m)))
|
||||
-> NValue m -> NValue m
|
||||
addProvenance s f l@(NValue _ v) = NValue (Just (Provenance s (f l))) v
|
||||
changeProvenance :: Scopes m (NThunk m)
|
||||
-> (NValue m -> NExprLocF (Maybe (NValue m)))
|
||||
-> NValue m -> NValue m
|
||||
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)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue