{-# LANGUAGE CPP #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}


-- | Code for rendering/representation of the messages packaged with their context (Frames).
module Nix.Render.Frame where

import           Control.Monad.Reader
import           Data.Fix
import           Data.Typeable
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           Prettyprinter
import           Text.Megaparsec.Pos
#ifdef MIN_VERSION_pretty_show
import qualified Text.Show.Pretty as PS
#endif

renderFrames
  :: forall v t f e m ann
   . ( MonadReader e m
     , Has e Options
     , MonadFile m
     , MonadCitedThunks t f m
     , Typeable v
     )
  => Frames
  -> m (Doc ann)
renderFrames :: Frames -> m (Doc ann)
renderFrames []       = Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc ann
forall a. Monoid a => a
mempty
renderFrames (NixFrame
x : Frames
xs) = do
  Options
opts :: Options <- (e -> Options) -> m Options
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (FoldLike Options e e Options Options -> e -> Options
forall a s t b. FoldLike a s t a b -> s -> a
view FoldLike Options e e Options Options
forall a b. Has a b => Lens' a b
hasLens)
  [Doc ann]
frames          <- if
    | Options -> Verbosity
verbose Options
opts Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
<= Verbosity
ErrorsOnly -> NixFrame -> m [Doc ann]
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]
renderFrame @v @t @f NixFrame
x
    | Options -> Verbosity
verbose Options
opts Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
<= Verbosity
Informational -> do
      [Doc ann]
f <- NixFrame -> m [Doc ann]
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]
renderFrame @v @t @f NixFrame
x
      [Doc ann] -> m [Doc ann]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Doc ann] -> m [Doc ann]) -> [Doc ann] -> m [Doc ann]
forall a b. (a -> b) -> a -> b
$ (NixFrame -> [Doc ann]) -> Frames -> [Doc ann]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NixFrame -> [Doc ann]
go (Frames -> Frames
forall a. [a] -> [a]
reverse Frames
xs) [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. [a] -> [a] -> [a]
++ [Doc ann]
f
    | Bool
otherwise -> [[Doc ann]] -> [Doc ann]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Doc ann]] -> [Doc ann]) -> m [[Doc ann]] -> m [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NixFrame -> m [Doc ann]) -> Frames -> m [[Doc ann]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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]
forall e (m :: * -> *) ann.
(MonadReader e m, Has e Options, MonadFile m,
 MonadCitedThunks t f m, Typeable v) =>
NixFrame -> m [Doc ann]
renderFrame @v @t @f) (Frames -> Frames
forall a. [a] -> [a]
reverse (NixFrame
x NixFrame -> Frames -> Frames
forall a. a -> [a] -> [a]
: Frames
xs))
  Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc ann -> m (Doc ann)) -> Doc ann -> m (Doc ann)
forall a b. (a -> b) -> a -> b
$ case [Doc ann]
frames of
    [] -> Doc ann
forall a. Monoid a => a
mempty
    [Doc ann]
_  -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann]
frames
 where
  go :: NixFrame -> [Doc ann]
  go :: NixFrame -> [Doc ann]
go NixFrame
f = case NixFrame -> Maybe SourcePos
forall v (m :: * -> *).
(Typeable m, Typeable v) =>
NixFrame -> Maybe SourcePos
framePos @v @m NixFrame
f of
    Just SourcePos
pos ->
      [Doc ann
"While evaluating at " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (SourcePos -> String
sourcePosPretty SourcePos
pos) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon]
    Maybe SourcePos
Nothing -> []

framePos
  :: forall v (m :: * -> *)
   . (Typeable m, Typeable v)
  => NixFrame
  -> Maybe SourcePos
framePos :: NixFrame -> Maybe SourcePos
framePos (NixFrame NixLevel
_ SomeException
f)
  | Just (EvalFrame m v
e :: EvalFrame m v) <- SomeException -> Maybe (EvalFrame m v)
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
f = case EvalFrame m v
e of
    EvaluatingExpr Scopes m v
