module Test.DocTest.Base (
    checkResult,
    ExpectedResult,
    Result(..),
    ExpectedLine(..),
    LineChunk(..),
    ) where

import Data.List (isPrefixOf)
import Data.Char (isSpace, isPrint)


stripEnd :: String -> String
stripEnd :: String -> String
stripEnd = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse


data LineChunk = LineChunk String | WildCardChunk
  deriving (Int -> LineChunk -> String -> String
[LineChunk] -> String -> String
LineChunk -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LineChunk] -> String -> String
$cshowList :: [LineChunk] -> String -> String
show :: LineChunk -> String
$cshow :: LineChunk -> String
showsPrec :: Int -> LineChunk -> String -> String
$cshowsPrec :: Int -> LineChunk -> String -> String
Show, LineChunk -> LineChunk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LineChunk -> LineChunk -> Bool
$c/= :: LineChunk -> LineChunk -> Bool
== :: LineChunk -> LineChunk -> Bool
$c== :: LineChunk -> LineChunk -> Bool
Eq)

data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine
  deriving (Int -> ExpectedLine -> String -> String
[ExpectedLine] -> String -> String
ExpectedLine -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ExpectedLine] -> String -> String
$cshowList :: [ExpectedLine] -> String -> String
show :: ExpectedLine -> String
$cshow :: ExpectedLine -> String
showsPrec :: Int -> ExpectedLine -> String -> String
$cshowsPrec :: Int -> ExpectedLine -> String -> String
Show, ExpectedLine -> ExpectedLine -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExpectedLine -> ExpectedLine -> Bool
$c/= :: ExpectedLine -> ExpectedLine -> Bool
== :: ExpectedLine -> ExpectedLine -> Bool
$c== :: ExpectedLine -> ExpectedLine -> Bool
Eq)

type ExpectedResult = [ExpectedLine]


maxBy :: (Ord a) => (b -> a) -> b -> b -> b
maxBy :: forall a b. Ord a => (b -> a) -> b -> b -> b
maxBy b -> a
f b
x b
y = case forall a. Ord a => a -> a -> Ordering
compare (b -> a
f b
x) (b -> a
f b
y) of
  Ordering
LT -> b
y
  Ordering
EQ -> b
x
  Ordering
GT -> b
x

data Result = Equal | NotEqual [String]
  deriving (Result -> Result -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: Result -> Result -> Bool
Eq, Int -> Result -> String -> String
[Result] -> String -> String
Result -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Result] -> String -> String
$cshowList :: [Result] -> String -> String
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> String -> String
$cshowsPrec :: Int -> Result -> String -> String
Show)

checkResult :: ExpectedResult -> [String] -> Result
checkResult :: [ExpectedLine] -> [String] -> Result
checkResult [ExpectedLine]
expected_ [String]
actual_ =
  case [ExpectedLine]
expected [ExpectedLine] -> [String] -> Match LinesDivergence
`matches` [String]
actual of
  Match LinesDivergence
Full            -> Result
Equal
  Partial LinesDivergence
partial -> [String] -> Result
NotEqual ([ExpectedLine] -> [String] -> LinesDivergence -> [String]
formatNotEqual [ExpectedLine]
expected [String]
actual LinesDivergence
partial)
  where
    -- use show to escape special characters in output lines if any output line
    -- contains any unsafe character
    escapeOutput :: String -> String
escapeOutput
      | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSafe) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String]
expectedAsString forall a. [a] -> [a] -> [a]
++ [String]
actual_) = forall a. [a] -> [a]
init forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
stripEnd
      | Bool
otherwise = forall a. a -> a
id

    actual :: [String]
    actual :: [String]
actual = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
escapeOutput [String]
actual_

    expected :: ExpectedResult
    expected :: [ExpectedLine]
expected = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> String) -> ExpectedLine -> ExpectedLine
transformExcpectedLine String -> String
escapeOutput) [ExpectedLine]
expected_

    expectedAsString :: [String]
    expectedAsString :: [String]
expectedAsString = forall a b. (a -> b) -> [a] -> [b]
map (\ExpectedLine
x -> case ExpectedLine
x of
        ExpectedLine [LineChunk]
str -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LineChunk -> String
lineChunkToString [LineChunk]
str
        ExpectedLine
WildCardLine -> String
"..." ) [ExpectedLine]
expected_

    isSafe :: Char -> Bool
    isSafe :: Char -> Bool
