From 570d8ff08c7007c4fffd345c9bf2057201a0bdd4 Mon Sep 17 00:00:00 2001
From: John MacFarlane <jgm@berkeley.edu>
Date: Sat, 29 Jan 2011 11:24:16 -0800
Subject: Moved tests to src.

---
 src/Tests/Helpers.hs | 116 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 116 insertions(+)
 create mode 100644 src/Tests/Helpers.hs

(limited to 'src/Tests/Helpers.hs')

diff --git a/src/Tests/Helpers.hs b/src/Tests/Helpers.hs
new file mode 100644
index 000000000..b8d6b83a7
--- /dev/null
+++ b/src/Tests/Helpers.hs
@@ -0,0 +1,116 @@
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, TemplateHaskell #-}
+-- Utility functions for the test suite.
+
+module Tests.Helpers ( lit
+                     , file
+                     , test
+                     , (=?>)
+                     , property
+                     , ToString(..)
+                     , ToPandoc(..)
+                     )
+                     where
+
+import Text.Pandoc.Definition
+import Text.Pandoc.Builder (Inlines, Blocks, doc, plain)
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.Framework.Providers.QuickCheck2
+import Test.HUnit (assertBool)
+import Text.Pandoc.Shared (normalize, defaultWriterOptions,
+                           WriterOptions(..), removeTrailingSpace)
+import Text.Pandoc.Writers.Native (writeNative)
+import Language.Haskell.TH.Quote (QuasiQuoter(..))
+import Language.Haskell.TH.Syntax (Q, runIO)
+import qualified Test.QuickCheck.Property as QP
+import System.Console.ANSI
+import Data.Algorithm.Diff
+
+lit :: QuasiQuoter
+lit = QuasiQuoter {
+           quoteExp = (\a -> let b = rnl a in [|b|]) . filter (/= '\r')
+         , quotePat = error "Cannot use lit as a pattern"
+         }
+       where rnl ('\n':xs) = xs
+             rnl xs        = xs
+
+file :: QuasiQuoter
+file = quoteFile lit
+
+-- adapted from TH 2.5 code
+quoteFile :: QuasiQuoter -> QuasiQuoter
+quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp }) =
+  QuasiQuoter { quoteExp = get qe, quotePat = get qp }
+  where
+    get :: (String -> Q a) -> String -> Q a
+    get old_quoter file_name = do { file_cts <- runIO (readFile file_name)
+                                  ; old_quoter file_cts }
+
+test :: (ToString a, ToString b, ToString c)
+     => (a -> b)  -- ^ function to test
+     -> String    -- ^ name of test case
+     -> (a, c)    -- ^ (input, expected value)
+     -> Test
+test fn name (input, expected) =
+  testCase name $ assertBool msg (actual' == expected')
+     where msg = nl ++ dashes "input" ++ nl ++ input' ++ nl ++
+                 dashes "expected" ++ nl ++ expected'' ++
+                 dashes "got" ++ nl ++ actual'' ++
+                 dashes ""
+           nl = "\n"
+           input'  = toString input
+           actual' = toString $ fn input
+           expected' = toString expected
+           diff = getDiff (lines expected') (lines actual')
+           expected'' = unlines $ map vividize $ filter (\(d,_) -> d /= S) diff
+           actual''   = unlines $ map vividize $ filter (\(d,_) -> d /= F) diff
+           dashes "" = replicate 72 '-'
+           dashes x  = replicate (72 - length x - 5) '-' ++ " " ++ x ++ " ---"
+
+vividize :: (DI,String) -> String
+vividize (B,s) = s
+vividize (_,s) = vivid s
+
+property :: QP.Testable a => TestName -> a -> Test
+property = testProperty
+
+vivid :: String -> String
+vivid s = setSGRCode [SetColor Background Dull Red
+                     , SetColor Foreground Vivid White] ++ s
+          ++ setSGRCode [Reset]
+
+infix 6 =?>
+(=?>) :: a -> b -> (a,b)
+x =?> y = (x, y)
+
+class ToString a where
+  toString :: a -> String
+
+instance ToString Pandoc where
+  toString d = writeNative defaultWriterOptions{ writerStandalone = s }
+               $ toPandoc d
+   where s = case d of
+                  (Pandoc (Meta [] [] []) _) -> False
+                  _                          -> True
+
+instance ToString Blocks where
+  toString = writeNative defaultWriterOptions . toPandoc
+
+instance ToString Inlines where
+  toString = removeTrailingSpace . writeNative defaultWriterOptions .
+             toPandoc
+
+instance ToString String where
+  toString = id
+
+class ToPandoc a where
+  toPandoc :: a -> Pandoc
+
+instance ToPandoc Pandoc where
+  toPandoc = normalize
+
+instance ToPandoc Blocks where
+  toPandoc = normalize . doc
+
+instance ToPandoc Inlines where
+  toPandoc = normalize . doc . plain
-- 
cgit v1.2.3