_ (Fix (Compose (Ann (SrcSpan SourcePos
beg SourcePos
_) NExprF (Fix NExprLocF)
_))) -> SourcePos -> Maybe SourcePos
forall a. a -> Maybe a
Just SourcePos
beg
    EvalFrame m v
_ -> Maybe SourcePos
forall a. Maybe a
Nothing
  | Bool
otherwise = Maybe SourcePos
forall a. Maybe a
Nothing

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]
renderFrame :: NixFrame -> m [Doc ann]
renderFrame (NixFrame NixLevel
level SomeException
f)
  | Just (EvalFrame m v
e :: EvalFrame m v) <- SomeException -> Maybe (EvalFrame m v)
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
f = NixLevel -> EvalFrame m v -> m [Doc ann]
forall e (m :: * -> *) v ann.
(MonadReader e m, Has e Options, MonadFile m) =>
NixLevel -> EvalFrame m v -> m [Doc ann]
renderEvalFrame NixLevel
level EvalFrame m v
e
  | Just (ThunkLoop
e :: ThunkLoop) <- SomeException -> Maybe ThunkLoop
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
f = NixLevel -> ThunkLoop -> m [Doc ann]
forall e (m :: * -> *) ann.
(MonadReader e m, Has e Options, MonadFile m, Show (ThunkId m)) =>
NixLevel -> ThunkLoop -> m [Doc ann]
renderThunkLoop NixLevel
level ThunkLoop
e
  | Just (ValueFrame t f m
e :: ValueFrame t f m) <- SomeException -> Maybe (ValueFrame t f m)
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
f = NixLevel -> ValueFrame t f m -> m [Doc ann]
forall e t (f :: * -> *) (m :: * -> *) ann.
(MonadReader e m, Has e Options, MonadFile m,
 MonadCitedThunks t f m) =>
NixLevel -> ValueFrame t f m -> m [Doc ann]
renderValueFrame NixLevel
level ValueFrame t f m
e
  | Just (NormalLoop t f m
e :: NormalLoop t f m) <- SomeException -> Maybe (NormalLoop t f m)
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
f = NixLevel -> NormalLoop t f m -> m [Doc ann]
forall e (m :: * -> *) t (f :: * -> *) ann.
(MonadReader e m, Has e Options, MonadFile m,
 MonadCitedThunks t f m) =>
NixLevel -> NormalLoop t f m -> m [Doc ann]
renderNormalLoop NixLevel
level NormalLoop t f m
e
  | Just (ExecFrame t f m
e :: ExecFrame t f m) <- SomeException -> Maybe (ExecFrame t f m)
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
f = NixLevel -> ExecFrame t f m -> m [Doc ann]
forall e (m :: * -> *) t (f :: * -> *) ann.
(MonadReader e m, Has e Options, MonadFile m,
 MonadCitedThunks t f m) =>
NixLevel -> ExecFrame t f m -> m [Doc ann]
renderExecFrame NixLevel
level ExecFrame t f m
e
  | Just (ErrorCall
e :: ErrorCall) <- SomeException -> Maybe ErrorCall
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
f = [Doc ann] -> m [Doc ann]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ErrorCall -> String
forall a. Show a => a -> String
show ErrorCall
e)]
  | Just (SynHoleInfo m v
e :: SynHoleInfo m v) <- SomeException -> Maybe (SynHoleInfo m v)
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
f = [Doc ann] -> m [Doc ann]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (SynHoleInfo m v -> String
forall a. Show a => a -> String
show SynHoleInfo m v
e)]
  | Bool
otherwise = String -> m [Doc ann]
forall a. HasCallStack => String -> a
error (String -> m [Doc ann]) -> String -> m [Doc ann]
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized frame: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
f

wrapExpr :: NExprF r -> NExpr
wrapExpr :: NExprF r -> NExpr
wrapExpr NExprF r
x = NExprF NExpr -> NExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (NExprF NExpr -> NExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (VarName -> NExprF NExpr
forall r. VarName -> NExprF r
NSym VarName
"<?>") NExpr -> NExprF r -> NExprF NExpr
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ NExprF r
x)

renderEvalFrame
  :: (MonadReader e m, Has e Options, MonadFile m)
  => NixLevel
  -> EvalFrame m v
  -> m [Doc ann]
