{-# 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           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 (x :: NixFrame
x : xs :: 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
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann]
frames
 where
  go :: NixFrame -> [Doc ann]
  go :: NixFrame -> [Doc ann]
go f :: NixFrame
f = case NixFrame -> Maybe SourcePos
forall v (m :: * -> *).
(Typeable m, Typeable v) =>
NixFrame -> Maybe SourcePos
framePos @v @m NixFrame
f of
    Just pos :: SourcePos
pos ->
      ["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]
    Nothing -> []

framePos
  :: forall v (m :: * -> *)
   . (Typeable m, Typeable v)
  => NixFrame
  -> Maybe SourcePos
framePos :: NixFrame -> Maybe SourcePos
framePos (NixFrame _ f :: 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 _ (Fix (Compose (Ann (SrcSpan beg :: SourcePos
beg _) _))) -> SourcePos -> Maybe SourcePos
forall a. a -> Maybe a
Just SourcePos
beg
    _ -> 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 level :: NixLevel
level f :: 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
$ "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 x :: 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 "<?>") 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 level :: NixLevel
level f :: 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 scope :: Scopes m v
scope e :: Fix NExprLocF
e@(Fix (Compose (Ann ann :: SrcSpan
ann _))) -> 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 (\x :: 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 "While evaluating" "Expression" Fix NExprLocF
e

    ForcingExpr _scope :: Scopes m v
_scope e :: Fix NExprLocF
e@(Fix (Compose (Ann ann :: SrcSpan
ann _))) | 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 "While forcing thunk from" "Forcing thunk" Fix NExprLocF
e

    Calling name :: String
name ann :: 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
$  "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 synfo :: 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 ann :: SrcSpan
ann _))) = 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 "While evaluating" "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 _ _ -> [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 _level :: NixLevel
_level longLabel :: String
longLabel shortLabel :: String
shortLabel e :: Fix NExprLocF
e@(Fix (Compose (Ann _ x :: 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 "<?>") 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
        ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ [String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
longLabel String -> String -> String
forall a. [a] -> [a] -> [a]
++ ":\n>>>>>>>>"), Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent 2 Doc ann
rendered, "<<<<<<<<"]
    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
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 level :: 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
_t -> Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure "ForcingThunk" -- jww (2019-03-18): NYI
  ConcerningValue _v :: NValue t f m
_v -> Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure "ConcerningValue"
  Comparison     _ _ -> Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure "Comparing"
  Addition       _ _ -> Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure "Adding"
  Division       _ _ -> Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure "Dividing"
  Multiplication _ _ -> Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure "Multiplying"

  Coercion       x :: ValueType
x y :: 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), " 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 = "Cannot coerce "
         | Bool
otherwise      = "While coercing "

  CoercionToJson v :: 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 "" "" 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
$ "CoercionToJson " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
v'
  CoercionFromJson _j :: Value
_j -> Doc ann -> m (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure "CoercionFromJson"
  Expectation t :: ValueType
t v :: 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 "" "" 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
$ "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
<> " 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 _level :: NixLevel
_level _longLabel :: String
_longLabel _shortLabel :: String
_shortLabel v :: 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 level :: NixLevel
level = \case
  Assertion ann :: SrcSpan
ann v :: 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
=<< (   (\d :: Doc ann
d -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
fillSep ["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 "" "" 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 _level :: 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 n :: 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
$ "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 level :: 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 v :: 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 "" "" 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
$ "Infinite recursion during normalization forcing " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
v'