module Main where

import Test.Framework
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test)
import Text.PrettyPrint.Free.Internal

main :: IO ()
main = defaultMain [
         testGroup "Tests for each data constructor" conTests
       , testGroup "Tests for some combinators" codeTests
       , testGroup "Tests for the formatting algorithms" formatTests
       , testGroup "Tests for the code examples in the documentation" docTests
       ]

conTests :: [Test]
conTests = [
    testCase "Empty tests"   emptyTests
  , testCase "Char tests"    charTests
  , testCase "Text tests"    textTests
  , testCase "Line tests"    textTests
  , testCase "FlatAlt tests" flatAltTests
  , testCase "Cat tests"     catTests
  , testCase "Nest tests"    nestTests
  , testCase "Union tests"   unionTests
  , testCase "Column tests"  columnTests
  , testCase "Nesting tests" nestingTests
  , testCase "Columns tests" columnsTests
  , testCase "Ribbon tests"  ribbonTests
  ]

------------------------------------------------------------
-- We test the @Doc@ constructors.

assertPretty :: Int -> String -> String -> Doc e -> Assertion
assertPretty w desc str doc = assertEqual (desc ++ " (pretty)") str
                                $ displayS (renderPretty 1.0 w doc) ""

assertSmart :: Int -> String -> String -> Doc e -> Assertion
assertSmart w desc str doc = assertEqual (desc ++ " (smart)") str
                                $ displayS (renderSmart w doc) ""

assertRender :: Int -> String -> String -> Doc e -> Assertion
assertRender w desc str doc = do assertPretty w desc str doc
                                 assertSmart w desc str doc

emptyTests :: Assertion
emptyTests = assertRender 80 "Empty test 1" "" empty

charTests :: Assertion
charTests = assertRender 80 "Char test 1" "a" (char 'a')

textTests :: Assertion
textTests = assertRender 80 "Text test 1" "text..." (text "text...")

lineTests :: Assertion
lineTests = assertRender 80 "Line test 1" "\n" hardline

flatAltTests :: Assertion
flatAltTests = do assertRender 80 "FlatAlt test 1" "x"
                    $ flatAlt (text "x") (text "y")
                  assertRender 80 "FlatAlt test 2" "y"
                    $ flatten $ flatAlt (text "x") (text "y")

catTests :: Assertion
catTests = do assertRender 80 "Cat test 1" "some code"
                $ text "some" <> space <> text "code"

nestTests :: Assertion
nestTests = do assertRender 80 "Nest test 1" "foo bar"
                 $ text "foo" <+> nest 2 (text "bar")
               assertRender 80 "Nest test 2" "foo\n  bar"
                 $ text "foo" <> nest 2 (line <> text "bar")

unionTests :: Assertion
unionTests = do assertRender 80 "Union test 1" "foo bar"
                  $ text "foo" </> text "bar"
                assertRender 5 "Union test 2" "foo\nbar"
                  $ text "foo" </> text "bar"

columnTests :: Assertion
columnTests = do assertRender 80 "Column test 1" "foo 4"
                   $ text "foo" <+> (column $ \c -> pretty c)

nestingTests :: Assertion
nestingTests = do assertRender 80 "Nesting test 1" "foo 2"
                    $ text "foo" <+> (nest 2 $ nesting $ \n -> pretty n)

columnsTests :: Assertion
columnsTests = do assertRender 21 "Columns test 1" "foo 21"
                    $ text "foo" <+> (nest 2 $ columns $ \w -> pretty w)

ribbonTests :: Assertion
ribbonTests = do assertEqual "Ribbon test 1" "foo 32"
                   $ show (text "foo" <+> (ribbon $ \r -> pretty r))

------------------------------------------------------------
-- We test some combinators.

codeTests :: [Test]
codeTests = [
    testCase "@list@ tests"   listTests
  , testCase "@tupled@ tests" tupledTests
  ]

listTests :: Assertion
listTests = do assertRender 80 "@list@ test 1" "[1, 2, 3]"
                 $ pretty ([1, 2, 3] :: [Int])
               assertRender 5 "@list@ test 2" "[ 1\n, 2\n, 3 ]"
                 $ pretty ([1, 2, 3] :: [Int])

tupledTests :: Assertion
tupledTests = do assertRender 80 "@tupled@ test 1" "(1, True, a)"
                   $ pretty (1 :: Int, True, 'a')
                 assertRender 5 "@tupled@ test 2" "( 1\n, True\n, a )"
                   $ pretty (1 :: Int, True, 'a')

------------------------------------------------------------
-- We test some corner cases of the formatting algorithms on a prototypical
-- syntax for a scripting language (e.g. Python).

formatTests :: [Test]
formatTests = [
    testCase "@renderPretty@ test" renderPrettyTest
  , testCase "@renderSmart@ test"  renderSmartTest
  ]

data Syn = Call String [Syn]    -- name(syn, ..., syn)
         | Plus Syn Syn  -- syn + syn
         | List [Syn]    -- [syn, ..., syn]
         | Name String