renderEvalFrame :: NixLevel -> EvalFrame m v -> m [Doc ann]
renderEvalFrame NixLevel
level EvalFrame m v
f = do
  Options
opts :: Options <- (e -> Options) -> m Options
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (FoldLike Options e e Options Options -> e -> Options
forall a s t b. FoldLike a s t a b -> s -> a
view FoldLike Options e e Options Options
forall a b. Has a b => Lens' a b
hasLens)
  case EvalFrame m v
f of
    EvaluatingExpr Scopes m v
scope e :: Fix NExprLocF
e@(Fix (Compose (Ann SrcSpan
ann NExprF (Fix NExprLocF)
_))) -> do
      let scopeInfo :: [Doc ann]
scopeInfo | Options -> Bool
scopes Options
opts = [String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ Scopes m v -> String
forall a. Show a => a -> String
show Scopes m v
scope]
                    | Bool
otherwise   = []
      (Doc ann -> [Doc ann]) -> m (Doc ann) -> m [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Doc ann
x -> [Doc ann]
scopeInfo [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. [a] -> [a] -> [a]
++ [Doc ann
x])
        (m (Doc ann) -> m [Doc ann]) -> m (Doc ann) -> m [Doc ann]
forall a b. (a -> b) -> a -> b
$   SrcSpan -> Doc ann -> m (Doc ann)
forall (m :: * -> *) a.
MonadFile m =>
SrcSpan -> Doc a -> m (Doc a)
renderLocation SrcSpan
ann
        (Doc ann -> m (Doc ann)) -> m (Doc ann) -> m (Doc ann)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NixLevel -> String -> String -> Fix NExprLocF -> m (Doc ann)
forall e (m :: * -> *) ann.
(MonadReader e m, Has e Options, MonadFile m) =>
NixLevel -> String -> String -> Fix NExprLocF -> m (Doc ann)
renderExpr NixLevel
level String
"While evaluating" String
"Expression" Fix NExprLocF
e

    ForcingExpr Scopes m v
_scope e :: Fix NExprLocF
e@(Fix (Compose (Ann SrcSpan
ann NExprF (Fix NExprLocF)
_))) | Options -> Bool
thunks Options
opts ->
      (Doc ann -> [Doc ann]) -> m (Doc ann) -> m [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: [])
        (m (Doc ann) -> m [Doc ann]) -> m (Doc ann) -> m [Doc ann]
forall a b. (a -> b) -> a -> b
$   SrcSpan -> Doc ann -> m (Doc ann)
forall (m :: * -> *) a.
MonadFile m =>
SrcSpan -> Doc a -> m (Doc a)
renderLocation SrcSpan
ann
        (Doc ann -> m (Doc ann)) -> m (Doc ann) -> m (Doc ann)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NixLevel -> String -> String -> Fix NExprLocF -> m (Doc ann)
forall e (m :: * -> *) ann.
(MonadReader e m, Has e Options, MonadFile m) =>
NixLevel -> String -> String -> Fix NExprLocF -> m (Doc ann)
renderExpr NixLevel
level String
"While forcing thunk from" String
"Forcing thunk" Fix NExprLocF
e

    Calling String
name SrcSpan
ann ->
      (Doc ann -> [Doc ann]) -> m (Doc ann) -> m [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: [])
        (m (Doc ann) -> m [Doc ann]) -> m (Doc ann) -> m [Doc ann]
forall a b. (a -> b) -> a -> b
$  SrcSpan -> Doc ann -> m (Doc ann)
forall (m :: * -> *) a.
MonadFile m =>
SrcSpan -> Doc a -> m (Doc a)
renderLocation SrcSpan
ann
        (Doc ann -> m (Doc ann)) -> Doc ann -> m (Doc ann)
forall a b. (a -> b) -> a -> b
$  Doc ann
"While calling builtins."
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
name

    SynHole SynHoleInfo m v
synfo ->
      [m (Doc ann)] -> m [Doc ann]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        ([m (Doc ann)] -> m [Doc ann]) -> [m (Doc ann)] -> m [Doc ann]
forall a b. (a -> b) -> a -> b
$ let e :: Fix NExprLocF
e@(Fix (Compose (Ann SrcSpan
ann NExprF (Fix NExprLocF)
_))) = SynHoleInfo m v -> Fix NExprLocF
forall (m :: * -> *) v. SynHoleInfo m v -> Fix NExprLocF
_synHoleInfo_expr SynHoleInfo m v
synfo
          in  [ SrcSpan -> Doc ann -> m (Doc ann)
forall (m :: * -> *) a.
MonadFile m =>
SrcSpan -> Doc a -> m (Doc a)
renderLocation SrcSpan
ann
                (Doc ann -> m (Doc ann)) -> m (Doc ann) -> m (Doc ann)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NixLevel -> String -> String -> Fix NExprLocF -> m (Doc ann)
forall e (m :: * -> *) ann.
(MonadReader e m, Has e Options, MonadFile m) =>
NixLevel -> String -> String -> Fix NExprLocF -> m (Doc ann)
renderExpr NixLevel
level String
"While evaluating" String
"Syntactic Hole" Fix NExprLocF
e
              , Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc ann -> m (Doc ann)) -> Doc ann -> m (Doc ann)
forall a b. (a -> b) -> a -> b
$ String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ Scopes m v -> String
forall a. Show a => a -> String
show (SynHoleInfo m v -> Scopes m v
forall (m :: * -> *) v. SynHoleInfo m v -> Scopes m v
_synHoleInfo_scope SynHoleInfo m v
synfo)
              ]

    ForcingExpr Scopes m v
