tests/Test/HM/Term.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2
   3 module Test.Term where
   4
   5 import Test.QuickCheck
   6 import Control.Applicative
   7 import Lambda.Parser.Fancy
   8 import Lambda.Term
   9
  10 cP :: Term
  11 cP = tRead "(λa d c.(λa.e) b (λc.d)) ((λa.(λd.a) (λd c.b ((λa.a) a)) (a ((λa.(λd.e) ((λe.(λd b.a) (λa c.(λa a d.(λd.b (λa d.c) e) (λb b.c a (a d (λb d d e a.d (λb b.d))))) ((λb.a) c)) (d ((λc.(λd.a (λe.e)) (c d)) ((λe.b) a))) c (λa.d (e (λe.(λd c.b) a))) (c (b a)) a (λe.(λa b e b a.d) b)) ((λe.b) (λa.b)) ((λe d.b) b) e) b) ((λc c.a e) (λb.(λb.e) a)))) (λe.e) b (λd c e e c a.c)) a)"
  12
  13 cY :: Term
  14 cY = tRead "λf.(λx.f (x x)) (λx.f (x x))"
  15 cI :: Term
  16 cI = tRead "λx.x"
  17 cK :: Term
  18 cK = tRead "λx y.x"
  19 cS :: Term
  20 cS = tRead "λx y z.x z (y z)"
  21
  22 instance Arbitrary Term
  23   where arbitrary = sized aTerm
  24
  25 aVarName :: Gen String
  26 aVarName = oneof . map (pure . (:[])) $ ['a'..'e']
  27
  28 aTypeName :: Gen String
  29 aTypeName = oneof . map (pure . (:[])) $ ['A'..'E']
  30
  31 aComb :: Gen Term
  32 aComb = oneof . map pure $ [cS, cK, cI, cY]
  33
  34 aVar :: Gen Term
  35 aVar = liftA Var aVarName
  36
  37 aTerm :: Int -> Gen Term
  38 aTerm 0 = aVar
  39 aTerm n = oneof
  40             [ aVar, aComb
  41             , liftA2 Lam aVarName $ aTerm (n - 1)
  42             , liftA2 App (aTerm (n `div` 2)) (aTerm (n `div` 2))
  43             , liftA3 Let aVar (aTerm (n / 2)) (aTerm (n / 2))]
  44
  45 --
  46 -- TODO: shrink Terms
  47 -- TODO: timed tests
  48
  49