instance Pretty Syn where
  pretty (Call n s) =
    text (n ++ "(") <> nest 2 (softbreak <> align body) <//> rparen
    where body = hcat $ punctuate (comma <> softline) (map pretty s)
  pretty (Plus s t) = nest 2 (pretty s) </> text "+" </> nest 2 (pretty t)
  pretty (List l) = list (map pretty l)
  pretty (Name n) = text n

deep :: Int -> Syn
deep 0 = List (map Name ["abc", "abcdef", "abcdef"])
deep i = Call "fun" [deep (i - 1)]

branch :: Int -> Syn
branch 0 = List (map Name ["abc", "abc"])
branch i | i < 3 = Call "fun" [branch (i - 1), branch (i - 1)]
         | otherwise = Call "fun" [branch (i - 1)]

wide :: Syn
wide = Call "aaaaaaaaaaa" [List $ map Name ["abc", "def", "ghi"]]

-- @renderPretty@ has only one line of lookahead, so it can not fit the
-- entire document within the pagewidth (20c), only the first line.
renderPrettyTest :: Assertion
renderPrettyTest = do assertPretty 20 "@renderPretty@ test 1" (concat [
                          "fun(fun(fun(fun(fun(\n"
                        , "                  [ abc\n"
                        , "                  , abcdef\n"
                        , "                  , abcdef ]\n"
                        , "                ))))\n"
                        , ")" ])
                        $ pretty (deep 5)
                      assertPretty 20 "@renderPretty@ test 2" (concat [
                          "fun(fun(fun([ abc\n"
                        , "            , abc ],\n"
                        , "            [ abc\n"
                        , "            , abc ]\n"
                        , "        ), fun([ abc\n"
                        , "               , abc ],\n"
                        , "               [ abc\n"
                        , "               , abc ]\n"
                        , "        )))" ])
                        $ pretty (branch 3)
                      assertPretty 20 "@renderPretty@ test 3" (concat [
                          "aaaaaaaaaaa([ abc\n"
                        , "            , def\n"
                        , "            , ghi ])" ])
                        $ pretty wide

-- @renderSmart@ has more sophisiticated lookahead, so it fits the entire
-- structure within the pagewidth (20c).
renderSmartTest :: Assertion
renderSmartTest = do assertSmart 20 "@renderSmart@ test 1" (concat [
                         "fun(\n"
                       , "  fun(\n"
                       , "    fun(\n"
                       , "      fun(\n"
                       , "        fun(\n"
                       , "          [ abc\n"
                       , "          , abcdef\n"
                       , "          , abcdef ]\n"
                       , "        )))))" ])
                       $ pretty (deep 5)
                     assertSmart 20 "@renderSmart@ test 2" (concat [
                         "fun(\n"
                       , "  fun(\n"
                       , "    fun(\n"
                       , "      fun(\n"
                       , "        fun([ abc\n"
                       , "            , abc ],\n"
                       , "            [ abc\n"
                       , "            , abc ]\n"
                       , "        ),\n"
                       , "        fun([ abc\n"
                       , "            , abc ],\n"
                       , "            [ abc\n"
                       , "            , abc ])\n"
                       , "      ))))" ])
                       $ pretty (branch 5)
                     assertSmart 20 "@renderSmart@ test 3" (concat [
                         "aaaaaaaaaaa(\n"
                       , "  [abc, def, ghi])" ])
                       $ pretty wide

------------------------------------------------------------
-- We test the code examples in the haddock comments.

docTests :: [Test]
docTests = [
    testCase "@fill@ test" fillTest
  , testCase "@fillBreak@ test" fillBreakTest
  , testCase "@hang@ test" hangTest
  , testCase "@align@ test" alignTest
  ]

types :: [(String, String)]
types = [ ("empty","Doc e")
        , ("nest","Int -> Doc e -> Doc e")
        , ("linebreak","Doc e") ]

fillTest :: Assertion
fillTest = do assertRender 80 "@fill@ test 1" (concat [
                  "let empty  :: Doc e\n"
                , "    nest   :: Int -> Doc e -> Doc e\n"
                , "    linebreak :: Doc e" ])
                $ text "let" <+> align (vcat (map ptype types))
              where ptype (name, tp) =
                      fill 6 (text name) <+> text "::" <+> text tp

fillBreakTest :: Assertion
fillBreakTest = do assertRender 80 "@fillBreak@ test 1" (concat [
                       "let empty  :: Doc e\n"
                     , "    nest   :: Int -> Doc e -> Doc e\n"
                     , "    linebreak\n"
                     , "           :: Doc e" ])
                     $ text "let" <+> align (vcat (map ptype types))
                where ptype (name, tp) =
                        fillBreak 6 (text name) <+> (text "::" <+> text tp)

hangTest :: Assertion
hangTest = do assertRender 20 "@hang@ test 1" (concat [
                  "the hang combinator\n"
                , "    indents these\n"
                , "    words !" ])
                $ hang 4 $ fillSep $ map text
                $ words "the hang combinator indents these words !"

alignTest :: Assertion
alignTest = do assertRender 20 "@align@ test 1" (concat [
                   "hi nice\n"
                 , "   world" ])
                 $ text "hi" <+> (text "nice" $$ text "world")
               where x $$ y = align $ x <> linebreak <> y