_ Fix NExprLocF
_ -> [Doc ann] -> m [Doc ann]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []


renderExpr
  :: (MonadReader e m, Has e Options, MonadFile m)
  => NixLevel
  -> String
  -> String
  -> NExprLoc
  -> m (Doc ann)
renderExpr :: NixLevel -> String -> String -> Fix NExprLocF -> m (Doc ann)
renderExpr NixLevel
_level String
longLabel String
shortLabel e :: Fix NExprLocF
e@(Fix (Compose (Ann SrcSpan
_ NExprF (Fix NExprLocF)
x))) = do
  Options
opts :: Options <- (e -> Options) -> m Options
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (FoldLike Options e e Options Options -> e -> Options
forall a s t b. FoldLike a s t a b -> s -> a
view FoldLike Options e e Options Options
forall a b. Has a b => Lens' a b
hasLens)
  let rendered :: Doc ann
rendered
          | Options -> Verbosity
verbose Options
opts Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
DebugInfo =
#ifdef MIN_VERSION_pretty_show
              String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (NExpr -> String
forall a. Show a => a -> String
PS.ppShow (Fix NExprLocF -> NExpr
forall (f :: * -> *) ann. Functor f => Fix (AnnF ann f) -> Fix f
stripAnnotation Fix NExprLocF
e))
#else
              pretty (show (stripAnnotation e))
#endif
          | Options -> Verbosity
verbose Options
opts Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Chatty = NExpr -> Doc ann
forall ann. NExpr -> Doc ann
prettyNix (Fix NExprLocF -> NExpr
forall (f :: * -> *) ann. Functor f => Fix (AnnF ann f) -> Fix f
stripAnnotation Fix NExprLocF
e)
          | Bool
otherwise = NExpr -> Doc ann
forall ann. NExpr -> Doc ann
prettyNix (NExprF NExpr -> NExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (NExprF NExpr -> NExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (VarName -> NExprF NExpr
forall r. VarName -> NExprF r
NSym VarName
"<?>") NExpr -> NExprF (Fix NExprLocF) -> NExprF NExpr
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ NExprF (Fix NExprLocF)
x))
  Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc ann -> m (Doc ann)) -> Doc ann -> m (Doc ann)
forall a b. (a -> b) -> a -> b
$ if Options -> Verbosity
verbose Options
opts Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Chatty
    then
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
longLabel String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n>>>>>>>>"), Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ann
rendered, Doc ann
"<<<<<<<<"]
    else String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
