[add a failing unit test suite
Helmut Grohne <grohne@cs.uni-bonn.de>**20150305162642
 Ignore-this: 7df433961fcd5f12206a7a0df0fb67c3
] hunk ./igor2.cabal 29
+test-suite igor2-test
+  type: exitcode-stdio-1.0
+  hs-source-dirs: src
+  main-is: Tests.hs
+  build-depends:
+    test-framework,
+    test-framework-quickcheck2,
+    QuickCheck
+
addfile ./src/Tests.hs
hunk ./src/Tests.hs 1
+module Main where
+
+import Test.Framework (defaultMain)
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+import qualified Test.QuickCheck as QC
+import qualified Test.QuickCheck.Property as QCP
+
+import Data.Functor ((<$>))
+import Control.Applicative ((<*>))
+import Control.Monad (liftM, liftM2)
+import Control.Monad.Reader (runReader)
+
+import Language.Haskell.TH.Syntax (Name, mkName)
+
+import Syntax
+
+instance QC.Arbitrary Name where
+  arbitrary = mkName <$> QC.listOf1 (QC.elements ['a'..'z'])
+  shrink n = case drop 1 (show n) of { [] -> []; n' -> [mkName n'] }
+
+instance QC.Arbitrary Type where
+  arbitrary = QC.sized arbType
+    where arbType 0 = QC.elements [VarT, ConT] <*> QC.arbitrary
+          arbType n = QC.oneof [arbType 0, AppT <$> arbType (n `div` 2) <*> arbType (n `div` 2)]
+  shrink (AppT a b)      = a : b : [ AppT a' b' | a' <- QC.shrink a, b' <- QC.shrink b ]
+  shrink (ForallT _ _ t) = [t]
+  shrink (VarT n)        = map VarT (QC.shrink n)
+  shrink (ConT n)        = map ConT (QC.shrink n)
+
+qcCompare :: (Show a) => (a -> a -> Bool) -> a -> a -> QC.Property
+qcCompare eq x y =
+  QC.printTestCase ("Left: " ++ show x) $
+  QC.printTestCase ("Right: " ++ show y) $
+  x `eq` y
+
+lggTypeAssociative :: Type -> Type -> Type -> QC.Property
+lggTypeAssociative t1 t2 t3 = flip runReader defaultContext $ (do
+    t23   <- lgg [t2, t3]
+    t123  <- lgg [t1, t23]
+    t123' <- lgg [t1, t2, t3]
+    return $ qcCompare equal t123 t123'
+    ) `safeCatchErrorC`
+    QC.discard -- Probably an invalid type like: AppT (VarT x) (VarT x)
+
+tests = [
+    testProperty "Types: lgg [a, lgg [b, c]] == lgg [a, b, c]" lggTypeAssociative
+    ]
+
+main = defaultMain tests