isSafe Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| (Char -> Bool
isPrint Char
c Bool -> Bool -> Bool
&& (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) Char
c)

    chunksMatch :: [LineChunk] -> String -> Match ChunksDivergence
    chunksMatch :: [LineChunk] -> String -> Match ChunksDivergence
chunksMatch [] String
"" = forall a. Match a
Full
    chunksMatch [LineChunk String
xs] String
ys =
      if String -> String
stripEnd String
xs forall a. Eq a => a -> a -> Bool
== String -> String
stripEnd String
ys
      then forall a. Match a
Full
      else forall a. a -> Match a
Partial forall a b. (a -> b) -> a -> b
$ String -> String -> ChunksDivergence
matchingPrefix String
xs String
ys
    chunksMatch (LineChunk String
x : [LineChunk]
xs) String
ys =
      if String
x forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
ys
      then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> ChunksDivergence -> ChunksDivergence
prependText String
x) forall a b. (a -> b) -> a -> b
$ ([LineChunk]
xs [LineChunk] -> String -> Match ChunksDivergence
`chunksMatch` forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x) String
ys)
      else forall a. a -> Match a
Partial forall a b. (a -> b) -> a -> b
$ String -> String -> ChunksDivergence
matchingPrefix String
x String
ys
    chunksMatch zs :: [LineChunk]
zs@(LineChunk
WildCardChunk : [LineChunk]
xs) (Char
_:String
ys) =
      -- Prefer longer matches.
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChunksDivergence -> ChunksDivergence
prependWildcard forall a b. (a -> b) -> a -> b
$ forall a b. Ord a => (b -> a) -> b -> b -> b
maxBy
        (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChunksDivergence -> String
matchText)
        ([LineChunk] -> String -> Match ChunksDivergence
chunksMatch [LineChunk]
xs String
ys)
        ([LineChunk] -> String -> Match ChunksDivergence
chunksMatch [LineChunk]
zs String
ys)
    chunksMatch [LineChunk
WildCardChunk] [] = forall a. Match a
Full
    chunksMatch (LineChunk
WildCardChunk:[LineChunk]
_) [] = forall a. a -> Match a
Partial (String -> String -> ChunksDivergence
ChunksDivergence String
"" String
"")
    chunksMatch [] (Char
_:String
_) = forall a. a -> Match a
Partial (String -> String -> ChunksDivergence
ChunksDivergence String
"" String
"")

    matchingPrefix :: String -> String -> ChunksDivergence
matchingPrefix String
xs String
ys =
      let common :: String
common = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst (forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(Char
x, Char
y) -> Char
x forall a. Eq a => a -> a -> Bool
== Char
y) (String
xs forall a b. [a] -> [b] -> [(a, b)]
`zip` String
ys)) in
      String -> String -> ChunksDivergence
ChunksDivergence String
common String
common

    matches :: ExpectedResult -> [String] -> Match LinesDivergence
    matches :: [ExpectedLine] -> [String] -> Match LinesDivergence
matches (ExpectedLine [LineChunk]
x : [ExpectedLine]
xs) (String
y : [String]
ys) =
      case [LineChunk]
x [LineChunk] -> String -> Match ChunksDivergence
`chunksMatch` String
y of
      Match ChunksDivergence
Full -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LinesDivergence -> LinesDivergence
incLineNo forall a b. (a -> b) -> a -> b
$ [ExpectedLine]
xs [ExpectedLine] -> [String] -> Match LinesDivergence
`matches` [String]
ys
      Partial ChunksDivergence
partial -> forall a. a -> Match a
Partial (Int -> String -> LinesDivergence
LinesDivergence Int
1 (ChunksDivergence -> String
expandedWildcards ChunksDivergence
partial))
    matches zs :: [ExpectedLine]
zs@(ExpectedLine
WildCardLine : [ExpectedLine]
xs) us :: [String]
us@(String
_ : [String]
ys) =
      -- Prefer longer matches, and later ones of equal length.
      let matchWithoutWC :: Match LinesDivergence
matchWithoutWC = [ExpectedLine]
xs [ExpectedLine] -> [String] -> Match LinesDivergence
`matches` [String]
us in
      let matchWithWC :: Match LinesDivergence
matchWithWC    = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LinesDivergence -> LinesDivergence
incLineNo ([ExpectedLine]
zs [ExpectedLine] -> [String] -> Match LinesDivergence
`matches` [String]
ys) in
      let key :: LinesDivergence -> (Int, Int)