shortLabel Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
fillSep [Doc ann
": ", Doc ann
rendered]

renderValueFrame
  :: forall e t f m ann
   . (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
  => NixLevel
  -> ValueFrame t f m
  -> m [Doc ann]
renderValueFrame :: NixLevel -> ValueFrame t f m -> m [Doc ann]
renderValueFrame NixLevel
level = (Doc ann -> [Doc ann]) -> m (Doc ann) -> m [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: []) (m (Doc ann) -> m [Doc ann])
-> (ValueFrame t f m -> m (Doc ann))
-> ValueFrame t f m
-> m [Doc ann]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  ForcingThunk    t
_t -> Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc ann
"ForcingThunk" -- jww (2019-03-18): NYI
  ConcerningValue NValue t f m
_v -> Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc ann
"ConcerningValue"
  Comparison     NValue t f m
_ NValue t f m
_ -> Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc ann
"Comparing"
  Addition       NValue t f m
_ NValue t f m
_ -> Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc ann
"Adding"
  Division       NValue t f m
_ NValue t f m
_ -> Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc ann
"Dividing"
  Multiplication NValue t f m
_ NValue t f m
_ -> Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc ann
"Multiplying"

  Coercion       ValueType
x ValueType
y -> Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Doc ann -> m (Doc ann)) -> Doc ann -> m (Doc ann)
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat [Doc ann
desc, String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ValueType -> String
describeValue ValueType
x), Doc ann
" to ", String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ValueType -> String
describeValue ValueType
y)]
   where
    desc :: Doc ann
desc | NixLevel
level NixLevel -> NixLevel -> Bool
forall a. Ord a => a -> a -> Bool
<= NixLevel
Error = Doc ann
"Cannot coerce "
         | Bool
otherwise      = Doc ann
"While coercing "

  CoercionToJson NValue t f m
v -> do
    Doc ann
v' <- NixLevel -> String -> String -> NValue t f m -> m (Doc ann)
forall e t (f :: * -> *) (m :: * -> *) ann.
(MonadReader e m, Has e Options, MonadFile m,
 MonadCitedThunks t f m) =>
NixLevel -> String -> String -> NValue t f m -> m (Doc ann)
renderValue NixLevel
level String
"" String
"" NValue t f m
v
    Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc ann -> m (Doc ann)) -> Doc ann -> m (Doc ann)
forall a b. (a -> b) -> a -> b
$ Doc ann
"CoercionToJson " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
v'
  CoercionFromJson Value
_j -> Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc ann
"CoercionFromJson"
  Expectation ValueType
t NValue t f m
v     -> do
    Doc ann
v' <- NixLevel -> String -> String -> NValue t f m -> m (Doc ann)
forall e t (f :: * -> *) (m :: * -> *) ann.
(MonadReader e m, Has e Options, MonadFile m,
 MonadCitedThunks t f m) =>
NixLevel -> String -> String -> NValue t f m -> m (Doc ann)
renderValue @_ @t @f @m NixLevel
level String
"" String
"" NValue t f m
v
    Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc ann -> m (Doc ann)) -> Doc ann -> m (Doc ann)
forall a b. (a -> b) -> a -> b
$ Doc ann
"Saw " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
v' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" but expected " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ValueType -> String
describeValue ValueType
t)

