[quickcheck: attempt at instance Arbitrary TExp
Helmut Grohne <grohne@cs.uni-bonn.de>**20150325160707
 Ignore-this: 654557a9b90e94001242be8b4f3f85cf
] hunk ./src/Tests.hs 13
+import qualified Data.Map as M
hunk ./src/Tests.hs 19
+import Syntax.Ppr (Pretty)
hunk ./src/Tests.hs 76
+simpleTExps :: [TExp]
+simpleTExps = map (uncurry TConE) . M.assocs $ ctx_types defaultContext
+
+type Env = M.Map Name Type
+
+genTExp :: Maybe Type -> Env -> Int -> QC.Gen (TExp, Env)
+genTExp t env size = QC.oneof gens >>= uncurry app
+  where andenv e = (e, env)
+        simple = map andenv $ maybe id (\t' -> filter ((t' ==) . typeOf)) t simpleTExps
+        conssimple = if null simple then id else (QC.elements simple:)
+        var = do t' <- maybe QC.arbitrary return t
+                 n <- QC.arbitrary
+                 if n `M.member` env then var
+                                   else QC.elements [(TVarE n t', M.insert n t' env),
+                                                     andenv (TWildE n t')]
+        fromenv = QC.elements . map (andenv . uncurry TVarE) $ M.assocs env
+        consenv = if M.null env then id else (fromenv:)
+        gens = conssimple $ consenv [var]
+        app e env' = if not . isFunT $ typeOf e then return (e, env') else (do
+            let argt = head . unArrowT $ typeOf e
+            (e', env'') <- genTExp (Just argt) env' (pred size)
+            app (tAppE e e') env'')
+
+instance QC.Arbitrary TExp where
+  arbitrary = fmap fst . QC.sized $ genTExp Nothing M.empty
+
+  shrink e@(TAppE {}) = tail $ unfoldTAppE e
+  shrink _ = []
+
hunk ./src/Tests.hs 113
-lggTypeAssociative :: Type -> Type -> Type -> QC.Property
-lggTypeAssociative t1 t2 t3 = runContext $ (do
+typeWitness :: Type
+typeWitness = undefined
+texpWitness :: TExp
+texpWitness = undefined
+
+lggAssociative :: (AUnify t, Pretty t, Term t) => t -> t -> t -> t -> QC.Property
+lggAssociative _witness t1 t2 t3 = runContext $ (do
hunk ./src/Tests.hs 126
-matchApply :: Type -> Type -> QC.Property
-matchApply t1 t2 = runContext $ (do
+matchApply :: (Term t, Unify t) => t -> t -> t -> QC.Property
+matchApply _witness t1 t2 = runContext $ (do
hunk ./src/Tests.hs 134
-    testProperty "Types: lgg [a, lgg [b, c]] == lgg [a, b, c]" lggTypeAssociative,
-    testProperty "Types: apply (match a b) b == a" matchApply
+    testProperty "Types: lgg [a, lgg [b, c]] == lgg [a, b, c]" (lggAssociative typeWitness),
+    testProperty "Exprs: lgg [a, lgg [b, c]] == lgg [a, b, c]" (lggAssociative texpWitness),
+    testProperty "Types: apply (match a b) b == a" (matchApply typeWitness),
+    testProperty "Exprs: apply (match a b) b == a" (matchApply texpWitness)