Factor out citation information to its own data structure
This commit is contained in:
John Wiegley
parent
dc12cdf92e
commit
f397b80a9c
|
|
@ -154,7 +154,7 @@ main = do
|
|||
where
|
||||
go prefix s = do
|
||||
xs <- forM (sortOn fst (M.toList s))
|
||||
$ \(k, nv@(NThunk _ t)) -> case t of
|
||||
$ \(k, nv@(NThunk (NCited _ t))) -> case t of
|
||||
Value v -> pure (k, Just v)
|
||||
Thunk _ _ ref -> do
|
||||
let path = prefix ++ Text.unpack k
|
||||
|
|
|
|||
|
|
@ -148,7 +148,7 @@ typeof args = do
|
|||
val <- case M.lookup line (tmctx st) of
|
||||
Just val -> return val
|
||||
Nothing -> exec False line
|
||||
liftIO $ putStrLn $ describeValue $ valueType (_baseValue val)
|
||||
liftIO $ putStrLn $ describeValue . valueType . _cited . _nValue $ val
|
||||
where
|
||||
line = Text.pack (unwords args)
|
||||
|
||||
|
|
|
|||
|
|
@ -119,15 +119,15 @@ instance MonadNix e m => MonadThunk (NValue m) (NThunk m) m where
|
|||
go _ = []
|
||||
ps = concatMap (go . frame) frames
|
||||
|
||||
fmap (NThunk ps . coerce) . buildThunk $ mv
|
||||
fmap (NThunk . NCited ps . coerce) . buildThunk $ mv
|
||||
else
|
||||
fmap (NThunk [] . coerce) . buildThunk $ mv
|
||||
fmap (NThunk . NCited [] . coerce) . buildThunk $ mv
|
||||
|
||||
-- The ThunkLoop exception is thrown as an exception with MonadThrow,
|
||||
-- which does not capture the current stack frame information to provide
|
||||
-- it in a NixException, so we catch and re-throw it here using
|
||||
-- 'throwError' from Frames.hs.
|
||||
force (NThunk ps t) f = catch go (throwError @ThunkLoop)
|
||||
force (NThunk (NCited ps t)) f = catch go (throwError @ThunkLoop)
|
||||
where
|
||||
go = case ps of
|
||||
[] -> forceThunk t f
|
||||
|
|
@ -135,7 +135,7 @@ instance MonadNix e m => MonadThunk (NValue m) (NThunk m) m where
|
|||
withFrame Info (ForcingExpr scope (wrapExprLoc span e))
|
||||
(forceThunk t f)
|
||||
|
||||
value = NThunk [] . coerce . valueRef
|
||||
value = NThunk . NCited [] . coerce . valueRef
|
||||
|
||||
{-
|
||||
prov :: MonadNix e m
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@ normalFormBy k n v = case v of
|
|||
then return $ Pure val
|
||||
else normalFormBy k (succ n) val
|
||||
|
||||
seen (NThunk _ (Thunk _ b _)) = do
|
||||
seen (NThunk (NCited _ (Thunk _ b _))) = do
|
||||
res <- gets (isJust . find (eqVar @m b))
|
||||
unless res $
|
||||
modify (b:)
|
||||
|
|
@ -90,7 +90,7 @@ normalForm_
|
|||
:: forall e m. (Framed e m, MonadVar m, Typeable m,
|
||||
MonadThunk (NValue m) (NThunk m) m)
|
||||
=> NValue m -> m ()
|
||||
normalForm_ = void . normalForm' (forceEffects . _baseThunk)
|
||||
normalForm_ = void . normalForm' (forceEffects . _cited . _nThunk)
|
||||
|
||||
embed :: forall m. (MonadThunk (NValue m) (NThunk m) m)
|
||||
=> NValueNF m -> m (NValue m)
|
||||
|
|
|
|||
|
|
@ -174,8 +174,8 @@ prettyOriginExpr = withoutParens . go
|
|||
go = exprFNixDoc . annotated . getCompose . fmap render
|
||||
|
||||
render Nothing = simpleExpr $ "_"
|
||||
render (Just (NValue (reverse -> p:_) _)) = go (_originExpr p)
|
||||
render (Just (NValue _ _)) = simpleExpr "?"
|
||||
render (Just (NValue (NCited (reverse -> p:_) _))) = go (_originExpr p)
|
||||
render (Just (NValue (NCited _ _))) = simpleExpr "?"
|
||||
-- simpleExpr $ foldr ((\x y -> vsep [x, y]) . parens . indent 2 . withoutParens
|
||||
-- . go . originExpr)
|
||||
-- mempty (reverse ps)
|
||||
|
|
@ -314,8 +314,10 @@ printNix = iter phi . check
|
|||
removeEffects :: Functor m => NValueF m (NThunk m) -> NValueNF m
|
||||
removeEffects = Free . fmap dethunk
|
||||
where
|
||||
dethunk (NThunk _ (Value v)) = removeEffects (_baseValue v)
|
||||
dethunk (NThunk _ _) = Free $ NVStrF $ principledMakeNixStringWithoutContext "<thunk>"
|
||||
dethunk (NThunk (NCited _ (Value (NValue v)))) =
|
||||
removeEffects (_cited v)
|
||||
dethunk (NThunk (NCited _ _)) =
|
||||
Free $ NVStrF $ principledMakeNixStringWithoutContext "<thunk>"
|
||||
|
||||
removeEffectsM :: MonadVar m => NValueF m (NThunk m) -> m (NValueNF m)
|
||||
removeEffectsM = fmap Free . traverse dethunk
|
||||
|
|
@ -324,12 +326,12 @@ prettyNValueF :: MonadVar m => NValueF m (NThunk m) -> m (Doc ann)
|
|||
prettyNValueF = fmap prettyNValueNF . removeEffectsM
|
||||
|
||||
prettyNValue :: MonadVar m => NValue m -> m (Doc ann)
|
||||
prettyNValue (NValue _ v) = prettyNValueF v
|
||||
prettyNValue (NValue (NCited _ v)) = prettyNValueF v
|
||||
|
||||
prettyNValueProv :: MonadVar m => NValue m -> m (Doc ann)
|
||||
prettyNValueProv = \case
|
||||
NValue [] v -> prettyNValueF v
|
||||
NValue ps v -> do
|
||||
NValue (NCited [] v) -> prettyNValueF v
|
||||
NValue (NCited ps v) -> do
|
||||
v' <- prettyNValueF v
|
||||
pure $ fillSep $
|
||||
[ v'
|
||||
|
|
@ -339,7 +341,7 @@ prettyNValueProv = \case
|
|||
]
|
||||
prettyNThunk :: MonadVar m => NThunk m -> m (Doc ann)
|
||||
prettyNThunk = \case
|
||||
t@(NThunk ps _) -> do
|
||||
t@(NThunk (NCited ps _)) -> do
|
||||
v' <- fmap prettyNValueNF (dethunk t)
|
||||
pure $ fillSep $
|
||||
[ v'
|
||||
|
|
@ -349,15 +351,15 @@ prettyNThunk = \case
|
|||
]
|
||||
dethunk :: MonadVar m => NThunk m -> m (NValueNF m)
|
||||
dethunk = \case
|
||||
NThunk _ (Value v) -> removeEffectsM (_baseValue v)
|
||||
NThunk _ (Thunk _ active ref) -> do
|
||||
NThunk (NCited _ (Value (NValue v))) -> removeEffectsM (_cited v)
|
||||
NThunk (NCited _ (Thunk _ active ref)) -> do
|
||||
nowActive <- atomicModifyVar active (True,)
|
||||
if nowActive
|
||||
then pure $ Free $ NVStrF $ principledMakeNixStringWithoutContext "<thunk>"
|
||||
else do
|
||||
eres <- readVar ref
|
||||
res <- case eres of
|
||||
Computed v -> removeEffectsM (_baseValue v)
|
||||
Computed (NValue v) -> removeEffectsM (_cited v)
|
||||
_ -> pure $ Free $ NVStrF $ principledMakeNixStringWithoutContext "<thunk>"
|
||||
_ <- atomicModifyVar active (False,)
|
||||
return res
|
||||
|
|
|
|||
|
|
@ -104,53 +104,51 @@ data Provenance m = Provenance
|
|||
-- result of the call, but what was called and with what arguments.
|
||||
}
|
||||
|
||||
data NThunk m = NThunk
|
||||
{ _thunkProvenance :: [Provenance m]
|
||||
, _baseThunk :: Thunk m (NValue m)
|
||||
data NCited f m a = NCited
|
||||
{ _provenance :: [Provenance m]
|
||||
, _cited :: f m a
|
||||
}
|
||||
|
||||
data NValue m = NValue
|
||||
{ _valueProvenance :: [Provenance m]
|
||||
, _baseValue :: NValueF m (NThunk m)
|
||||
}
|
||||
newtype NThunk m = NThunk { _nThunk :: NCited Thunk m (NValue m) }
|
||||
newtype NValue m = NValue { _nValue :: NCited NValueF m (NThunk m) }
|
||||
|
||||
addProvenance :: (NValue m -> Provenance m) -> NValue m -> NValue m
|
||||
addProvenance f l@(NValue p v) = NValue (f l : p) v
|
||||
addProvenance f l@(NValue (NCited p v)) = NValue (NCited (f l : p) v)
|
||||
|
||||
pattern NVConstant x <- NValue _ (NVConstantF x)
|
||||
pattern NVConstant x <- NValue (NCited _ (NVConstantF x))
|
||||
|
||||
nvConstant x = NValue [] (NVConstantF x)
|
||||
nvConstantP p x = NValue [p] (NVConstantF x)
|
||||
nvConstant x = NValue (NCited [] (NVConstantF x))
|
||||
nvConstantP p x = NValue (NCited [p] (NVConstantF x))
|
||||
|
||||
pattern NVStr ns <- NValue _ (NVStrF ns)
|
||||
pattern NVStr ns <- NValue (NCited _ (NVStrF ns))
|
||||
|
||||
nvStr ns = NValue [] (NVStrF ns)
|
||||
nvStrP p ns = NValue [p] (NVStrF ns)
|
||||
nvStr ns = NValue (NCited [] (NVStrF ns))
|
||||
nvStrP p ns = NValue (NCited [p] (NVStrF ns))
|
||||
|
||||
pattern NVPath x <- NValue _ (NVPathF x)
|
||||
pattern NVPath x <- NValue (NCited _ (NVPathF x))
|
||||
|
||||
nvPath x = NValue [] (NVPathF x)
|
||||
nvPathP p x = NValue [p] (NVPathF x)
|
||||
nvPath x = NValue (NCited [] (NVPathF x))
|
||||
nvPathP p x = NValue (NCited [p] (NVPathF x))
|
||||
|
||||
pattern NVList l <- NValue _ (NVListF l)
|
||||
pattern NVList l <- NValue (NCited _ (NVListF l))
|
||||
|
||||
nvList l = NValue [] (NVListF l)
|
||||
nvListP p l = NValue [p] (NVListF l)
|
||||
nvList l = NValue (NCited [] (NVListF l))
|
||||
nvListP p l = NValue (NCited [p] (NVListF l))
|
||||
|
||||
pattern NVSet s x <- NValue _ (NVSetF s x)
|
||||
pattern NVSet s x <- NValue (NCited _ (NVSetF s x))
|
||||
|
||||
nvSet s x = NValue [] (NVSetF s x)
|
||||
nvSetP p s x = NValue [p] (NVSetF s x)
|
||||
nvSet s x = NValue (NCited [] (NVSetF s x))
|
||||
nvSetP p s x = NValue (NCited [p] (NVSetF s x))
|
||||
|
||||
pattern NVClosure x f <- NValue _ (NVClosureF x f)
|
||||
pattern NVClosure x f <- NValue (NCited _ (NVClosureF x f))
|
||||
|
||||
nvClosure x f = NValue [] (NVClosureF x f)
|
||||
nvClosureP p x f = NValue [p] (NVClosureF x f)
|
||||
nvClosure x f = NValue (NCited [] (NVClosureF x f))
|
||||
nvClosureP p x f = NValue (NCited [p] (NVClosureF x f))
|
||||
|
||||
pattern NVBuiltin name f <- NValue _ (NVBuiltinF name f)
|
||||
pattern NVBuiltin name f <- NValue (NCited _ (NVBuiltinF name f))
|
||||
|
||||
nvBuiltin name f = NValue [] (NVBuiltinF name f)
|
||||
nvBuiltinP p name f = NValue [p] (NVBuiltinF name f)
|
||||
nvBuiltin name f = NValue (NCited [] (NVBuiltinF name f))
|
||||
nvBuiltinP p name f = NValue (NCited [p] (NVBuiltinF name f))
|
||||
|
||||
instance Show (NValueF m (Fix (NValueF m))) where
|
||||
showsPrec = flip go where
|
||||
|
|
@ -227,7 +225,8 @@ thunkEq :: MonadThunk (NValue m) (NThunk m) m
|
|||
=> NThunk m -> NThunk m -> m Bool
|
||||
thunkEq lt rt = force lt $ \lv -> force rt $ \rv ->
|
||||
let unsafePtrEq = case (lt, rt) of
|
||||
(NThunk _ (Thunk lid _ _), NThunk _ (Thunk rid _ _)) | lid == rid -> return True
|
||||
(NThunk (NCited _ (Thunk lid _ _)),
|
||||
NThunk (NCited _ (Thunk rid _ _))) | lid == rid -> return True
|
||||
_ -> valueEq lv rv
|
||||
in case (lv, rv) of
|
||||
(NVClosure _ _, NVClosure _ _) -> unsafePtrEq
|
||||
|
|
@ -328,11 +327,11 @@ instance Show (NValueF m (NThunk m)) where
|
|||
show = show . describeValue . valueType
|
||||
|
||||
instance Show (NValue m) where
|
||||
show (NValue _ v) = show v
|
||||
show (NValue (NCited _ v)) = show v
|
||||
|
||||
instance Show (NThunk m) where
|
||||
show (NThunk _ (Value v)) = show v
|
||||
show (NThunk _ _) = "<thunk>"
|
||||
show (NThunk (NCited _ (Value v))) = show v
|
||||
show (NThunk (NCited _ _)) = "<thunk>"
|
||||
|
||||
instance Eq1 (NValueF m) where
|
||||
liftEq _ (NVConstantF x) (NVConstantF y) = x == y
|
||||
|
|
@ -370,6 +369,7 @@ instance Typeable m => Exception (ValueFrame m)
|
|||
|
||||
$(makeTraversals ''NValueF)
|
||||
$(makeLenses ''Provenance)
|
||||
$(makeLenses ''NCited)
|
||||
$(makeLenses ''NThunk)
|
||||
$(makeLenses ''NValue)
|
||||
|
||||
|
|
@ -383,4 +383,4 @@ hashAt :: VarName -> Lens' (AttrSet v) (Maybe v)
|
|||
hashAt = flip alterF
|
||||
|
||||
key :: Applicative f => VarName -> LensLike' f (NValue m) (Maybe (NThunk m))
|
||||
key k = baseValue._NVSetF._1.hashAt k
|
||||
key k = nValue.cited._NVSetF._1.hashAt k
|
||||
|
|
|
|||
Loading…
Reference in New Issue