ShowMutable.hs

-- | Show mutant variations
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)


-- | Show a Mutant as a tuple of lambdas.
--
-- > > putStrLn $ showMutantAsTuple ["p && q","not p"] ((&&),not) ((||),id)
-- > ( \p q -> case (p,q) of
-- >            (False,False) -> True
-- >            _ -> p && q
-- >, \p -> case p of
-- >          False -> False
-- >          True -> True
-- >          _ -> not p )
--
-- Can be easily copy pasted into an interactive session for manipulation.
-- On GHCi, use @:{@ and @:}@ to allow multi-line expressions and definitions.
showMutantAsTuple :: ShowMutable a => [String] -> a -> a -> String
showMutantAsTuple names f f' = showMutantSAsTuple names
                             $ flatten
                             $ mutantS f f'

-- | Show a Mutant as the list of bindings that differ from the original
--   function(s).
--
-- > > putStrLn $ showMutantBindings ["p && q","not p"] ((&&),not) ((==),id)
-- > False && False = True
-- > not False = False
-- > not True  = True
--
-- Can possibly be copied into the source of the original function for
-- manipulation.
showMutantBindings :: ShowMutable a => [String] -> a -> a -> String
showMutantBindings names f f' = showMutantSBindings False names
                              $ flatten
                              $ mutantS f f'

-- | Show a Mutant as a new complete top-level definition, with a prime
-- appended to the name of the mutant.
--
-- > > putStrLn $ showMutantDefinition ["p && q","not p"] ((&&),not) ((==),id)
-- > False &&- False = True
-- > p     &&- q     = p && q
-- > not' False = False
-- > not' True  = True
-- > not' p     = not p
showMutantDefinition :: ShowMutable a => [String] -> a -> a -> String
showMutantDefinition names f f' = showMutantSBindings True names
                               $ flatten
                               $ mutantS f f'

-- | Show a Mutant as a tuple of nested lambdas.
-- Very similar to 'showMutantAsTuple', but the underlying data structure is
-- not flatten: so the output is as close as possible to the underlying
-- representation.
showMutantNested :: ShowMutable a => [String] -> a -> a -> String
showMutantNested names f f' = showMutantSAsTuple names
                            $ mutantS f f'

-- | Show a Mutant without providing a default name.
-- An alias for @showMutantAsTuple []@.
showMutant :: ShowMutable a => a -> a -> String
showMutant = showMutantAsTuple []


-- | Default function names (when none given):
--
-- > f g h f' g' h' f'' g'' h''
defaultFunctionNames :: [String]
defaultFunctionNames = ["f","g","h"] ++ map (++"'") defaultFunctionNames

-- | Default names in a call (function and variables):
--
-- > f x y z w x' y' z' w' x'' y'' z'' w'' ...
defaultNames :: [String]
defaultNames = head defaultFunctionNames : defVarNames
  where defVarNames = ["x","y","z","w"] ++ map (++"'") defVarNames


-- | Types that can have their mutation shown.
-- Has only one function 'mutantS' that returns a simple AST ('MutantS')
-- representing the mutant.  A standard implementation of 'mutantS' for 'Eq'
-- types is given by 'mutantSEq'.
class ShowMutable a where
  mutantS :: a -> a -> MutantS

-- | For a given type @Type@ instance of @Eq@ and @Show@,
-- define the 'ShowMutable' instance as:
--
-- > instance ShowMutable Type
-- >   where mutantS = mutantSEq
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 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 (Listable a, Show a, ShowMutable b) => ShowMutable (a->b) where
  -- TODO: let the user provide how many values should be tried when printing
  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' ]


-- | (Show) Structure of a mutant.
-- This format is intended for processing then pretty-printing.
data MutantS = Unmutated String
             | Atom String
             | Tuple [MutantS]
             | Function [([String],MutantS)]
  deriving Show

