Test.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Test the pretty printer.
module Main where

import           Control.Applicative    ( (<|>) )
import           Control.Monad          ( forM_, guard )

import           Data.Maybe             ( mapMaybe )
import qualified Data.Text              as T
import           Data.Text.Lazy         ( Text )
import qualified Data.Text.Lazy         as TL
import qualified Data.Text.Lazy.Builder as TB ( toLazyText )
import qualified Data.Text.Lazy.IO      as TIO

import           Floskell

import           Language.Haskell.Exts  ( Language(Haskell2010) )

import           Markdone               ( Markdone(..) )
import qualified Markdone               as MD

import           System.Environment     ( getArgs )

import           Test.Hspec

data TestTree =
    TestSection String [TestTree] | TestSnippet Text | TestMismatchMarker

-- | Prints a string without quoting and escaping.
newtype Readable = Readable Text
    deriving ( Eq )

instance Show Readable where
    show (Readable x) = "\n" ++ TL.unpack x

-- | Version of 'shouldBe' that prints strings in a readable way,
-- better for our use-case.
shouldBeReadable :: Text -> Text -> Expectation
shouldBeReadable x y = Readable x `shouldBe` Readable y

haskell :: Text
haskell = "haskell"

referenceFile :: Style -> String
referenceFile style = "styles/" ++ name ++ ".md"
  where
    name = T.unpack $ styleName style

loadMarkdone :: String -> IO [Markdone]
loadMarkdone filename = do
    bytes <- TIO.readFile filename
    MD.parse (MD.tokenize bytes)

saveMarkdone :: String -> [Markdone] -> IO ()
saveMarkdone filename doc =
    TIO.writeFile filename . TB.toLazyText $ MD.print doc

-- | Extract code snippets from a Markdone document.
extractSnippets :: Text -> [Markdone] -> [TestTree]
extractSnippets lang = mapMaybe convert
  where
    convert (Section name children) = return $ TestSection (TL.unpack name) $
        extractSnippets lang children
    convert (CodeFence l c) = do
        guard $ l == lang
        return $ TestSnippet c
    convert _ = Nothing

-- | Load haskell code snippets from Markdone document.
loadSnippets :: String -> IO [TestTree]
loadSnippets filename = do
    doc <- loadMarkdone filename
    return $ extractSnippets haskell doc

disabled :: T.Text -> [Int] -> Maybe String
disabled style path = lookup (Just style, path) disabledTests
    <|> lookup (Nothing :: Maybe T.Text, path) disabledTests
  where
    disabledTests =
        []
#if MIN_VERSION_haskell_src_exts(1,21,0)
#else
        ++ [ ((Nothing, [ 2, 3, 4, 1 ]), "requires haskell-src-exts >=1.21.0")
           ]
#if MIN_VERSION_haskell_src_exts(1,20,0)
#else
        ++ [ ((Nothing, [ 2, 3, 6, 1 ]), "requires haskell-src-exts >=1.20.0")
           , ((Nothing, [ 2, 3, 11, 1 ]), "requires haskell-src-exts >=1.20.0")
           , ((Nothing, [ 2, 3, 12, 1 ]), "requires haskell-src-exts >=1.20.0")
           , ((Nothing, [ 2, 4, 1, 1 ]), "requires haskell-src-exts >=1.20.0")
           , ((Nothing, [ 2, 4, 9, 1 ]), "requires haskell-src-exts >=1.20.0")
           ]
#endif
#endif

-- | Convert the Markdone document to Spec benchmarks.
toSpec :: Style -> [Int] -> [TestTree] -> [TestTree] -> Spec
toSpec style path inp ref =
    forM_ (zip3 [ 1 :: Int .. ] inp (ref ++ repeat TestMismatchMarker)) $ \case
        (n, TestSection title children, TestSection _ children') ->
            describe (title ++ show (path ++ [ n ])) $
            toSpec style (path ++ [ n ]) children children'
        (n, TestSnippet code, TestSnippet code') ->
            case disabled (styleName style) (path ++ [ n ]) of
                Just msg -> it "Disabled" $ pendingWith msg
                Nothing -> do
                    it (name n "formats as expected") $
                        case reformatSnippet style code of
                            Left e -> error e
                            Right b -> b `shouldBeReadable` code'
                    it (name n "formatting is idempotent") $
                        case reformatSnippet style code of
                            Left e -> error e
                            Right b -> case reformatSnippet style b of
                                Left e -> error e
                                Right b' -> b' `shouldBeReadable` b
        (n, _, _) -> error $ name n "structure mismatch in reference file"
  where
    name n desc = "Snippet " ++ show n ++ " - " ++ desc

-- | Main tests.
testAll :: IO ()
testAll = do
    input <- loadSnippets "TEST.md"
    refs <- mapM loadRef styles
    hspec $ forM_ refs $
        \(name, style, ref) -> context name $ toSpec style [] input ref
  where
    loadRef style = do
        let name = T.unpack $ styleName style
        tree <- loadSnippets $ referenceFile style
        return (name, style, tree)

reformatSnippet :: Style -> Text -> Either String Text
reformatSnippet style =
    reformat (AppConfig style Haskell2010 defaultExtensions [])
             (Just "TEST.md")

regenerate :: Style -> [Markdone] -> [Markdone]
regenerate style = map fmt
  where
    fmt (CodeFence lang code) =
        if lang == haskell
        then CodeFence lang $ either (TL.pack . ("-- " ++) . show) id $
            reformatSnippet style code
        else CodeFence lang code
    fmt (Section heading children) =
        Section heading $ regenerate style children
    fmt x = x

-- | Regenerate style reference files.
regenerateAll :: IO ()
regenerateAll = do
    doc <- loadMarkdone "TEST.md"
    forM_ styles $ \style -> saveMarkdone (referenceFile style) $
        regenerate style doc

main :: IO ()
main = do
    args <- getArgs
    case args of
        [ "regenerate" ] -> regenerateAll
        _ -> testAll