extrapolate-0.4.0: test/extrapolate.hs
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, CPP #-} -- for GHC <= 7.8
-- Copyright (c) 2017-2019 Rudy Matela.
-- Distributed under the 3-Clause BSD licence (see the file LICENSE).
import Test
import Data.List (sort, nub)
#if __GLASGOW_HASKELL__ < 710
import Data.Typeable (Typeable)
deriving instance Typeable NOrd
#endif
data NOrd = NOrd
deriving Show
deriveListable ''NOrd
deriveGeneralizable ''NOrd
nord :: NOrd
nord = undefined
main :: IO ()
main = mainTest tests 10000
tests :: Int -> [Bool]
tests n =
[ True
-- Generalizable instance properties
, generalizableOK n ()
, generalizableOK n int
, generalizableOK n integer
, generalizableOK n bool
, generalizableOK n char
, generalizableOK n ordering
, generalizableOK 9 [()]
, generalizableOK n [int]
, generalizableOK n [integer]
, generalizableOK n [bool]
, generalizableOK n [char]
, generalizableOK n [ordering]
, generalizableOK n (mayb ())
, generalizableOK n (mayb int)
, generalizableOK n (mayb integer)
, generalizableOK n (mayb bool)
, generalizableOK n (mayb char)
, generalizableOK n (eith () int)
, generalizableOK n (eith integer bool)
, generalizableOK n (int,bool)
, generalizableOK n ((),integer)
, generalizableOK n ((),bool,integer)
, generalizableOK n (int,(),bool,integer)
, generalizableOK n (int,(),bool,integer,char)
, generalizableOK n (string,int,(),bool,integer,char)
-- TODO: implement further tuple instances (7,8,9,10,11,12) and uncomment below
, generalizableOK n ((),(),(),(),(),(),())
#if __GLASGOW_HASKELL__ < 710
-- no 8-tuples for you
#else
, generalizableOK n ((),(),(),(),(),(),(),())
--, generalizableOK n ((),(),(),(),(),(),(),(),())
--, generalizableOK n ((),(),(),(),(),(),(),(),(),())
--, generalizableOK n ((),(),(),(),(),(),(),(),(),(),())
--, generalizableOK n ((),(),(),(),(),(),(),(),(),(),(),())
#endif
-- Silly test, as it basically replicates the actual implementation:
, backgroundOf int =$ sort $= [ value "==" $ (==) -:> int
, value "/=" $ (/=) -:> int
, value "<=" $ (<=) -:> int
, value "<" $ (<) -:> int
]
, background (mayb int)
== [ value "==" ((==) -:> mayb int)
, value "/=" ((/=) -:> mayb int)
, value "<=" ((<=) -:> mayb int)
, value "<" ((<) -:> mayb int)
, value "Just" (Just ->: mayb int) ]
, background (eith int char)
== [ value "==" ((==) -:> eith int char)
, value "/=" ((/=) -:> eith int char)
, value "<=" ((<=) -:> eith int char)
, value "<" ((<) -:> eith int char)
, value "Left" (Left ->: eith int char)
, value "Right" (Right ->: eith int char) ]
, background [int]
== [ value "==" ((==) -:> [int])
, value "/=" ((/=) -:> [int])
, value "<=" ((<=) -:> [int])
, value "<" ((<) -:> [int])
, value "length" (length -:> [int])
, value "elem" (elem ->:> [int]) ]
, background (mayb nord)
== [ value "Just" (Just ->: mayb nord) ]
, background (eith nord nord)
== [ value "Left" (Left ->: eith nord nord)
, value "Right" (Right ->: eith nord nord) ]
, background [nord]
== [ value "length" (length -:> [nord]) ]
-- background tests
, listBackgroundOK ()
, listBackgroundOK int
, listBackgroundOK bool
, listBackgroundOK [(mayb (),integer,mayb char)]
, maybeBackgroundOK ()
, maybeBackgroundOK integer
, maybeBackgroundOK char
, maybeBackgroundOK [(int,bool,[mayb (char,())])]
, int `instancesSubset` [mayb [int]]
, bool `instancesSubset` ((),bool,char)
, [mayb ((),char)] `instancesSubset` [(int,(char,[mayb ((),char)]),bool)]
, not $ bool `instancesSubset` [mayb [int]]
, not $ bool `bgSubset` [mayb [int]]
, not $ bool `sameNamesIn` [mayb [int]]
, not $ bool `sameTiersIn` [mayb [int]]
, not $ mayb int `instancesSubset` [mayb [int]]
, not $ mayb int `bgSubset` [mayb [int]]
, not $ mayb int `sameNamesIn` [mayb [int]]
, not $ mayb int `sameTiersIn` [mayb [int]]
, candidateHoleGeneralizations isListable' (expr [0,0::Int])
== [ is_
, i_ -:- is_
, i_ -:- i_ -:- is_
, i_ -:- i_ -:- nil
, i_ -:- zero -:- is_
, i_ -:- zero -:- nil
, zero -:- is_
, zero -:- i_ -:- is_
, zero -:- i_ -:- nil
, zero -:- zero -:- is_
]
, candidateGeneralizations (\e -> typ e == typ one) (one -+- two)
== [ xx
, xx -+- yy
, xx -+- xx
, xx -+- two
, one -+- xx
]
, [ canonicalizeUsingHolesWith namesFor' g
| g <- candidateGeneralizations isListable' (expr [0,0::Int]) ]
== [ is_
, i_ -:- is_
, i_ -:- i_ -:- is_
, xx -:- xx -:- is_
, i_ -:- i_ -:- nil
, xx -:- xx -:- nil
, i_ -:- zero -:- is_
, i_ -:- zero -:- nil
, zero -:- is_
, zero -:- i_ -:- is_
, zero -:- i_ -:- nil
, zero -:- zero -:- is_
]
--, holds n $ bgEqOrdOK -:> () -- no Eq or Ord instance on background
, holds n $ bgEqOrdOK -:> int
, holds n $ bgEqOK -:> bool
, holds n $ bgEqOrdOK -:> char
, holds n $ bgEqOrdOK -:> integer
, holds n $ bgEqOrdOK -:> ordering
, holds n $ bgEqOrdOK -:> (int,int)
, holds n $ bgEqOK -:> (int,bool)
, holds n $ bgEqOK -:> (bool,int)
, holds n $ bgEqOK -:> (bool,bool)
, holds n $ bgEqOrdOK -:> (char,ordering)
, holds n $ bgEqOrdOK -:> (int,int,int)
, holds n $ bgEqOK -:> (int,int,bool)
, holds n $ bgEqOK -:> (int,bool,int)
, holds n $ bgEqOK -:> (int,bool,bool)
, holds n $ bgEqOK -:> (bool,int,int)
, holds n $ bgEqOK -:> (bool,int,bool)
, holds n $ bgEqOK -:> (bool,bool,int)
, holds n $ bgEqOK -:> (bool,bool,bool)
, holds n $ bgEqOrdOK -:> (integer,char,ordering)
, holds n $ bgEqOrdOK -:> (int,int,int,int)
, holds n $ bgEqOrdOK -:> (integer,char,ordering,int)
, holds n $ bgEqOK -:> (bool,bool,bool,bool)
, holds n $ bgEqOrdOK -:> [int]
, holds n $ bgEqOK -:> [bool]
, holds n $ bgEqOrdOK -:> [char]
, holds n $ bgEqOrdOK -:> [integer]
, holds n $ bgEqOrdOK -:> mayb int
, holds n $ bgEqOK -:> mayb bool
, holds n $ bgEqOrdOK -:> mayb char
, holds n $ bgEqOrdOK -:> eith int int
, holds n $ bgEqOK -:> eith int bool
, holds n $ bgEqOK -:> eith bool int
, holds n $ bgEqOK -:> eith bool bool
, holds n $ bgEqOrdOK -:> eith char ordering
, tinstancesUnrepeated $ bool
, tinstancesUnrepeated $ bool >- bool
, tinstancesUnrepeated $ int >- bool
, tinstancesUnrepeated $ char >- bool
, tinstancesUnrepeated $ bool >- bool >- bool
, tinstancesUnrepeated $ int >- int >- bool
, tinstancesUnrepeated $ char >- char >- bool
, tinstancesUnrepeated $ [bool] >- bool
, tinstancesUnrepeated $ [int] >- bool
, tinstancesUnrepeated $ [char] >- bool
, tinstancesUnrepeated $ mayb bool >- bool
, tinstancesUnrepeated $ mayb int >- bool
, tinstancesUnrepeated $ mayb char >- bool
, tinstancesUnrepeated $ eith bool bool >- bool
, tinstancesUnrepeated $ eith int int >- bool
, tinstancesUnrepeated $ eith char char >- bool
, tinstancesUnrepeated $ eith char () >- bool
, tinstancesUnrepeated $ ([bool],[bool]) >- bool
, tinstancesUnrepeated $ ([int], [int]) >- bool
, tinstancesUnrepeated $ ([char],[char]) >- bool
, tinstancesUnrepeated $ eith [bool] [bool] >- ([bool],[bool]) >- bool
]
theInstances :: [Expr]
theInstances = instances (undefined :: [Int]) []
isListable' :: Expr -> Bool
isListable' = isListable theInstances
namesFor' :: Expr -> [String]
namesFor' = lookupNames theInstances
tinstancesUnrepeated :: Testable a => a -> Bool
tinstancesUnrepeated p = nub is == is
where
is = map extractiers $ filter (not . isBackground) $ tinstances p
-- All tiers look the same without evaluating its elements:
-- > > tinstances bool
-- > [tiers :: [[Expr]],name :: Bool -> [Char],background :: [Expr],tiers :: [[Expr]],name :: Int -> [Char],background :: [Expr]]
-- So, this takes a representative to use in the comparison:
extractiers e@(Value "tiers" _) = head $ concat (eval undefined e :: [[Expr]])
extractiers e = e
-- every background looks the same without evaluating its elements
isBackground (Value "background" _) = True
isBackground _ = False
listBackgroundOK :: Generalizable a => a -> Bool
listBackgroundOK x = backgroundListOf x `subset` backgroundOf [x]
where
backgroundListOf x = [ value "length" $ length -:> [x] ]
+++ backgroundOf x
maybeBackgroundOK :: Generalizable a => a -> Bool
maybeBackgroundOK x = backgroundMaybeOf x `subset` backgroundOf (mayb x)
where
backgroundMaybeOf x = [value "Just" $ Just -:> x] +++ backgroundOf x