2018-05-09 01:40:56 +02:00
|
|
|
{-# LANGUAGE CPP #-}
|
2018-04-25 22:00:41 +02:00
|
|
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
2018-04-24 20:12:20 +02:00
|
|
|
{-# LANGUAGE ConstraintKinds #-}
|
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
{-# LANGUAGE LambdaCase #-}
|
2018-04-25 22:00:41 +02:00
|
|
|
{-# LANGUAGE MultiWayIf #-}
|
2018-04-24 20:12:20 +02:00
|
|
|
{-# LANGUAGE GADTs #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2018-04-25 22:00:41 +02:00
|
|
|
{-# LANGUAGE TypeApplications #-}
|
2018-04-24 20:12:20 +02:00
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
|
|
|
|
module Nix.Render.Frame where
|
|
|
|
|
2018-04-25 08:09:43 +02:00
|
|
|
import Control.Monad.Reader
|
|
|
|
import Data.Fix
|
|
|
|
import Data.Typeable
|
2018-11-17 05:51:18 +01:00
|
|
|
import Data.Text.Prettyprint.Doc
|
2018-04-25 08:09:43 +02:00
|
|
|
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
|
2018-05-07 21:06:56 +02:00
|
|
|
import Text.Megaparsec.Pos
|
2018-05-13 23:17:55 +02:00
|
|
|
#ifdef MIN_VERSION_pretty_show
|
2018-04-25 22:00:41 +02:00
|
|
|
import qualified Text.Show.Pretty as PS
|
2018-05-09 01:40:56 +02:00
|
|
|
#endif
|
2018-04-24 20:12:20 +02:00
|
|
|
|
2018-11-17 05:51:18 +01:00
|
|
|
renderFrames
|
2019-03-15 20:59:13 +01:00
|
|
|
:: forall v t f e m ann
|
|
|
|
. ( MonadReader e m
|
|
|
|
, Has e Options
|
|
|
|
, MonadFile m
|
|
|
|
, MonadCitedThunks t f m
|
|
|
|
, Typeable v
|
|
|
|
)
|
2018-11-17 05:51:18 +01:00
|
|
|
=> Frames -> m (Doc ann)
|
2018-04-24 20:12:20 +02:00
|
|
|
renderFrames [] = pure mempty
|
2018-04-25 22:00:41 +02:00
|
|
|
renderFrames (x:xs) = do
|
|
|
|
opts :: Options <- asks (view hasLens)
|
|
|
|
frames <-
|
|
|
|
if | verbose opts <= ErrorsOnly ->
|
2019-03-15 20:59:13 +01:00
|
|
|
renderFrame @v @t @f x
|
2018-04-25 22:00:41 +02:00
|
|
|
| verbose opts <= Informational -> do
|
2019-03-15 20:59:13 +01:00
|
|
|
f <- renderFrame @v @t @f x
|
2018-04-25 22:00:41 +02:00
|
|
|
pure $ concatMap go (reverse xs) ++ f
|
|
|
|
| otherwise ->
|
2019-03-15 20:59:13 +01:00
|
|
|
concat <$> mapM (renderFrame @v @t @f) (reverse (x:xs))
|
2018-04-25 22:00:41 +02:00
|
|
|
pure $ case frames of
|
|
|
|
[] -> mempty
|
2018-11-17 05:51:18 +01:00
|
|
|
_ -> vsep frames
|
2018-04-25 22:00:41 +02:00
|
|
|
where
|
2018-11-17 05:51:18 +01:00
|
|
|
go :: NixFrame -> [Doc ann]
|
2018-04-25 22:00:41 +02:00
|
|
|
go f = case framePos @v @m f of
|
|
|
|
Just pos ->
|
2018-11-17 05:51:18 +01:00
|
|
|
["While evaluating at "
|
|
|
|
<> pretty (sourcePosPretty pos)
|
2018-04-25 22:00:41 +02:00
|
|
|
<> colon]
|
|
|
|
Nothing -> []
|
2018-04-24 20:12:20 +02:00
|
|
|
|
2018-04-25 22:00:41 +02:00
|
|
|
framePos :: forall v (m :: * -> *). (Typeable m, Typeable v) => NixFrame
|
|
|
|
-> Maybe SourcePos
|
|
|
|
framePos (NixFrame _ f)
|
2018-05-02 02:33:17 +02:00
|
|
|
| Just (e :: EvalFrame m v) <- fromException f = case e of
|
2018-04-25 22:00:41 +02:00
|
|
|
EvaluatingExpr _ (Fix (Compose (Ann (SrcSpan beg _) _))) ->
|
|
|
|
Just beg
|
|
|
|
_ -> Nothing
|
|
|
|
| otherwise = Nothing
|
|
|
|
|
2019-03-15 20:59:13 +01:00
|
|
|
renderFrame
|
|
|
|
:: forall v t f e m ann.
|
|
|
|
( MonadReader e m
|
|
|
|
, Has e Options
|
|
|
|
, MonadFile m
|
|
|
|
, MonadCitedThunks t f m
|
|
|
|
, Typeable v
|
|
|
|
)
|
|
|
|
=> NixFrame -> m [Doc ann]
|
2018-04-24 20:12:20 +02:00
|
|
|
renderFrame (NixFrame level f)
|
2019-03-15 20:59:13 +01:00
|
|
|
| Just (e :: EvalFrame m v) <- fromException f = renderEvalFrame level e
|
|
|
|
| Just (e :: ThunkLoop) <- fromException f = renderThunkLoop level e
|
|
|
|
| Just (e :: ValueFrame t f m) <- fromException f = renderValueFrame level e
|
|
|
|
| Just (e :: NormalLoop t f m) <- fromException f = renderNormalLoop level e
|
|
|
|
| Just (e :: ExecFrame t f m) <- fromException f = renderExecFrame level e
|
|
|
|
| Just (e :: ErrorCall) <- fromException f = pure [pretty (show e)]
|
|
|
|
| Just (e :: SynHoleInfo m v) <- fromException f = pure [pretty (show e)]
|
2018-04-24 20:12:20 +02:00
|
|
|
| otherwise = error $ "Unrecognized frame: " ++ show f
|
|
|
|
|
2018-04-25 08:09:43 +02:00
|
|
|
wrapExpr :: NExprF r -> NExpr
|
|
|
|
wrapExpr x = Fix (Fix (NSym "<?>") <$ x)
|
|
|
|
|
2018-04-24 20:12:20 +02:00
|
|
|
renderEvalFrame :: (MonadReader e m, Has e Options, MonadFile m)
|
2018-11-17 05:51:18 +01:00
|
|
|
=> NixLevel -> EvalFrame m v -> m [Doc ann]
|
2018-04-28 05:36:38 +02:00
|
|
|
renderEvalFrame level f = do
|
2018-04-25 22:00:41 +02:00
|
|
|
opts :: Options <- asks (view hasLens)
|
|
|
|
case f of
|
2018-08-04 20:40:04 +02:00
|
|
|
EvaluatingExpr scope e@(Fix (Compose (Ann ann _))) -> do
|
2018-11-17 05:51:18 +01:00
|
|
|
let scopeInfo | scopes opts = [pretty $ show scope]
|
2018-08-04 20:40:04 +02:00
|
|
|
| otherwise = []
|
|
|
|
fmap (\x -> scopeInfo ++ [x]) $ renderLocation ann
|
2018-04-28 05:36:38 +02:00
|
|
|
=<< renderExpr level "While evaluating" "Expression" e
|
2018-04-24 20:12:20 +02:00
|
|
|
|
2018-04-25 22:00:41 +02:00
|
|
|
ForcingExpr _scope e@(Fix (Compose (Ann ann _)))
|
|
|
|
| thunks opts ->
|
2018-04-28 05:36:38 +02:00
|
|
|
fmap (:[]) $ renderLocation ann
|
|
|
|
=<< renderExpr level "While forcing thunk from"
|
|
|
|
"Forcing thunk" e
|
2018-05-06 09:35:21 +02:00
|
|
|
|
|
|
|
Calling name ann ->
|
|
|
|
fmap (:[]) $ renderLocation ann $
|
2018-11-17 05:51:18 +01:00
|
|
|
"While calling builtins." <> pretty name
|
2018-05-06 09:35:21 +02:00
|
|
|
|
2018-11-18 00:20:59 +01:00
|
|
|
SynHole synfo -> sequence $
|
|
|
|
let e@(Fix (Compose (Ann ann _))) = _synHoleInfo_expr synfo
|
|
|
|
in [ renderLocation ann =<<
|
|
|
|
renderExpr level "While evaluating" "Syntactic Hole" e
|
2019-03-10 18:41:31 +01:00
|
|
|
, pure $ pretty $ show (_synHoleInfo_scope synfo)
|
2018-11-18 00:20:59 +01:00
|
|
|
]
|
|
|
|
|
|
|
|
ForcingExpr _ _ -> pure []
|
|
|
|
|
2018-04-28 05:36:38 +02:00
|
|
|
|
|
|
|
renderExpr :: (MonadReader e m, Has e Options, MonadFile m)
|
2018-11-17 05:51:18 +01:00
|
|
|
=> NixLevel -> String -> String -> NExprLoc -> m (Doc ann)
|
2018-04-28 05:36:38 +02:00
|
|
|
renderExpr _level longLabel shortLabel e@(Fix (Compose (Ann _ x))) = do
|
|
|
|
opts :: Options <- asks (view hasLens)
|
|
|
|
let rendered
|
|
|
|
| verbose opts >= DebugInfo =
|
2018-05-13 23:17:55 +02:00
|
|
|
#ifdef MIN_VERSION_pretty_show
|
2018-11-17 05:51:18 +01:00
|
|
|
pretty (PS.ppShow (stripAnnotation e))
|
2018-05-09 01:40:56 +02:00
|
|
|
#else
|
2018-11-17 05:51:18 +01:00
|
|
|
pretty (show (stripAnnotation e))
|
2018-05-09 01:40:56 +02:00
|
|
|
#endif
|
2018-04-28 05:36:38 +02:00
|
|
|
| verbose opts >= Chatty =
|
|
|
|
prettyNix (stripAnnotation e)
|
|
|
|
| otherwise =
|
|
|
|
prettyNix (Fix (Fix (NSym "<?>") <$ x))
|
|
|
|
pure $ if verbose opts >= Chatty
|
2018-11-17 05:51:18 +01:00
|
|
|
then vsep $
|
|
|
|
[ pretty (longLabel ++ ":\n>>>>>>>>")
|
|
|
|
, indent 2 rendered
|
|
|
|
, "<<<<<<<<"
|
|
|
|
]
|
|
|
|
else pretty shortLabel <> fillSep [": ", rendered]
|
2018-04-24 20:12:20 +02:00
|
|
|
|
2019-03-15 20:59:13 +01:00
|
|
|
renderValueFrame
|
|
|
|
:: ( MonadReader e m
|
|
|
|
, Has e Options
|
|
|
|
, MonadFile m
|
|
|
|
, MonadCitedThunks t f m
|
|
|
|
)
|
|
|
|
=> NixLevel -> ValueFrame t f m -> m [Doc ann]
|
2018-08-05 01:05:01 +02:00
|
|
|
renderValueFrame level = fmap (:[]) . \case
|
2018-11-17 05:51:18 +01:00
|
|
|
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)
|
|
|
|
]
|
2018-04-24 20:12:20 +02:00
|
|
|
where
|
|
|
|
desc | level <= Error = "Cannot coerce "
|
|
|
|
| otherwise = "While coercing "
|
|
|
|
|
2018-12-05 20:59:42 +01:00
|
|
|
CoercionToJson v -> do
|
|
|
|
v' <- renderValue level "" "" v
|
|
|
|
pure $ "CoercionToJson " <> v'
|
2018-11-17 05:51:18 +01:00
|
|
|
CoercionFromJson _j -> pure "CoercionFromJson"
|
|
|
|
ExpectationNF _t _v -> pure "ExpectationNF"
|
2018-08-05 01:05:01 +02:00
|
|
|
Expectation t v -> do
|
|
|
|
v' <- renderValue level "" "" v
|
2018-11-17 05:51:18 +01:00
|
|
|
pure $ "Saw " <> v'
|
|
|
|
<> " but expected " <> pretty (describeValue t)
|
2018-04-24 20:12:20 +02:00
|
|
|
|
2019-03-15 20:59:13 +01:00
|
|
|
renderValue
|
|
|
|
:: ( MonadReader e m
|
|
|
|
, Has e Options
|
|
|
|
, MonadFile m
|
|
|
|
, MonadCitedThunks t f m
|
|
|
|
)
|
|
|
|
=> NixLevel -> String -> String -> NValue t f m -> m (Doc ann)
|
2018-04-28 05:36:38 +02:00
|
|
|
renderValue _level _longLabel _shortLabel v = do
|
|
|
|
opts :: Options <- asks (view hasLens)
|
|
|
|
if values opts
|
|
|
|
then prettyNValueProv v
|
|
|
|
else prettyNValue v
|
|
|
|
|
2019-03-15 20:59:13 +01:00
|
|
|
renderExecFrame
|
|
|
|
:: ( MonadReader e m
|
|
|
|
, Has e Options
|
|
|
|
, MonadFile m
|
|
|
|
, MonadCitedThunks t f m
|
|
|
|
)
|
|
|
|
=> NixLevel -> ExecFrame t f m -> m [Doc ann]
|
2018-04-28 05:36:38 +02:00
|
|
|
renderExecFrame level = \case
|
|
|
|
Assertion ann v ->
|
|
|
|
fmap (:[]) $ renderLocation ann
|
2018-11-17 05:51:18 +01:00
|
|
|
=<< ((\d -> fillSep ["Assertion failed:", d])
|
2018-04-28 05:36:38 +02:00
|
|
|
<$> renderValue level "" "" v)
|
2018-04-24 20:12:20 +02:00
|
|
|
|
|
|
|
renderThunkLoop :: (MonadReader e m, Has e Options, MonadFile m)
|
2018-11-17 05:51:18 +01:00
|
|
|
=> NixLevel -> ThunkLoop -> m [Doc ann]
|
2018-04-25 22:00:41 +02:00
|
|
|
renderThunkLoop _level = pure . (:[]) . \case
|
2019-03-16 19:41:48 +01:00
|
|
|
ThunkLoop n -> pretty $ "Infinite recursion in thunk #" ++ show n
|
2018-08-05 21:48:52 +02:00
|
|
|
|
2019-03-15 20:59:13 +01:00
|
|
|
renderNormalLoop
|
|
|
|
:: ( MonadReader e m
|
|
|
|
, Has e Options
|
|
|
|
, MonadFile m
|
|
|
|
, MonadCitedThunks t f m
|
|
|
|
)
|
|
|
|
=> NixLevel -> NormalLoop t f m -> m [Doc ann]
|
2018-08-05 21:48:52 +02:00
|
|
|
renderNormalLoop level = fmap (:[]) . \case
|
|
|
|
NormalLoop v -> do
|
|
|
|
v' <- renderValue level "" "" v
|
2018-11-25 04:09:28 +01:00
|
|
|
pure $ "Infinite recursion during normalization forcing " <> v'
|