195 lines
7 KiB
Haskell
195 lines
7 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
{-# LANGUAGE ConstraintKinds #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
module Nix.Render.Frame where
|
|
|
|
import Control.Monad.Reader
|
|
import Data.Fix
|
|
import Data.Typeable
|
|
import Data.Text.Prettyprint.Doc
|
|
import Nix.Eval
|
|
import Nix.Exec
|
|
import Nix.Expr
|
|
import Nix.Frames
|
|
import Nix.Normal
|
|
import Nix.Options
|
|
import Nix.Pretty
|
|
import Nix.Render
|
|
import Nix.Thunk
|
|
import Nix.Utils
|
|
import Nix.Value
|
|
import Text.Megaparsec.Pos
|
|
#ifdef MIN_VERSION_pretty_show
|
|
import qualified Text.Show.Pretty as PS
|
|
#endif
|
|
|
|
renderFrames
|
|
:: forall v e m ann
|
|
. ( MonadReader e m, Has e Options
|
|
, MonadVar m, MonadFile m, Typeable m, Typeable v)
|
|
=> Frames -> m (Doc ann)
|
|
renderFrames [] = pure mempty
|
|
renderFrames (x:xs) = do
|
|
opts :: Options <- asks (view hasLens)
|
|
frames <-
|
|
if | verbose opts <= ErrorsOnly ->
|
|
renderFrame @v x
|
|
| verbose opts <= Informational -> do
|
|
f <- renderFrame @v x
|
|
pure $ concatMap go (reverse xs) ++ f
|
|
| otherwise ->
|
|
concat <$> mapM (renderFrame @v) (reverse (x:xs))
|
|
pure $ case frames of
|
|
[] -> mempty
|
|
_ -> vsep frames
|
|
where
|
|
go :: NixFrame -> [Doc ann]
|
|
go f = case framePos @v @m f of
|
|
Just pos ->
|
|
["While evaluating at "
|
|
<> pretty (sourcePosPretty pos)
|
|
<> colon]
|
|
Nothing -> []
|
|
|
|
framePos :: forall v (m :: * -> *). (Typeable m, Typeable v) => NixFrame
|
|
-> Maybe SourcePos
|
|
framePos (NixFrame _ f)
|
|
| Just (e :: EvalFrame m v) <- fromException f = case e of
|
|
EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) ->
|
|
Just beg
|
|
_ -> Nothing
|
|
| otherwise = Nothing
|
|
|
|
renderFrame :: forall v e m ann.
|
|
(MonadReader e m, Has e Options, MonadVar m,
|
|
MonadFile m, Typeable m, Typeable v)
|
|
=> NixFrame -> m [Doc ann]
|
|
renderFrame (NixFrame level f)
|
|
| Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e
|
|
| Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e
|
|
| Just (e :: ValueFrame m) <- fromException f = renderValueFrame level e
|
|
| Just (e :: NormalLoop m) <- fromException f = renderNormalLoop level e
|
|
| Just (e :: ExecFrame m) <- fromException f = renderExecFrame level e
|
|
| Just (e :: ErrorCall) <- fromException f = pure [pretty (show e)]
|
|
| otherwise = error $ "Unrecognized frame: " ++ show f
|
|
|
|
wrapExpr :: NExprF r -> NExpr
|
|
wrapExpr x = Fix (Fix (NSym "<?>") <$ x)
|
|
|
|
renderEvalFrame :: (MonadReader e m, Has e Options, MonadFile m)
|
|
=> NixLevel -> EvalFrame m v -> m [Doc ann]
|
|
renderEvalFrame level f = do
|
|
opts :: Options <- asks (view hasLens)
|
|
case f of
|
|
EvaluatingExpr scope e@(Fix (Compose (Ann ann _))) -> do
|
|
let scopeInfo | scopes opts = [pretty $ show scope]
|
|
| otherwise = []
|
|
fmap (\x -> scopeInfo ++ [x]) $ renderLocation ann
|
|
=<< renderExpr level "While evaluating" "Expression" e
|
|
|
|
ForcingExpr _scope e@(Fix (Compose (Ann ann _)))
|
|
| thunks opts ->
|
|
fmap (:[]) $ renderLocation ann
|
|
=<< renderExpr level "While forcing thunk from"
|
|
"Forcing thunk" e
|
|
|
|
Calling name ann ->
|
|
fmap (:[]) $ renderLocation ann $
|
|
"While calling builtins." <> pretty name
|
|
|
|
_ -> pure []
|
|
|
|
renderExpr :: (MonadReader e m, Has e Options, MonadFile m)
|
|
=> NixLevel -> String -> String -> NExprLoc -> m (Doc ann)
|
|
renderExpr _level longLabel shortLabel e@(Fix (Compose (Ann _ x))) = do
|
|
opts :: Options <- asks (view hasLens)
|
|
let rendered
|
|
| verbose opts >= DebugInfo =
|
|
#ifdef MIN_VERSION_pretty_show
|
|
pretty (PS.ppShow (stripAnnotation e))
|
|
#else
|
|
pretty (show (stripAnnotation e))
|
|
#endif
|
|
| verbose opts >= Chatty =
|
|
prettyNix (stripAnnotation e)
|
|
| otherwise =
|
|
prettyNix (Fix (Fix (NSym "<?>") <$ x))
|
|
pure $ if verbose opts >= Chatty
|
|
then vsep $
|
|
[ pretty (longLabel ++ ":\n>>>>>>>>")
|
|
, indent 2 rendered
|
|
, "<<<<<<<<"
|
|
]
|
|
else pretty shortLabel <> fillSep [": ", rendered]
|
|
|
|
renderValueFrame :: (MonadReader e m, Has e Options,
|
|
MonadFile m, MonadVar m)
|
|
=> NixLevel -> ValueFrame m -> m [Doc ann]
|
|
renderValueFrame level = fmap (:[]) . \case
|
|
ForcingThunk -> pure "ForcingThunk"
|
|
ConcerningValue _v -> pure "ConcerningValue"
|
|
Comparison _ _ -> pure "Comparing"
|
|
Addition _ _ -> pure "Adding"
|
|
Division _ _ -> pure "Dividing"
|
|
Multiplication _ _ -> pure "Multiplying"
|
|
|
|
Coercion x y -> pure $ mconcat
|
|
[ desc
|
|
, pretty (describeValue x)
|
|
, " to "
|
|
, pretty (describeValue y)
|
|
]
|
|
where
|
|
desc | level <= Error = "Cannot coerce "
|
|
| otherwise = "While coercing "
|
|
|
|
CoercionToJson v -> do
|
|
v' <- renderValue level "" "" v
|
|
pure $ "CoercionToJson " <> v'
|
|
CoercionFromJson _j -> pure "CoercionFromJson"
|
|
ExpectationNF _t _v -> pure "ExpectationNF"
|
|
Expectation t v -> do
|
|
v' <- renderValue level "" "" v
|
|
pure $ "Saw " <> v'
|
|
<> " but expected " <> pretty (describeValue t)
|
|
|
|
renderValue :: (MonadReader e m, Has e Options, MonadFile m, MonadVar m)
|
|
=> NixLevel -> String -> String -> NValue m -> m (Doc ann)
|
|
renderValue _level _longLabel _shortLabel v = do
|
|
opts :: Options <- asks (view hasLens)
|
|
if values opts
|
|
then prettyNValueProv v
|
|
else prettyNValue v
|
|
|
|
renderExecFrame :: (MonadReader e m, Has e Options, MonadVar m, MonadFile m)
|
|
=> NixLevel -> ExecFrame m -> m [Doc ann]
|
|
renderExecFrame level = \case
|
|
Assertion ann v ->
|
|
fmap (:[]) $ renderLocation ann
|
|
=<< ((\d -> fillSep ["Assertion failed:", d])
|
|
<$> renderValue level "" "" v)
|
|
|
|
renderThunkLoop :: (MonadReader e m, Has e Options, MonadFile m)
|
|
=> NixLevel -> ThunkLoop -> m [Doc ann]
|
|
renderThunkLoop _level = pure . (:[]) . \case
|
|
ThunkLoop Nothing -> "Infinite recursion"
|
|
ThunkLoop (Just n) ->
|
|
pretty $ "Infinite recursion in thunk #" ++ show n
|
|
|
|
renderNormalLoop :: (MonadReader e m, Has e Options, MonadFile m, MonadVar m)
|
|
=> NixLevel -> NormalLoop m -> m [Doc ann]
|
|
renderNormalLoop level = fmap (:[]) . \case
|
|
NormalLoop v -> do
|
|
v' <- renderValue level "" "" v
|
|
pure $ "Infinite recursion during normalization forcing " <> v'
|