module Test.FitSpec.ShowMutable
( ShowMutable (..)
, mutantSEq
, showMutantAsTuple
, showMutantNested
, showMutantDefinition
, showMutantBindings
, MutantS ()
, mutantSTuple
)
where
import Test.FitSpec.PrettyPrint
import Test.LeanCheck.Error (errorToNothing, Listable(..))
import Data.Maybe (mapMaybe,isNothing)
import Control.Monad (join)
import Data.List (intercalate,tails)
import Data.Char (isLetter)
import Data.Ratio (Ratio)
import Data.Word (Word)
showMutantAsTuple :: ShowMutable a => [String] -> a -> a -> String
showMutantAsTuple names f f' = showMutantSAsTuple names
$ flatten
$ mutantS f f'
showMutantBindings :: ShowMutable a => [String] -> a -> a -> String
showMutantBindings names f f' = showMutantSBindings False names
$ flatten
$ mutantS f f'
showMutantDefinition :: ShowMutable a => [String] -> a -> a -> String
showMutantDefinition names f f' = showMutantSBindings True names
$ flatten
$ mutantS f f'
showMutantNested :: ShowMutable a => [String] -> a -> a -> String
showMutantNested names f f' = showMutantSAsTuple names
$ mutantS f f'
showMutant :: ShowMutable a => a -> a -> String
showMutant = showMutantAsTuple []
defaultFunctionNames :: [String]
defaultFunctionNames = ["f","g","h"] ++ map (++"'") defaultFunctionNames
defaultNames :: [String]
defaultNames = head defaultFunctionNames : defVarNames
where defVarNames = ["x","y","z","w"] ++ map (++"'") defVarNames
class ShowMutable a where
mutantS :: a -> a -> MutantS
mutantSEq :: (Eq a, Show a)
=> a -> a -> MutantS
mutantSEq x x' = if x == x'
then Unmutated $ show x
else Atom $ show x'
instance ShowMutable () where mutantS = mutantSEq
instance ShowMutable Int where mutantS = mutantSEq
instance ShowMutable Integer where mutantS = mutantSEq
instance ShowMutable Char where mutantS = mutantSEq
instance ShowMutable Bool where mutantS = mutantSEq
instance (Eq a, Show a) => ShowMutable [a] where mutantS = mutantSEq
instance (Eq a, Show a) => ShowMutable (Maybe a) where mutantS = mutantSEq
instance (Eq a, Show a, Eq b, Show b) => ShowMutable (Either a b)
where mutantS = mutantSEq
instance (Eq a, Show a, Integral a) => ShowMutable (Ratio a)
where mutantS = mutantSEq
instance ShowMutable Float where mutantS = mutantSEq
instance ShowMutable Double where mutantS = mutantSEq
instance ShowMutable Ordering where mutantS = mutantSEq
instance ShowMutable Word where mutantS = mutantSEq
instance (Listable a, Show a, ShowMutable b) => ShowMutable (a->b) where
mutantS f f' = Function
. take 10
. filter (not . isUnmutated . snd)
. mapMaybe bindingFor
. take 200
$ list
where bindingFor x = fmap ((,) [show x])
$ errorToNothing (mutantS (f x) (f' x))
instance (ShowMutable a, ShowMutable b) => ShowMutable (a,b) where
mutantS (f,g) (f',g') = Tuple [ mutantS f f'
, mutantS g g' ]
instance (ShowMutable a, ShowMutable b, ShowMutable c)
=> ShowMutable (a,b,c) where
mutantS (f,g,h) (f',g',h') = Tuple [ mutantS f f'
, mutantS g g'
, mutantS h h' ]
data MutantS = Unmutated String
| Atom String
| Tuple [MutantS]
| Function [([String],MutantS)]
deriving Show
isUnmutated :: MutantS -> Bool
isUnmutated (Unmutated _) = True
isUnmutated (Tuple ms) = all isUnmutated ms
isUnmutated (Function bs) = all (isUnmutated . snd) bs
isUnmutated _ = False
isFunction :: MutantS -> Bool
isFunction (Function _) = True
isFunction _ = False
flatten :: MutantS -> MutantS
flatten (Tuple ms) = Tuple $ map flatten ms
flatten (Function [([],s)]) = flatten s
flatten (Function (([],s):_)) = error "flatten: ambiguous value"
flatten (Function bs) = let bs' = map (mapSnd flatten) bs in
if any (not . isFunction . snd) bs'
then Function bs'
else Function
$ take 10
$ concatMap (\(as,Function bs'') -> map (mapFst (as++)) bs'') bs'
flatten m = m
showMutantS :: MutantS -> String
showMutantS (Unmutated s) = s
showMutantS (Atom s) = s
showMutantS (Tuple ms) = showTuple $ map showMutantS ms
showMutantS (Function bs) = showLambda ["??"] bs
showMutantSAsTuple :: [String] -> MutantS -> String
showMutantSAsTuple ns (Tuple ms) = showTuple $ zipWith show1 (ns +- defaultFunctionNames) ms
where show1 n (Unmutated _) = n
show1 n (Function bs) = showLambda (fvnames n) bs
show1 _ m = showMutantS m
showMutantSAsTuple ns m = showMutantSAsTuple ns (Tuple [m])
showMutantSBindings :: Bool -> [String] -> MutantS -> String
showMutantSBindings new ns (Tuple ms) = concatMap (uncurry show1)
$ zip (ns ++ defaultFunctionNames) ms
where show1 _ (Unmutated s) = ""
show1 _ (Function []) = ""
show1 n (Function bs) = showBindings new (fvnames n) bs
show1 n m = let fn = head $ fvnames n
fn' | new = prime fn
| otherwise = fn
in (apply fn' [] ++ " = ")
`beside` showMutantS m
showMutantSBindings new ns m = showMutantSBindings new ns (Tuple [m])
showLambda :: [String] -> [([String],MutantS)] -> String
showLambda [] [] = "undefined {- (err?) unmutated -}"
showLambda (n:_) [] = apply n []
showLambda _ [([],m)] = showMutantS m
showLambda _ (([],_):_) = "undefined {- (err?) ambiguous value -}"
showLambda ns bs = (("\\" ++ unwords bound ++ " -> ") `beside`)
$ "case " ++ showTuple bound ++ " of\n"
++ " " `beside` cases
where
cases = concatMap (\(as,r) -> (showTuple as ++ " -> ") `beside` showResult r) bs
++ "_ -> " ++ apply fn bound
showResult (Function bs') = showLambda (apply fn bound:unbound) bs'
showResult m = showMutantS m
unbound = drop (length bound) vns
bound = zipWith const vns (fst $ head bs)
(fn:vns) = ns +- defaultNames
showBindings :: Bool -> [String] -> [([String],MutantS)] -> String
showBindings new ns bs =
table " " $ (uncurry showBind `map` bs)
++ [words (apply fn' bound) ++ ["=", apply fn bound] | new]
where
showBind [a1,a2] r | isInfix fn' = [a1, fn', a2, "=", showMutantS r]
showBind as r = [fn'] ++ as ++ ["=", showMutantS r]
fn' | new = prime fn
| otherwise = fn
bound = zipWith const vns (fst $ head bs)
(fn:vns) = ns +- defaultNames
fvnames :: String -> [String]
fvnames = fvns' . words
where fvns' :: [String] -> [String]
fvns' [a,o,b] | isInfix o = o:[a,b]
fvns' [] = defaultNames
fvns' fvs = fvs
apply :: String -> [String] -> String
apply f [x,y] | isInfix f = unwords [x,f,y]
apply f xs = if isInfix f
then unwords (toPrefix f:xs)
else unwords (f:xs)
isInfix :: String -> Bool
isInfix (c:cs) = c /= '(' && not (isLetter c)
toPrefix :: String -> String
toPrefix ('`':cs) = init cs
toPrefix cs = '(':cs ++ ")"
prime :: String -> String
prime ('`':cs) = '`':init cs ++ "'`"
prime ('(':cs) = '(':init cs ++ "-)"
prime cs | isInfix cs = cs ++ "-"
| otherwise = cs ++ "'"
mapFst :: (a->b) -> (a,c) -> (b,c)
mapFst f (x,y) = (f x,y)
mapSnd :: (a->b) -> (c,a) -> (c,b)
mapSnd f (x,y) = (x,f y)
(+-) :: Eq a => [a] -> [a] -> [a]
xs +- ys = xs ++ drop (length xs) ys
instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d)
=> ShowMutable (a,b,c,d) where
mutantS (f,g,h,i) (f',g',h',i') = Tuple [ mutantS f f'
, mutantS g g'
, mutantS h h'
, mutantS i i' ]
instance (ShowMutable a, ShowMutable b, ShowMutable c,
ShowMutable d, ShowMutable e)
=> ShowMutable (a,b,c,d,e) where
mutantS (f,g,h,i,j) (f',g',h',i',j') = Tuple [ mutantS f f'
, mutantS g g'
, mutantS h h'
, mutantS i i'
, mutantS j j' ]
instance (ShowMutable a, ShowMutable b, ShowMutable c,
ShowMutable d, ShowMutable e, ShowMutable f)
=> ShowMutable (a,b,c,d,e,f) where
mutantS (f,g,h,i,j,k) (f',g',h',i',j',k') = Tuple [ mutantS f f'
, mutantS g g'
, mutantS h h'
, mutantS i i'
, mutantS j j'
, mutantS k k' ]
mutantSTuple :: [MutantS] -> MutantS
mutantSTuple = Tuple