renderValue
  :: forall e t f m ann
   . (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
  => NixLevel
  -> String
  -> String
  -> NValue t f m
  -> m (Doc ann)
renderValue :: NixLevel -> String -> String -> NValue t f m -> m (Doc ann)
renderValue NixLevel
_level String
_longLabel String
_shortLabel NValue t f m
v = do
  Options
opts :: Options <- (e -> Options) -> m Options
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (FoldLike Options e e Options Options -> e -> Options
forall a s t b. FoldLike a s t a b -> s -> a
view FoldLike Options e e Options Options
forall a b. Has a b => Lens' a b
hasLens)
  (if Options -> Bool
values Options
opts
     then NValue t f m -> Doc ann
forall t (f :: * -> *) (m :: * -> *) ann.
(HasCitations m (NValue t f m) t, HasCitations1 m (NValue t f m) f,
 MonadThunk t m (NValue t f m), MonadDataContext f m) =>
NValue t f m -> Doc ann
prettyNValueProv
     else NValue t f m -> Doc ann
forall t (f :: * -> *) (m :: * -> *) ann.
MonadDataContext f m =>
NValue t f m -> Doc ann
prettyNValue) (NValue t f m -> Doc ann) -> m (NValue t f m) -> m (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NValue t f m -> m (NValue t f m)
forall t (m :: * -> *) (f :: * -> *).
(MonadThunk t m (NValue t f m), MonadDataContext f m) =>
NValue t f m -> m (NValue t f m)
removeEffects NValue t f m
v

renderExecFrame
  :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
  => NixLevel
  -> ExecFrame t f m
  -> m [Doc ann]
renderExecFrame :: NixLevel -> ExecFrame t f m -> m [Doc ann]
renderExecFrame NixLevel
level = \case
  Assertion SrcSpan
ann NValue t f m
v ->
    (Doc ann -> [Doc ann]) -> m (Doc ann) -> m [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: [])
      (m (Doc ann) -> m [Doc ann]) -> m (Doc ann) -> m [Doc ann]
forall a b. (a -> b) -> a -> b
$   SrcSpan -> Doc ann -> m (Doc ann)
forall (m :: * -> *) a.
MonadFile m =>
SrcSpan -> Doc a -> m (Doc a)
renderLocation SrcSpan
ann
      (Doc ann -> m (Doc ann)) -> m (Doc ann) -> m (Doc ann)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (   (\Doc ann
d -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
fillSep [Doc ann
"Assertion failed:", Doc ann
d])
          (Doc ann -> Doc ann) -> m (Doc ann) -> m (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NixLevel -> String -> String -> NValue t f m -> m (Doc ann)
forall e t (f :: * -> *) (m :: * -> *) ann.
(MonadReader e m, Has e Options, MonadFile m,
 MonadCitedThunks t f m) =>
NixLevel -> String -> String -> NValue t f m -> m (Doc ann)
renderValue NixLevel
level String
"" String
"" NValue t f m
v
          )

renderThunkLoop
  :: (MonadReader e m, Has e Options, MonadFile m, Show (ThunkId m))
  => NixLevel
  -> ThunkLoop
  -> m [Doc ann]
renderThunkLoop :: NixLevel -> ThunkLoop -> m [Doc ann]
renderThunkLoop NixLevel
_level = [Doc ann] -> m [Doc ann]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Doc ann] -> m [Doc ann])
-> (ThunkLoop -> [Doc ann]) -> ThunkLoop -> m [Doc ann]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: []) (Doc ann -> [Doc ann])
-> (ThunkLoop -> Doc ann) -> ThunkLoop -> [Doc ann]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  ThunkLoop String
n -> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ String
"Infinite recursion in thunk " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n

renderNormalLoop
  :: (MonadReader e m, Has e Options, MonadFile m, MonadCitedThunks t f m)
  => NixLevel
  -> NormalLoop t f m
  -> m [Doc ann]
renderNormalLoop :: NixLevel -> NormalLoop t f m -> m [Doc ann]
renderNormalLoop NixLevel
level = (Doc ann -> [Doc ann]) -> m (Doc ann) -> m [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: []) (m (Doc ann) -> m [Doc ann])
-> (NormalLoop t f m -> m (Doc ann))
-> NormalLoop t f m
-> m [Doc ann]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  NormalLoop NValue t f m
v -> do
    Doc ann
v' <- NixLevel -> String -> String -> NValue t f m -> m (Doc ann)
forall e t (f :: * -> *) (m :: * -> *) ann.
(MonadReader e m, Has e Options, MonadFile m,
 MonadCitedThunks t f m) =>
NixLevel -> String -> String -> NValue t f m -> m (Doc ann)
renderValue NixLevel
level String
"" String
"" NValue t f m
v
    Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc ann -> m (Doc ann)) -> Doc ann -> m (Doc ann)
forall a b. (a -> b) -> a -> b
$ Doc ann
"Infinite recursion during normalization forcing " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
v'