hnix/src/Nix/Render/Frame.hs

{-# 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 t f e m ann
  .  ( MonadReader e m
     , Has e Options
     , MonadFile m
     , MonadCitedThunks t f 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 @t @f x
           | verbose opts <= Informational -> do
             f <- renderFrame @v @t @f x
             pure $ concatMap go (reverse xs) ++ f
           | otherwise ->
             concat <$> mapM (renderFrame @v @t @f) (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 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 level f)
    | 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)]
    | 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

        SynHole synfo -> sequence $
            let e@(Fix (Compose (Ann ann _))) = _synHoleInfo_expr synfo
             in [ renderLocation ann =<<
                    renderExpr level "While evaluating" "Syntactic Hole" e
                , pure $ pretty $ show (_synHoleInfo_scope synfo)
                ]

        ForcingExpr _ _ -> 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
      , MonadCitedThunks t f m
      )
    => NixLevel -> ValueFrame t f 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
      , MonadCitedThunks t f m
      )
    => NixLevel -> String -> String -> NValue t f 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
      , MonadFile m
      , MonadCitedThunks t f m
      )
    => NixLevel -> ExecFrame t f 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, Show (ThunkId m))
    => NixLevel -> ThunkLoop -> m [Doc ann]
renderThunkLoop _level = pure . (:[]) . \case
    ThunkLoop n -> pretty $ "Infinite recursion in thunk " ++ n

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