-- | Check if a 'MutantS' is null
isUnmutated :: MutantS -> Bool
isUnmutated (Unmutated _) = True
isUnmutated (Tuple ms)    = all isUnmutated ms
isUnmutated (Function bs) = all (isUnmutated . snd) bs
isUnmutated _             = False

-- | Check if a 'MutantS' is a function.
isFunction :: MutantS -> Bool
isFunction (Function _) = True
isFunction _            = False

-- | Flatten a MutantS by merging nested 'Function's.
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


-- | Show a nameless mutant.
-- Functions should not (but can) be shown using this.
showMutantS :: MutantS -> String
showMutantS (Unmutated s) = s
showMutantS (Atom s)      = s
showMutantS (Tuple ms)    = showTuple $ map showMutantS ms
showMutantS (Function bs) = showLambda ["??"] bs

-- | Show top-level (maybe tuple) named 'MutantS' as a tuple.
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])

-- | Show top-level (maybe tuple) named 'MutantS' as a bindings.
-- In general, you want to 'flatten' the 'MutantS' before applying this
-- function.
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])


-- | Given a list with the function and variable names and a list of bindings,
-- show a function as a case expression enclosed in a lambda.
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

-- | Given a list with the function and variable names and a list of bindings,
-- show function binding declarations.
--
-- The 'new' boolean argument indicates whether if the function should be shown
-- as a new definition.
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


-- | Separate function from variable names in a simple Haskell expr.
--
-- > fvarnames "f x y" == ["f","x","y"]
-- > fvarnames "aa bb cc dd" == ["aa","bb","cc","dd"]
--
-- When there are three lexemes, the function checks for a potential infix
-- operator in the middle.
--
-- > fvarnames "x + y" == ["(+)","x","y"]
-- 
-- This function always returns a "head"
--
-- > fvarnames "" == ["f"]
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 a function ('String') to a list of variables ('[String]').
--
-- For the sake of clarity, in the following examples, double-quotes are omitted:
-- > apply f       == f
-- > apply f x     == f x
-- > apply f x y   == f x y
-- > apply (+)     == (+)
-- > apply (+) x   == (+) x
-- > apply (+) x y == (+) x y
-- > apply +       == (+)
-- > apply + x     == (+) x
-- > apply + x y   == (x + y)
-- > apply + x y z == (+) x y z
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)

-- | Check if a function / operator is infix
--
-- > isInfix "foo"   == False
-- > isInfix "(+)"   == False
-- > isInfix "`foo`" == True
-- > isInfix "+"     == True
isInfix :: String -> Bool
isInfix (c:cs) = c /= '(' && not (isLetter c)

-- | Transform an infix operator into an infix function:
--
-- > toPrefix "`foo`" == "foo"
-- > toPrefix "+"     == "(+)"
toPrefix :: String -> String
toPrefix ('`':cs) = init cs
toPrefix cs = '(':cs ++ ")"

-- Primeify the name of a function by appending prime @'@ to functions and
-- minus @-@ to operators.
--
-- > prime "(+)"   == "(+-)"
-- > prime "foo"   == "foo'"
-- > prime "`foo`" == "`foo'`"
-- > prime "*"     == "*-
prime :: String -> String
prime ('`':cs) = '`':init cs ++ "'`" -- `foo` to `foo'`
prime ('(':cs) = '(':init cs ++ "-)" -- (+) to (+-)
prime cs | isInfix cs = cs ++ "-"    -- + to +-
         | otherwise  = cs ++ "'"    -- foo to foo'


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)

-- | @xs +- ys@ superimposes @xs@ over @ys@.
--
-- [1,2,3] +- [0,0,0,0,0,0,0] == [1,2,3,0,0,0,0]
-- [x,y,z] +- [a,b,c,d,e,f,g] == [x,y,z,d,e,f,g]
-- "asdf" +- "this is a test" == "asdf is a test"
(+-) :: Eq a => [a] -> [a] -> [a]
xs +- ys = xs ++ drop (length xs) ys


-- Instances of ShowMutable for up to 6-tuples are given here:

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