{-# 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 Markup -> Image
renderHedgehogToImage Doc Markup
doc = Image -> Attr -> [Token] -> Image
foldTokens Image
emptyImage Attr
defaultAttr ([Token] -> Image) -> [Token] -> Image
forall a b. (a -> b) -> a -> b
$ Doc Markup -> [Token]
renderHedgehogToTokens Doc Markup
doc

foldTokens :: Image -> Attr -> [Token] -> Image
foldTokens Image
imageSoFar Attr
currentAttr ((Str Text
"\n"):[Token]
xs) = (if Image
imageSoFar Image -> Image -> Bool
forall a. Eq a => a -> a -> Bool
== Image
emptyImage then Attr -> Text -> Image
text Attr
defaultAttr Text
" " else Image
imageSoFar) Image -> Image -> Image
<-> Image -> Attr -> [Token] -> Image
foldTokens Image
emptyImage Attr
currentAttr [Token]
xs
foldTokens Image
imageSoFar Attr
currentAttr ((Str Text
s):[Token]
xs) = Image -> Attr -> [Token] -> Image
foldTokens (Image
imageSoFar Image -> Image -> Image
<|> Attr -> Text -> Image
text' Attr
currentAttr Text
s) Attr
currentAttr [Token]
xs
foldTokens Image
imageSoFar Attr
_currentAttr ((NewAttr Attr
attr):[Token]
xs) = Image -> Attr -> [Token] -> Image
foldTokens Image
imageSoFar Attr
attr [Token]
xs
foldTokens Image
imageSoFar Attr
_currentAttr [] = Image
imageSoFar

renderHedgehogToTokens :: Doc Markup -> [Token]
renderHedgehogToTokens :: Doc Markup -> [Token]
renderHedgehogToTokens Doc Markup
doc =
  Int -> Doc Markup -> Doc Markup
forall a. Int -> Doc a -> Doc a
WL.indent Int
0 Doc Markup
doc
  Doc Markup -> (Doc Markup -> SimpleDoc Markup) -> SimpleDoc Markup
forall a b. a -> (a -> b) -> b
& Int -> Doc Markup -> SimpleDoc Markup
forall a. Int -> Doc a -> SimpleDoc a
WL.renderSmart Int
100
  SimpleDoc Markup -> (SimpleDoc Markup -> [Token]) -> [Token]
forall a b. a -> (a -> b) -> b
& (Markup -> [Token])
-> (Markup -> [Token])
-> (String -> [Token])
-> SimpleDoc Markup
-> [Token]
forall o a.
Monoid o =>
(a -> o) -> (a -> o) -> (String -> o) -> SimpleDoc a -> o
WL.displayDecorated (\Markup
x -> [Attr -> Token
NewAttr (Attr -> Token) -> Attr -> Token
forall a b. (a -> b) -> a -> b
$ Markup -> Attr
start Markup
x]) Markup -> [Token]
forall {p}. p -> [Token]
end (\String
x -> [Text -> Token
Str (String -> Text
T.pack String
x)])
  [Token] -> ([Token] -> [Token]) -> [Token]
forall a b. a -> (a -> b) -> b
& [Token] -> [Token]
joinAdjacentStrings
  [Token] -> ([Token] -> [Token]) -> [Token]
forall a b. a -> (a -> b) -> b
& [Token] -> [Token]
splitNewlines
  where
    joinAdjacentStrings :: [Token] -> [Token]
joinAdjacentStrings ((Str Text
s1):(Str Text
s2):[Token]
xs) = [Token] -> [Token]
joinAdjacentStrings (Text -> Token
Str (Text
s1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s2) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
xs)
    joinAdjacentStrings (Token
x:[Token]
xs) = Token
x Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
joinAdjacentStrings [Token]
xs
    joinAdjacentStrings [] = []

    splitNewlines :: [Token] -> [Token]
    splitNewlines :: [Token] -> [Token]
splitNewlines ((Str Text
s):[Token]
xs) = [Text -> Token
Str Text
s' | Text
s' <- [Text]
parts, Text
s' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
""] [Token] -> [Token] -> [Token]
forall a. Semigroup a => a -> a -> a
<> [Token] -> [Token]
splitNewlines [Token]
xs
      where parts :: [Text]
parts = Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
L.intersperse Text
"\n" ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"\n" Text
s
    splitNewlines (Token
x:[Token]
xs) = Token
x Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> [Token]
splitNewlines [Token]
xs
    splitNewlines [] = []

data Token = Str T.Text
           | NewAttr Attr
  deriving (Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Token -> ShowS
showsPrec :: Int -> Token -> ShowS
$cshow :: Token -> String
show :: Token -> String
$cshowList :: [Token] -> ShowS
showList :: [Token] -> ShowS
Show)

dedent :: Int -> String -> String
dedent :: Int -> ShowS
dedent Int
n String
s
  | (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ') String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
s = Int -> ShowS
forall a. Int -> [a] -> [a]
L.drop Int
n String
s
  | Bool
otherwise = String
s

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

defaultAttr :: Attr
defaultAttr = MaybeDefault Style
-> MaybeDefault Color
-> MaybeDefault Color
-> MaybeDefault Text
-> Attr
Attr MaybeDefault Style
forall v. MaybeDefault v
Default MaybeDefault Color
forall v. MaybeDefault v
Default MaybeDefault Color
forall v. MaybeDefault v
Default MaybeDefault Text
forall v. MaybeDefault v
Default
redVivid :: Attr
redVivid = Attr -> Color -> Attr
withForeColor Attr
defaultAttr Color
brightRed
redDull :: Attr
redDull = Attr -> Color -> Attr
withForeColor Attr
defaultAttr Color
red
redVividBold :: Attr
redVividBold = (Attr -> Style -> Attr) -> Style -> Attr -> Attr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Attr -> Style -> Attr
withStyle Style
bold (Attr -> Attr) -> Attr -> Attr
forall a b. (a -> b) -> a -> b
$ Attr -> Color -> Attr
withForeColor Attr
defaultAttr Color
brightRed
yellowDull :: Attr
yellowDull = Attr -> Color -> Attr
withForeColor Attr
defaultAttr Color
yellow
magentaDull :: Attr
magentaDull = Attr -> Color -> Attr
withForeColor Attr
defaultAttr Color
magenta
greenDull :: Attr
greenDull = Attr -> Color -> Attr
withForeColor Attr
defaultAttr Color
green
blackVivid :: Attr
blackVivid = Attr -> Color -> Attr
withForeColor Attr
defaultAttr Color
brightBlack

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

  Markup
DeclarationLocation -> Attr
defaultAttr

  StyledLineNo Style
StyleDefault -> Attr
defaultAttr
  StyledSource Style
StyleDefault -> Attr
defaultAttr
  StyledBorder Style
StyleDefault -> Attr
defaultAttr

  StyledLineNo Style
StyleAnnotation -> Attr
magentaDull
  StyledSource Style
StyleAnnotation -> Attr
defaultAttr
  StyledBorder Style
StyleAnnotation -> Attr
defaultAttr
  Markup
AnnotationGutter -> Attr
magentaDull
  Markup
AnnotationValue -> Attr
magentaDull

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

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

  Markup
ReproduceHeader -> Attr
defaultAttr
  Markup
ReproduceGutter -> Attr
defaultAttr
  Markup
ReproduceSource -> Attr
defaultAttr

end :: p -> [Token]
end p
_ = [Attr -> Token
NewAttr Attr
defaultAttr]