{-# LANGUAGE CPP #-}
module Test.LeanCheck.Function.ShowFunction
(
showFunction
, showFunctionLine
, ShowFunction (..)
, bindtiersShow
, Binding
, bindings
, explainedBindings
, describedBindings
, clarifiedBindings
, Listable
)
where
import Test.LeanCheck.Core
import Test.LeanCheck.Error (errorToNothing)
import Test.LeanCheck.Utils.Types
import Test.LeanCheck.Stats (classifyOn)
import Data.List (intercalate, sortBy)
import Data.Maybe
import Data.Function (on)
import Data.Word
import Data.Int
import Data.Ratio
import Data.Complex
import Data.Char (GeneralCategory)
import System.Exit (ExitCode)
import System.IO (IOMode, BufferMode, SeekMode)
import Foreign.C
type Binding = ([String], Maybe String)
class ShowFunction a where
bindtiers :: a -> [[Binding]]
bindings :: ShowFunction a => a -> [Binding]
bindings = concat . bindtiers
bindtiersShow :: Show a => a -> [[Binding]]
bindtiersShow x = [[([],errorToNothing $ show x)]]
instance ShowFunction () where bindtiers = bindtiersShow
instance ShowFunction Bool where bindtiers = bindtiersShow
instance ShowFunction Int where bindtiers = bindtiersShow
instance ShowFunction Word where bindtiers = bindtiersShow
instance ShowFunction Integer where bindtiers = bindtiersShow
instance ShowFunction Char where bindtiers = bindtiersShow
instance ShowFunction Float where bindtiers = bindtiersShow
instance ShowFunction Double where bindtiers = bindtiersShow
instance ShowFunction Ordering where bindtiers = bindtiersShow
instance Show a => ShowFunction [a] where bindtiers = bindtiersShow
instance Show a => ShowFunction (Maybe a) where bindtiers = bindtiersShow
instance (Show a, Show b) => ShowFunction (Either a b) where bindtiers = bindtiersShow
instance (Show a, Show b) => ShowFunction (a,b) where bindtiers = bindtiersShow
instance (Show a, Listable a, ShowFunction b) => ShowFunction (a->b) where
bindtiers f = concatMapT bindtiersFor tiers
where bindtiersFor x = mapFst (show x:) `mapT` bindtiers (f x)
mapFst f (x,y) = (f x, y)
paren :: String -> String
paren s = "(" ++ s ++ ")"
varnamesFor :: ShowFunction a => a -> [String]
varnamesFor = zipWith const varnames . fst . head . bindings
where varnames = ["x","y","z","w"] ++ map (++"'") varnames
showTuple :: [String] -> String
showTuple [x] = x
showTuple xs | all (== "_") xs = "_"
| otherwise = paren $ intercalate "," xs
showBindings :: [Binding] -> [String]
showBindings bs = [ showTuple as ++ " -> " ++ r | (as, Just r) <- bs ]
showNBindings :: Bool -> Int -> [Binding] -> [String]
showNBindings infinite n bs' = take n bs ++ ["..." | infinite || length bs > n]
where
bs = showBindings bs'
isValue :: ShowFunction a => a -> Bool
isValue f = case bindings f of
[([],_)] -> True
_ -> False
showValueOf :: ShowFunction a => a -> String
showValueOf x = case snd . head . bindings $ x of
Nothing -> "undefined"
Just x' -> x'
showFunction :: ShowFunction a => Int -> a -> String
showFunction n = showFunctionL False (n*n+1) n
showFunctionLine :: ShowFunction a => Int -> a -> String
showFunctionLine n = showFunctionL True (n*n+1) n
isUndefined :: ShowFunction a => Int -> a -> Bool
isUndefined m = all (isNothing . snd) . take m . bindings
isConstant :: ShowFunction a => Int -> a -> Bool
isConstant m f = case take m $ bindings f of
[] -> False
((_,r'):bs) -> all (\(_,r) -> r == r') bs
showConstant :: ShowFunction a => Int -> a -> String
showConstant m f = "\\" ++ unwords vs ++ " -> " ++ fromMaybe "undefined" r
where
(as,r) = head $ bindings f
vs = replicate (length as) "_"
showFunctionL :: ShowFunction a => Bool -> Int -> Int -> a -> String
showFunctionL singleLine m n f | isValue f = showValueOf f
showFunctionL singleLine m n f | isConstant m f = showConstant m f
showFunctionL singleLine m n f | otherwise = lambdaPat ++ caseExp
where
lambdaPat = "\\" ++ unwords vs ++ " -> "
casePat = "case " ++ showTuple (filter (/= "_") vs) ++ " of"
(vs, bindings) = clarifiedBindings m n f
bs = showNBindings (length bindings >= m) n bindings
sep | singleLine = " "
| otherwise = "\n"
cases | singleLine = intercalate "; " bs
| otherwise = unlines
$ (replicate (length lambdaPat) ' ' ++) `map` bs
caseExp = if isUndefined m f
then "undefined"
else casePat ++ sep ++ cases
instance (Show a, Show b, Show c)
=> ShowFunction (a,b,c) where bindtiers = bindtiersShow
instance (Show a, Show b, Show c, Show d)
=> ShowFunction (a,b,c,d) where bindtiers = bindtiersShow
instance (Show a, Show b, Show c, Show d, Show e)
=> ShowFunction (a,b,c,d,e) where bindtiers = bindtiersShow
instance (Show a, Show b, Show c, Show d, Show e, Show f)
=> ShowFunction (a,b,c,d,e,f) where bindtiers = bindtiersShow
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g)
=> ShowFunction (a,b,c,d,e,f,g) where bindtiers = bindtiersShow
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h)
=> ShowFunction (a,b,c,d,e,f,g,h) where bindtiers = bindtiersShow
instance ( Show a, Show b, Show c, Show d
, Show e, Show f, Show g, Show h
, Show i )
=> ShowFunction (a,b,c,d,e,f,g,h,i) where bindtiers = bindtiersShow
instance ( Show a, Show b, Show c, Show d
, Show e, Show f, Show g, Show h
, Show i, Show j )
=> ShowFunction (a,b,c,d,e,f,g,h,i,j) where bindtiers = bindtiersShow
instance ( Show a, Show b, Show c, Show d
, Show e, Show f, Show g, Show h
, Show i, Show j, Show k )
=> ShowFunction (a,b,c,d,e,f,g,h,i,j,k) where bindtiers = bindtiersShow
instance ( Show a, Show b, Show c, Show d
, Show e, Show f, Show g, Show h
, Show i, Show j, Show k, Show l )
=> ShowFunction (a,b,c,d,e,f,g,h,i,j,k,l) where bindtiers = bindtiersShow
instance (Integral a, Show a) => ShowFunction (Ratio a) where bindtiers = bindtiersShow
instance (RealFloat a, Show a) => ShowFunction (Complex a) where bindtiers = bindtiersShow
instance ShowFunction Int8 where bindtiers = bindtiersShow
instance ShowFunction Int16 where bindtiers = bindtiersShow
instance ShowFunction Int32 where bindtiers = bindtiersShow
instance ShowFunction Int64 where bindtiers = bindtiersShow
instance ShowFunction Word8 where bindtiers = bindtiersShow
instance ShowFunction Word16 where bindtiers = bindtiersShow
instance ShowFunction Word32 where bindtiers = bindtiersShow
instance ShowFunction Word64 where bindtiers = bindtiersShow
instance ShowFunction Nat where bindtiers = bindtiersShow
instance ShowFunction Nat1 where bindtiers = bindtiersShow
instance ShowFunction Nat2 where bindtiers = bindtiersShow
instance ShowFunction Nat3 where bindtiers = bindtiersShow
instance ShowFunction Nat4 where bindtiers = bindtiersShow
instance ShowFunction Nat5 where bindtiers = bindtiersShow
instance ShowFunction Nat6 where bindtiers = bindtiersShow
instance ShowFunction Nat7 where bindtiers = bindtiersShow
instance ShowFunction Int1 where bindtiers = bindtiersShow
instance ShowFunction Int2 where bindtiers = bindtiersShow
instance ShowFunction Int3 where bindtiers = bindtiersShow
instance ShowFunction Int4 where bindtiers = bindtiersShow
instance ShowFunction Word1 where bindtiers = bindtiersShow
instance ShowFunction Word2 where bindtiers = bindtiersShow
instance ShowFunction Word3 where bindtiers = bindtiersShow
instance ShowFunction Word4 where bindtiers = bindtiersShow
instance ShowFunction Natural where bindtiers = bindtiersShow
instance ShowFunction Letter where bindtiers = bindtiersShow
instance ShowFunction AlphaNum where bindtiers = bindtiersShow
instance ShowFunction Digit where bindtiers = bindtiersShow
instance ShowFunction Alpha where bindtiers = bindtiersShow
instance ShowFunction Upper where bindtiers = bindtiersShow
instance ShowFunction Lower where bindtiers = bindtiersShow
instance ShowFunction Space where bindtiers = bindtiersShow
instance ShowFunction Spaces where bindtiers = bindtiersShow
instance ShowFunction Lowers where bindtiers = bindtiersShow
instance ShowFunction Uppers where bindtiers = bindtiersShow
instance ShowFunction Alphas where bindtiers = bindtiersShow
instance ShowFunction Digits where bindtiers = bindtiersShow
instance ShowFunction AlphaNums where bindtiers = bindtiersShow
instance ShowFunction Letters where bindtiers = bindtiersShow
instance Show a => ShowFunction (X a) where bindtiers = bindtiersShow
instance Show a => ShowFunction (Xs a) where bindtiers = bindtiersShow
instance Show a => ShowFunction (Set a) where bindtiers = bindtiersShow
instance Show a => ShowFunction (Bag a) where bindtiers = bindtiersShow
instance Show a => ShowFunction (NoDup a) where bindtiers = bindtiersShow
instance (Show a, Show b) => ShowFunction (Map a b) where bindtiers = bindtiersShow
instance ShowFunction ExitCode where bindtiers = bindtiersShow
instance ShowFunction SeekMode where bindtiers = bindtiersShow
instance ShowFunction IOMode where bindtiers = bindtiersShow
instance ShowFunction BufferMode where bindtiers = bindtiersShow
instance ShowFunction GeneralCategory where bindtiers = bindtiersShow
instance ShowFunction CChar where bindtiers = bindtiersShow
instance ShowFunction CSChar where bindtiers = bindtiersShow
instance ShowFunction CUChar where bindtiers = bindtiersShow
instance ShowFunction CShort where bindtiers = bindtiersShow
instance ShowFunction CUShort where bindtiers = bindtiersShow
instance ShowFunction CInt where bindtiers = bindtiersShow
instance ShowFunction CUInt where bindtiers = bindtiersShow
instance ShowFunction CLong where bindtiers = bindtiersShow
instance ShowFunction CULong where bindtiers = bindtiersShow
instance ShowFunction CPtrdiff where bindtiers = bindtiersShow
instance ShowFunction CSize where bindtiers = bindtiersShow
instance ShowFunction CWchar where bindtiers = bindtiersShow
instance ShowFunction CSigAtomic where bindtiers = bindtiersShow
instance ShowFunction CLLong where bindtiers = bindtiersShow
instance ShowFunction CULLong where bindtiers = bindtiersShow
instance ShowFunction CIntPtr where bindtiers = bindtiersShow
instance ShowFunction CUIntPtr where bindtiers = bindtiersShow
instance ShowFunction CIntMax where bindtiers = bindtiersShow
instance ShowFunction CUIntMax where bindtiers = bindtiersShow
instance ShowFunction CClock where bindtiers = bindtiersShow
instance ShowFunction CTime where bindtiers = bindtiersShow
instance ShowFunction CFloat where bindtiers = bindtiersShow
instance ShowFunction CDouble where bindtiers = bindtiersShow
#if __GLASGOW_HASKELL__ >= 802
instance ShowFunction CBool where bindtiers = bindtiersShow
#endif
#if __GLASGOW_HASKELL__
instance ShowFunction CUSeconds where bindtiers = bindtiersShow
instance ShowFunction CSUSeconds where bindtiers = bindtiersShow
#endif
functionNames :: [(String, [Binding])]
functionNames =
[ "id" `for` (id :: () -> ())
, "const" `for` (const :: () -> () -> ())
, "id" `for` (id :: Bool -> Bool)
, "not" `for` (not :: Bool -> Bool)
, "const" `for` (const :: Bool -> Bool -> Bool)
, "(&&)" `for` (&&)
, "(||)" `for` (||)
, "id" `for` (id :: Int -> Int)
, "const" `for` (const :: Int -> Int -> Int)
, "(+)" `for` ((+) :: Int -> Int -> Int)
, "(-)" `for` ((-) :: Int -> Int -> Int)
, "(*)" `for` ((*) :: Int -> Int -> Int)
, "negate" `for` (negate :: Int -> Int)
, "abs" `for` (abs :: Int -> Int)
, "signum" `for` (signum :: Int -> Int)
, "odd" `for` (odd :: Int -> Bool)
, "even" `for` (even :: Int -> Bool)
]
where
n `for` f = (n, bindings f)
name :: ShowFunction a => Int -> a -> Maybe String
name n f = listToMaybe [ nm | (nm, bs) <- functionNames
, take n bs == take n (bindings f)]
canName :: ShowFunction a => Int -> a -> Bool
canName n = isJust . name n
showName :: ShowFunction a => Int -> a -> String
showName n = fromMaybe "unknown" . name n
clarifiedBindings :: ShowFunction a => Int -> Int -> a -> ([String],[Binding])
clarifiedBindings m n = clarifyBindings . describedBindings m n
clarifyBindings :: [Binding] -> ([String],[Binding])
clarifyBindings bs = (varnamesByUsage used, map (mapFst $ select used) bs)
where
mapFst f (x,y) = (f x, y)
used = usedArgs bs
varnamesByUsage :: [Bool] -> [String]
varnamesByUsage = zipWith used varnames
where
used s False = "_"
used s True = s
varnames = ["x","y","z","w"] ++ map (++"'") varnames
usedArgs :: [Binding] -> [Bool]
usedArgs = foldr1 (zipWith (||))
. map (map (/= "_") . fst)
describedBindings :: ShowFunction a => Int -> Int -> a -> [Binding]
describedBindings m n f
| length bs1 <= n = bs1
| otherwise = bs0
where
bs0 = take m $ bindings f
bs1 = describeBindings bs0
describeBindings :: [Binding] -> [Binding]
describeBindings bs = head $ sortOn length $
[ bs
, explainBindings bs
, explainBindings . concat . sortOn length $ classifyOn snd bs
]
explainedBindings :: ShowFunction a => Int -> a -> [Binding]
explainedBindings m = explainBindings . take m . bindings
explainBindings :: [Binding] -> [Binding]
explainBindings = explain []
where
explain :: [Binding] -> [Binding] -> [Binding]
explain bs' [] = reverse bs'
explain bs' ((as,r):bs) = explain (bs''++bs') [b | b <- bs, none (b <~~) bs'']
where
bs'' = discardLater (<~~)
[ (gas,r) | gas <- generalizations as
, and [r' == r | (as',r') <- bs, as' <~ gas] ]
generalizations :: [String] -> [[String]]
generalizations [] = [[]]
generalizations (v:vs) = map ("_":) gvs ++ map (v:) gvs
where
gvs = generalizations vs
(<~) :: [String] -> [String] -> Bool
[] <~ [] = True
(v:vs) <~ ("_":ws) = vs <~ ws
(v:vs) <~ (w:ws) = v == w && vs <~ ws
_ <~ _ = False
(<~~) :: Binding -> Binding -> Bool
(as,r) <~~ (as',r') = as <~ as' && r == r'
discard :: (a -> Bool) -> [a] -> [a]
discard p = filter (not . p)
discardLater :: (a -> a -> Bool) -> [a] -> [a]
discardLater (?>) = dl
where
dl [] = []
dl (x:xs) = x : discard (?> x) (dl xs)
none :: (a -> Bool) -> [a] -> Bool
none p = not . any p
sortOn :: Ord b => (a -> b) -> [a] -> [a]
sortOn f = sortBy (compare `on` f)
select :: [Bool] -> [a] -> [a]
select [] _ = []
select _ [] = []
select (p:ps) (x:xs) = if p then x : xs' else xs' where xs' = select ps xs