Render.hs

{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

module Test.Sandwich.Hedgehog.Render (
  renderHedgehogToImage
  , renderHedgehogToTokens

  -- * Util
  , dedent
  ) where

import Data.Function
import qualified Data.List as L
import qualified Data.Text as T
import Graphics.Vty.Attributes hiding (currentAttr)
import Graphics.Vty.Image
import Hedgehog.Internal.Report
import Text.PrettyPrint.Annotated.WL (Doc)
import qualified Text.PrettyPrint.Annotated.WL as WL


renderHedgehogToImage :: Doc Markup -> Image
renderHedgehogToImage doc = foldTokens emptyImage defaultAttr $ renderHedgehogToTokens doc

foldTokens imageSoFar currentAttr ((Str "\n"):xs) = (if imageSoFar == emptyImage then text defaultAttr " " else imageSoFar) <-> foldTokens emptyImage currentAttr xs
foldTokens imageSoFar currentAttr ((Str s):xs) = foldTokens (imageSoFar <|> text' currentAttr s) currentAttr xs
foldTokens imageSoFar _currentAttr ((NewAttr attr):xs) = foldTokens imageSoFar attr xs
foldTokens imageSoFar _currentAttr [] = imageSoFar

renderHedgehogToTokens :: Doc Markup -> [Token]
renderHedgehogToTokens doc =
  WL.indent 0 doc
  & WL.renderSmart 100
  & WL.displayDecorated (\x -> [NewAttr $ start x]) end (\x -> [Str (T.pack x)])
  & joinAdjacentStrings
  & splitNewlines
  where
    joinAdjacentStrings ((Str s1):(Str s2):xs) = joinAdjacentStrings (Str (s1 <> s2) : xs)
    joinAdjacentStrings (x:xs) = x : joinAdjacentStrings xs
    joinAdjacentStrings [] = []

    splitNewlines :: [Token] -> [Token]
    splitNewlines ((Str s):xs) = [Str s' | s' <- parts, s' /= ""] <> splitNewlines xs
      where parts = L.intersperse "\n" $ T.splitOn "\n" s
    splitNewlines (x:xs) = x : splitNewlines xs
    splitNewlines [] = []

data Token = Str T.Text
           | NewAttr Attr
  deriving (Show)

dedent :: Int -> String -> String
dedent n s
  | (replicate n ' ') `L.isPrefixOf` s = L.drop n s
  | otherwise = s

-- * This all is modeled after Hedgehog.Internal.Report

defaultAttr = Attr Default Default Default Default
redVivid = withForeColor defaultAttr brightRed
redDull = withForeColor defaultAttr red
redVividBold = flip withStyle bold $ withForeColor defaultAttr brightRed
yellowDull = withForeColor defaultAttr yellow
magentaDull = withForeColor defaultAttr magenta
greenDull = withForeColor defaultAttr green
blackVivid = withForeColor defaultAttr brightBlack

start = \case
  WaitingIcon -> defaultAttr
  WaitingHeader -> defaultAttr
  RunningIcon -> defaultAttr
  RunningHeader -> defaultAttr
  ShrinkingIcon -> redVivid
  ShrinkingHeader -> redVivid
  FailedIcon -> redVivid
  FailedText -> redVivid
  GaveUpIcon -> yellowDull
  GaveUpText -> yellowDull
  SuccessIcon -> greenDull
  SuccessText -> greenDull
  CoverageIcon -> yellowDull
  CoverageText -> yellowDull
  CoverageFill -> blackVivid

  DeclarationLocation -> defaultAttr

  StyledLineNo StyleDefault -> defaultAttr
  StyledSource StyleDefault -> defaultAttr
  StyledBorder StyleDefault -> defaultAttr

  StyledLineNo StyleAnnotation -> magentaDull
  StyledSource StyleAnnotation -> defaultAttr
  StyledBorder StyleAnnotation -> defaultAttr
  AnnotationGutter -> magentaDull
  AnnotationValue -> magentaDull

  StyledLineNo StyleFailure -> redVivid
  StyledSource StyleFailure -> redVividBold
  StyledBorder StyleFailure -> defaultAttr
  FailureArrows -> redVivid
  FailureMessage -> defaultAttr
  FailureGutter -> defaultAttr

  DiffPrefix -> defaultAttr
  DiffInfix -> defaultAttr
  DiffSuffix -> defaultAttr
  DiffSame -> defaultAttr
  DiffRemoved -> redDull
  DiffAdded -> greenDull

  ReproduceHeader -> defaultAttr
  ReproduceGutter -> defaultAttr
  ReproduceSource -> defaultAttr

end _ = [NewAttr defaultAttr]