key (LinesDivergence Int
lineNo String
line) = (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
line, Int
lineNo) in
      forall a b. Ord a => (b -> a) -> b -> b -> b
maxBy (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LinesDivergence -> (Int, Int)
key) Match LinesDivergence
matchWithoutWC Match LinesDivergence
matchWithWC
    matches [ExpectedLine
WildCardLine] [] = forall a. Match a
Full
    matches [] [] = forall a. Match a
Full
    matches [] [String]
_  = forall a. a -> Match a
Partial (Int -> String -> LinesDivergence
LinesDivergence Int
1 String
"")
    matches [ExpectedLine]
_  [] = forall a. a -> Match a
Partial (Int -> String -> LinesDivergence
LinesDivergence Int
1 String
"")

-- Note: order of constructors matters, so that full matches sort as
-- greater than partial.
data Match a = Partial a | Full
  deriving (Match a -> Match a -> Bool
forall a. Eq a => Match a -> Match a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Match a -> Match a -> Bool
$c/= :: forall a. Eq a => Match a -> Match a -> Bool
== :: Match a -> Match a -> Bool
$c== :: forall a. Eq a => Match a -> Match a -> Bool
Eq, Match a -> Match a -> Bool
Match a -> Match a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Match a)
forall a. Ord a => Match a -> Match a -> Bool
forall a. Ord a => Match a -> Match a -> Ordering
forall a. Ord a => Match a -> Match a -> Match a
min :: Match a -> Match a -> Match a
$cmin :: forall a. Ord a => Match a -> Match a -> Match a
max :: Match a -> Match a -> Match a
$cmax :: forall a. Ord a => Match a -> Match a -> Match a
>= :: Match a -> Match a -> Bool
$c>= :: forall a. Ord a => Match a -> Match a -> Bool
> :: Match a -> Match a -> Bool
$c> :: forall a. Ord a => Match a -> Match a -> Bool
<= :: Match a -> Match a -> Bool
$c<= :: forall a. Ord a => Match a -> Match a -> Bool
< :: Match a -> Match a -> Bool
$c< :: forall a. Ord a => Match a -> Match a -> Bool
compare :: Match a -> Match a -> Ordering
$ccompare :: forall a. Ord a => Match a -> Match a -> Ordering
Ord, Int -> Match a -> String -> String
forall a. Show a => Int -> Match a -> String -> String
forall a. Show a => [Match a] -> String -> String
forall a. Show a => Match a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Match a] -> String -> String
$cshowList :: forall a. Show a => [Match a] -> String -> String
show :: Match a -> String
$cshow :: forall a. Show a => Match a -> String
showsPrec :: Int -> Match a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> Match a -> String -> String
Show)

instance Functor Match where
  fmap :: forall a b. (a -> b) -> Match a -> Match b
fmap a -> b
f (Partial a
a) = forall a. a -> Match a
Partial (a -> b
f a
a)
  fmap a -> b
_ Match a
Full = forall a. Match a
Full

data ChunksDivergence = ChunksDivergence { ChunksDivergence -> String
matchText :: String, ChunksDivergence -> String
expandedWildcards :: String }
  deriving (Int -> ChunksDivergence -> String -> String
[ChunksDivergence] -> String -> String
ChunksDivergence -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ChunksDivergence] -> String -> String
$cshowList :: [ChunksDivergence] -> String -> String
show :: ChunksDivergence -> String
$cshow :: ChunksDivergence -> String
showsPrec :: Int -> ChunksDivergence -> String -> String
$cshowsPrec :: Int -> ChunksDivergence -> String -> String
Show)

prependText :: String -> ChunksDivergence -> ChunksDivergence
prependText :: String -> ChunksDivergence -> ChunksDivergence
prependText String
s (ChunksDivergence String
mt String
wct) = String -> String -> ChunksDivergence
ChunksDivergence (String
sforall a. [a] -> [a] -> [a]
++String
mt) (String
sforall a. [a] -> [a] -> [a]
++String
wct)

prependWildcard :: ChunksDivergence -> ChunksDivergence
prependWildcard :: ChunksDivergence -> ChunksDivergence
prependWildcard (ChunksDivergence String
mt String
wct) = String -> String -> ChunksDivergence
ChunksDivergence String
mt (Char
'.'forall a. a -> [a] -> [a]
:String
wct)

data LinesDivergence = LinesDivergence { LinesDivergence -> Int
_mismatchLineNo :: Int, LinesDivergence -> String
_partialLine :: String }
  deriving (Int -> LinesDivergence -> String -> String
[LinesDivergence] -> String -> String
LinesDivergence -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LinesDivergence] -> String -> String
$cshowList :: [LinesDivergence] -> String -> String
show :: LinesDivergence -> String
$cshow :: LinesDivergence -> String
showsPrec :: Int -> LinesDivergence -> String -> String
$cshowsPrec :: Int -> LinesDivergence -> String -> String
Show)

incLineNo :: LinesDivergence -> LinesDivergence
incLineNo :: LinesDivergence -> LinesDivergence
incLineNo (LinesDivergence Int
lineNo String
partialLineMatch) = Int -> String -> LinesDivergence
LinesDivergence (Int
lineNo forall a. Num a => a -> a -> a
+ Int
1) String
partialLineMatch

formatNotEqual :: ExpectedResult -> [String] -> LinesDivergence -> [String]
formatNotEqual :: [ExpectedLine] -> [String] -> LinesDivergence -> [String]
formatNotEqual [ExpectedLine]
expected_ [String]
actual LinesDivergence
partial = String -> [String] -> [String]
formatLines String
"expected: " [String]
expected forall a. [a] -> [a] -> [a]
++ String -> [String] -> [String]
formatLines String
" but got: " (Bool -> LinesDivergence -> [String] -> [String]
lineMarker Bool
wildcard LinesDivergence
partial [String]
actual)
  where
    expected :: [String]
    expected :: [String]
expected = forall a b. (a -> b) -> [a] -> [b]
map (\ExpectedLine
x -> case ExpectedLine
x of
        ExpectedLine [LineChunk]
str -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LineChunk -> String
lineChunkToString [LineChunk]
str
        ExpectedLine
WildCardLine -> String
"..." ) [ExpectedLine]
expected_

    formatLines :: String -> [String] -> [String]
    formatLines :: String -> [String] -> [String]
formatLines String
message [String]
xs = case [String]
xs of
      String
y:[String]
ys -> (String
message forall a. [a] -> [a] -> [a]
++ String
y) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (String
padding forall a. [a] -> [a] -> [a]
++) [String]
ys
      []   -> [String
message]
      where
        padding :: String
padding = forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
message) Char
' '

    wildcard :: Bool
    wildcard :: Bool
wildcard = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ExpectedLine
x -> case ExpectedLine
x of
        ExpectedLine [LineChunk]
xs -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\LineChunk
y -> case LineChunk
y of { LineChunk
WildCardChunk -> Bool
True; LineChunk
_ -> Bool
False }) [LineChunk]
xs
        ExpectedLine
WildCardLine -> Bool
True ) [ExpectedLine]
expected_

lineChunkToString :: LineChunk -> String
lineChunkToString :: LineChunk -> String
lineChunkToString LineChunk
WildCardChunk = String
"..."
lineChunkToString (LineChunk String
str) = String
str

transformExcpectedLine :: (String -> String) -> ExpectedLine -> ExpectedLine
transformExcpectedLine :: (String -> String) -> ExpectedLine -> ExpectedLine
transformExcpectedLine String -> String
f (ExpectedLine [LineChunk]
xs) =
  [LineChunk] -> ExpectedLine
ExpectedLine forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\LineChunk
el -> case LineChunk
el of
    LineChunk String
s -> String -> LineChunk
LineChunk forall a b. (a -> b) -> a -> b
$ String -> String
f String
s
    LineChunk
WildCardChunk -> LineChunk
WildCardChunk
  ) [LineChunk]
xs
transformExcpectedLine String -> String
_ ExpectedLine
WildCardLine = ExpectedLine
WildCardLine

lineMarker :: Bool -> LinesDivergence -> [String] -> [String]
lineMarker :: Bool -> LinesDivergence -> [String] -> [String]
lineMarker Bool
wildcard (LinesDivergence Int
row String
expanded) [String]
actual =
  let ([String]
pre, [String]
post) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
row [String]
actual in
  [String]
pre forall a. [a] -> [a] -> [a]
++
  [(if Bool
wildcard Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length String
expanded forall a. Ord a => a -> a -> Bool
> Int
30
    -- show expanded pattern if match is long, to help understanding what matched what
    then String
expanded
    else forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
expanded) Char
' ') forall a. [a] -> [a] -> [a]
++ String
"^"] forall a. [a] -> [a] -> [a]
++
  [String]
post