-- |
-- Module      : Test.FitSpec.ShowMutable
-- Copyright   : (c) 2015-2017 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- Exports a typeclass to 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)
import Data.Ratio (Ratio)
import Data.Word (Word) -- for GHC <= 7.10


-- | 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 :: [String] -> a -> a -> String
showMutantAsTuple [String]
names a
f a
f' = [String] -> MutantS -> String
showMutantSAsTuple [String]
names
                             (MutantS -> String) -> MutantS -> String
forall a b. (a -> b) -> a -> b
$ MutantS -> MutantS
flatten
                             (MutantS -> MutantS) -> MutantS -> MutantS
forall a b. (a -> b) -> a -> b
$ a -> a -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS a
f a
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 :: [String] -> a -> a -> String
showMutantBindings [String]
names a
f a
f' = Bool -> [String] -> MutantS -> String
showMutantSBindings Bool
False [String]
names
                              (MutantS -> String) -> MutantS -> String
forall a b. (a -> b) -> a -> b
$ MutantS -> MutantS
flatten
                              (MutantS -> MutantS) -> MutantS -> MutantS
forall a b. (a -> b) -> a -> b
$ a -> a -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS a
f a
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 :: [String] -> a -> a -> String
showMutantDefinition [String]
names a
f a
f' = Bool -> [String] -> MutantS -> String
showMutantSBindings Bool
True [String]
names
                               (MutantS -> String) -> MutantS -> String
forall a b. (a -> b) -> a -> b
$ MutantS -> MutantS
flatten
                               (MutantS -> MutantS) -> MutantS -> MutantS
forall a b. (a -> b) -> a -> b
$ a -> a -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS a
f a
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 :: [String] -> a -> a -> String
showMutantNested [String]
names a
f a
f' = [String] -> MutantS -> String
showMutantSAsTuple [String]
names
                            (MutantS -> String) -> MutantS -> String
forall a b. (a -> b) -> a -> b
$ a -> a -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS a
f a
f'

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


-- | Default function names (when none given):
--
-- > f g h f' g' h' f'' g'' h''
defaultFunctionNames :: [String]
defaultFunctionNames :: [String]
defaultFunctionNames = [String
"f",String
"g",String
"h"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'") [String]
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 :: [String]
defaultNames = [String] -> String
forall a. [a] -> a
head [String]
defaultFunctionNames String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
defVarNames
  where defVarNames :: [String]
defVarNames = [String
"x",String
"y",String
"z",String
"w"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'") [String]
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 :: a -> a -> MutantS
mutantSEq a
x a
x' = if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x'
                    then String -> MutantS
Unmutated (String -> MutantS) -> String -> MutantS
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
x
                    else String -> MutantS
Atom      (String -> MutantS) -> String -> MutantS
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
x'

instance ShowMutable ()   where mutantS :: () -> () -> MutantS
mutantS = () -> () -> MutantS
forall a. (Eq a, Show a) => a -> a -> MutantS
mutantSEq
instance ShowMutable Int  where mutantS :: Int -> Int -> MutantS
mutantS = Int -> Int -> MutantS
forall a. (Eq a, Show a) => a -> a -> MutantS
mutantSEq
instance ShowMutable Integer where mutantS :: Integer -> Integer -> MutantS
mutantS = Integer -> Integer -> MutantS
forall a. (Eq a, Show a) => a -> a -> MutantS
mutantSEq
instance ShowMutable Char where mutantS :: Char -> Char -> MutantS
mutantS = Char -> Char -> MutantS
forall a. (Eq a, Show a) => a -> a -> MutantS
mutantSEq
instance ShowMutable Bool where mutantS :: Bool -> Bool -> MutantS
mutantS = Bool -> Bool -> MutantS
forall a. (Eq a, Show a) => a -> a -> MutantS
mutantSEq
instance (Eq a, Show a) => ShowMutable [a]       where mutantS :: [a] -> [a] -> MutantS
mutantS = [a] -> [a] -> MutantS
forall a. (Eq a, Show a) => a -> a -> MutantS
mutantSEq
instance (Eq a, Show a) => ShowMutable (Maybe a) where mutantS :: Maybe a -> Maybe a -> MutantS
mutantS = Maybe a -> Maybe a -> MutantS
forall a. (Eq a, Show a) => a -> a -> MutantS
mutantSEq
instance (Eq a, Show a, Eq b, Show b) => ShowMutable (Either a b)
  where mutantS :: Either a b -> Either a b -> MutantS
mutantS = Either a b -> Either a b -> MutantS
forall a. (Eq a, Show a) => a -> a -> MutantS
mutantSEq
instance (Eq a, Show a, Integral a) => ShowMutable (Ratio a)
  where mutantS :: Ratio a -> Ratio a -> MutantS
mutantS = Ratio a -> Ratio a -> MutantS
forall a. (Eq a, Show a) => a -> a -> MutantS
mutantSEq
instance ShowMutable Float    where mutantS :: Float -> Float -> MutantS
mutantS = Float -> Float -> MutantS
forall a. (Eq a, Show a) => a -> a -> MutantS
mutantSEq
instance ShowMutable Double   where mutantS :: Double -> Double -> MutantS
mutantS = Double -> Double -> MutantS
forall a. (Eq a, Show a) => a -> a -> MutantS
mutantSEq
instance ShowMutable Ordering where mutantS :: Ordering -> Ordering -> MutantS
mutantS = Ordering -> Ordering -> MutantS
forall a. (Eq a, Show a) => a -> a -> MutantS
mutantSEq
instance ShowMutable Word     where mutantS :: Word -> Word -> MutantS
mutantS = Word -> Word -> MutantS
forall a. (Eq a, Show a) => a -> a -> 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 :: (a -> b) -> (a -> b) -> MutantS
mutantS a -> b
f a -> b
f' = [([String], MutantS)] -> MutantS
Function
               ([([String], MutantS)] -> MutantS)
-> ([a] -> [([String], MutantS)]) -> [a] -> MutantS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [([String], MutantS)] -> [([String], MutantS)]
forall a. Int -> [a] -> [a]
take Int
10
               ([([String], MutantS)] -> [([String], MutantS)])
-> ([a] -> [([String], MutantS)]) -> [a] -> [([String], MutantS)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([String], MutantS) -> Bool)
-> [([String], MutantS)] -> [([String], MutantS)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (([String], MutantS) -> Bool) -> ([String], MutantS) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MutantS -> Bool
isUnmutated (MutantS -> Bool)
-> (([String], MutantS) -> MutantS) -> ([String], MutantS) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String], MutantS) -> MutantS
forall a b. (a, b) -> b
snd)
               ([([String], MutantS)] -> [([String], MutantS)])
-> ([a] -> [([String], MutantS)]) -> [a] -> [([String], MutantS)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe ([String], MutantS)) -> [a] -> [([String], MutantS)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe a -> Maybe ([String], MutantS)
bindingFor
               ([a] -> [([String], MutantS)])
-> ([a] -> [a]) -> [a] -> [([String], MutantS)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
200
               ([a] -> MutantS) -> [a] -> MutantS
forall a b. (a -> b) -> a -> b
$ [a]
forall a. Listable a => [a]
list
    where bindingFor :: a -> Maybe ([String], MutantS)
bindingFor a
x = (MutantS -> ([String], MutantS))
-> Maybe MutantS -> Maybe ([String], MutantS)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) [a -> String
forall a. Show a => a -> String
show a
x])
                       (Maybe MutantS -> Maybe ([String], MutantS))
-> Maybe MutantS -> Maybe ([String], MutantS)
forall a b. (a -> b) -> a -> b
$ MutantS -> Maybe MutantS
forall a. a -> Maybe a
errorToNothing (b -> b -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS (a -> b
f a
x) (a -> b
f' a
x))

instance (ShowMutable a, ShowMutable b) => ShowMutable (a,b) where
  mutantS :: (a, b) -> (a, b) -> MutantS
mutantS (a
f,b
g) (a
f',b
g') = [MutantS] -> MutantS
Tuple [ a -> a -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS a
f a
f'
                                , b -> b -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS b
g b
g' ]

instance (ShowMutable a, ShowMutable b, ShowMutable c)
      => ShowMutable (a,b,c) where
  mutantS :: (a, b, c) -> (a, b, c) -> MutantS
mutantS (a
f,b
g,c
h) (a
f',b
g',c
h') = [MutantS] -> MutantS
Tuple [ a -> a -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS a
f a
f'
                                     , b -> b -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS b
g b
g'
                                     , c -> c -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS c
h c
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 Int -> MutantS -> String -> String
[MutantS] -> String -> String
MutantS -> String
(Int -> MutantS -> String -> String)
-> (MutantS -> String)
-> ([MutantS] -> String -> String)
-> Show MutantS
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [MutantS] -> String -> String
$cshowList :: [MutantS] -> String -> String
show :: MutantS -> String
$cshow :: MutantS -> String
showsPrec :: Int -> MutantS -> String -> String
$cshowsPrec :: Int -> MutantS -> String -> String
Show

-- | Check if a 'MutantS' is null
isUnmutated :: MutantS -> Bool
isUnmutated :: MutantS -> Bool
isUnmutated (Unmutated String
_) = Bool
True
isUnmutated (Tuple [MutantS]
ms)    = (MutantS -> Bool) -> [MutantS] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all MutantS -> Bool
isUnmutated [MutantS]
ms
isUnmutated (Function [([String], MutantS)]
bs) = (([String], MutantS) -> Bool) -> [([String], MutantS)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (MutantS -> Bool
isUnmutated (MutantS -> Bool)
-> (([String], MutantS) -> MutantS) -> ([String], MutantS) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String], MutantS) -> MutantS
forall a b. (a, b) -> b
snd) [([String], MutantS)]
bs
isUnmutated MutantS
_             = Bool
False

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

-- Flatten a MutantS by merging nested 'Function's.
flatten :: MutantS -> MutantS
flatten :: MutantS -> MutantS
flatten (Tuple [MutantS]
ms) = [MutantS] -> MutantS
Tuple ([MutantS] -> MutantS) -> [MutantS] -> MutantS
forall a b. (a -> b) -> a -> b
$ (MutantS -> MutantS) -> [MutantS] -> [MutantS]
forall a b. (a -> b) -> [a] -> [b]
map MutantS -> MutantS
flatten [MutantS]
ms
flatten (Function [([],MutantS
s)])  = MutantS -> MutantS
flatten MutantS
s
flatten (Function (([],MutantS
s):[([String], MutantS)]
_)) = String -> MutantS
forall a. HasCallStack => String -> a
error String
"flatten: ambiguous value"
flatten (Function [([String], MutantS)]
bs) = let bs' :: [([String], MutantS)]
bs' = (([String], MutantS) -> ([String], MutantS))
-> [([String], MutantS)] -> [([String], MutantS)]
forall a b. (a -> b) -> [a] -> [b]
map ((MutantS -> MutantS) -> ([String], MutantS) -> ([String], MutantS)
forall a b c. (a -> b) -> (c, a) -> (c, b)
mapSnd MutantS -> MutantS
flatten) [([String], MutantS)]
bs in
  if (([String], MutantS) -> Bool) -> [([String], MutantS)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool)
-> (([String], MutantS) -> Bool) -> ([String], MutantS) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MutantS -> Bool
isFunction (MutantS -> Bool)
-> (([String], MutantS) -> MutantS) -> ([String], MutantS) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String], MutantS) -> MutantS
forall a b. (a, b) -> b
snd) [([String], MutantS)]
bs'
    then [([String], MutantS)] -> MutantS
Function [([String], MutantS)]
bs'
    else [([String], MutantS)] -> MutantS
Function
       ([([String], MutantS)] -> MutantS)
-> [([String], MutantS)] -> MutantS
forall a b. (a -> b) -> a -> b
$ Int -> [([String], MutantS)] -> [([String], MutantS)]
forall a. Int -> [a] -> [a]
take Int
10
       ([([String], MutantS)] -> [([String], MutantS)])
-> [([String], MutantS)] -> [([String], MutantS)]
forall a b. (a -> b) -> a -> b
$ (([String], MutantS) -> [([String], MutantS)])
-> [([String], MutantS)] -> [([String], MutantS)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\([String]
as,Function [([String], MutantS)]
bs'') -> (([String], MutantS) -> ([String], MutantS))
-> [([String], MutantS)] -> [([String], MutantS)]
forall a b. (a -> b) -> [a] -> [b]
map (([String] -> [String])
-> ([String], MutantS) -> ([String], MutantS)
forall a b c. (a -> b) -> (a, c) -> (b, c)
mapFst ([String]
as[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++)) [([String], MutantS)]
bs'') [([String], MutantS)]
bs'
flatten MutantS
m = MutantS
m


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

-- | Show top-level (maybe tuple) named 'MutantS' as a tuple.
showMutantSAsTuple :: [String] -> MutantS -> String
showMutantSAsTuple :: [String] -> MutantS -> String
showMutantSAsTuple [String]
ns (Tuple [MutantS]
ms) = [String] -> String
showTuple ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> MutantS -> String) -> [String] -> [MutantS] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> MutantS -> String
show1 ([String]
ns [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
+- [String]
defaultFunctionNames) [MutantS]
ms
  where show1 :: String -> MutantS -> String
show1 String
n  (Unmutated String
_) = String
n
        show1 String
n  (Function [([String], MutantS)]
bs) = [String] -> [([String], MutantS)] -> String
showLambda (String -> [String]
fvnames String
n) [([String], MutantS)]
bs
        show1 String
_  MutantS
m             = MutantS -> String
showMutantS MutantS
m
showMutantSAsTuple [String]
ns MutantS
m = [String] -> MutantS -> String
showMutantSAsTuple [String]
ns ([MutantS] -> MutantS
Tuple [MutantS
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 :: Bool -> [String] -> MutantS -> String
showMutantSBindings Bool
new [String]
ns (Tuple [MutantS]
ms) = ((String, MutantS) -> String) -> [(String, MutantS)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> MutantS -> String) -> (String, MutantS) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> MutantS -> String
show1)
                                  ([(String, MutantS)] -> String) -> [(String, MutantS)] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [MutantS] -> [(String, MutantS)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([String]
ns [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
defaultFunctionNames) [MutantS]
ms
  where show1 :: String -> MutantS -> String
show1 String
_ (Unmutated String
s) = String
""
        show1 String
_ (Function []) = String
""
        show1 String
n (Function [([String], MutantS)]
bs) = Bool -> [String] -> [([String], MutantS)] -> String
showBindings Bool
new (String -> [String]
fvnames String
n) [([String], MutantS)]
bs
        show1 String
n MutantS
m             = let fn :: String
fn = [String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
fvnames String
n
                                    fn' :: String
fn' | Bool
new = String -> String
prime String
fn
                                        | Bool
otherwise = String
fn
                                in (String -> [String] -> String
apply String
fn' [] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = ")
                          String -> String -> String
`beside` MutantS -> String
showMutantS MutantS
m
showMutantSBindings Bool
new [String]
ns MutantS
m = Bool -> [String] -> MutantS -> String
showMutantSBindings Bool
new [String]
ns ([MutantS] -> MutantS
Tuple [MutantS
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 :: [String] -> [([String], MutantS)] -> String
showLambda []    [] = String
"undefined {- (err?) unmutated -}"
showLambda (String
n:[String]
_) [] = String -> [String] -> String
apply String
n []
showLambda [String]
_ [([],MutantS
m)]   = MutantS -> String
showMutantS MutantS
m
showLambda [String]
_ (([],MutantS
_):[([String], MutantS)]
_) = String
"undefined {- (err?) ambiguous value -}"
showLambda [String]
ns [([String], MutantS)]
bs = ((String
"\\" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
bound String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> ") String -> String -> String
`beside`)
                 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"case " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
showTuple [String]
bound String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of\n"
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
`beside` String
cases
  where
    cases :: String
cases = (([String], MutantS) -> String) -> [([String], MutantS)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\([String]
as,MutantS
r) -> ([String] -> String
showTuple [String]
as String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> ") String -> String -> String
`beside` MutantS -> String
showResult MutantS
r) [([String], MutantS)]
bs
         String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_ -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
apply String
fn [String]
bound
    showResult :: MutantS -> String
showResult (Function [([String], MutantS)]
bs') = [String] -> [([String], MutantS)] -> String
showLambda (String -> [String] -> String
apply String
fn [String]
boundString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
unbound) [([String], MutantS)]
bs'
    showResult MutantS
m              = MutantS -> String
showMutantS MutantS
m
    unbound :: [String]
unbound  = Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
bound) [String]
vns
    bound :: [String]
bound    = (String -> String -> String) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> String -> String
forall a b. a -> b -> a
const [String]
vns (([String], MutantS) -> [String]
forall a b. (a, b) -> a
fst (([String], MutantS) -> [String])
-> ([String], MutantS) -> [String]
forall a b. (a -> b) -> a -> b
$ [([String], MutantS)] -> ([String], MutantS)
forall a. [a] -> a
head [([String], MutantS)]
bs)
    (String
fn:[String]
vns) = [String]
ns [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
+- [String]
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 :: Bool -> [String] -> [([String], MutantS)] -> String
showBindings Bool
new [String]
ns [([String], MutantS)]
bs =
  String -> [[String]] -> String
table String
" " ([[String]] -> String) -> [[String]] -> String
forall a b. (a -> b) -> a -> b
$ (([String] -> MutantS -> [String])
-> ([String], MutantS) -> [String]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [String] -> MutantS -> [String]
showBind (([String], MutantS) -> [String])
-> [([String], MutantS)] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
`map` [([String], MutantS)]
bs)
           [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++ [String -> [String]
words (String -> [String] -> String
apply String
fn' [String]
bound) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"=", String -> [String] -> String
apply String
fn [String]
bound] | Bool
new]
  where
    showBind :: [String] -> MutantS -> [String]
showBind [String
a1,String
a2] MutantS
r | String -> Bool
isInfix String
fn' = [String
a1, String
fn', String
a2,   String
"=", MutantS -> String
showMutantS MutantS
r]
    showBind [String]
as MutantS
r                    = [String
fn'] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
as [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"=", MutantS -> String
showMutantS MutantS
r]
    fn' :: String
fn' | Bool
new = String -> String
prime String
fn
        | Bool
otherwise = String
fn
    bound :: [String]
bound    = (String -> String -> String) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> String -> String
forall a b. a -> b -> a
const [String]
vns (([String], MutantS) -> [String]
forall a b. (a, b) -> a
fst (([String], MutantS) -> [String])
-> ([String], MutantS) -> [String]
forall a b. (a -> b) -> a -> b
$ [([String], MutantS)] -> ([String], MutantS)
forall a. [a] -> a
head [([String], MutantS)]
bs)
    (String
fn:[String]
vns) = [String]
ns [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
+- [String]
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 :: String -> [String]
fvnames = [String] -> [String]
fvns' ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words
  where fvns' :: [String] -> [String]
        fvns' :: [String] -> [String]
fvns' [String
a,String
o,String
b] | String -> Bool
isInfix String
o = String
oString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String
a,String
b]
        fvns' []      = [String]
defaultNames
        fvns' [String]
fvs     = [String]
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 :: String -> [String] -> String
apply String
f [String
x,String
y] | String -> Bool
isInfix String
f = [String] -> String
unwords [String
x,String
f,String
y]
apply String
f [String]
xs = if String -> Bool
isInfix String
f
               then [String] -> String
unwords (String -> String
toPrefix String
fString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs)
               else [String] -> String
unwords (String
fString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs)

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

-- | Transform an infix operator into an infix function:
--
-- > toPrefix "`foo`" == "foo"
-- > toPrefix "+"     == "(+)"
toPrefix :: String -> String
toPrefix :: String -> String
toPrefix (Char
'`':String
cs) = String -> String
forall a. [a] -> [a]
init String
cs
toPrefix String
cs = Char
'('Char -> String -> String
forall a. a -> [a] -> [a]
:String
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

-- 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 :: String -> String
prime (Char
'`':String
cs) = Char
'`'Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
forall a. [a] -> [a]
init String
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'`" -- `foo` to `foo'`
prime (Char
'(':String
cs) = Char
'('Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
forall a. [a] -> [a]
init String
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-)" -- (+) to (+-)
prime String
cs | String -> Bool
isInfix String
cs = String
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-"    -- + to +-
         | Bool
otherwise  = String
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"    -- foo to foo'


mapFst :: (a->b) -> (a,c) -> (b,c)
mapFst :: (a -> b) -> (a, c) -> (b, c)
mapFst a -> b
f (a
x,c
y) = (a -> b
f a
x,c
y)

mapSnd :: (a->b) -> (c,a) -> (c,b)
mapSnd :: (a -> b) -> (c, a) -> (c, b)
mapSnd a -> b
f (c
x,a
y) = (c
x,a -> b
f a
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]
[a]
xs +- :: [a] -> [a] -> [a]
+- [a]
ys = [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) [a]
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 :: (a, b, c, d) -> (a, b, c, d) -> MutantS
mutantS (a
f,b
g,c
h,d
i) (a
f',b
g',c
h',d
i') = [MutantS] -> MutantS
Tuple [ a -> a -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS a
f a
f'
                                          , b -> b -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS b
g b
g'
                                          , c -> c -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS c
h c
h'
                                          , d -> d -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS d
i d
i' ]

instance (ShowMutable a, ShowMutable b, ShowMutable c,
          ShowMutable d, ShowMutable e)
      => ShowMutable (a,b,c,d,e) where
  mutantS :: (a, b, c, d, e) -> (a, b, c, d, e) -> MutantS
mutantS (a
f,b
g,c
h,d
i,e
j) (a
f',b
g',c
h',d
i',e
j') = [MutantS] -> MutantS
Tuple [ a -> a -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS a
f a
f'
                                               , b -> b -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS b
g b
g'
                                               , c -> c -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS c
h c
h'
                                               , d -> d -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS d
i d
i'
                                               , e -> e -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS e
j e
j' ]

instance (ShowMutable a, ShowMutable b, ShowMutable c,
          ShowMutable d, ShowMutable e, ShowMutable f)
      => ShowMutable (a,b,c,d,e,f) where
  mutantS :: (a, b, c, d, e, f) -> (a, b, c, d, e, f) -> MutantS
mutantS (a
f,b
g,c
h,d
i,e
j,f
k) (a
f',b
g',c
h',d
i',e
j',f
k') = [MutantS] -> MutantS
Tuple [ a -> a -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS a
f a
f'
                                                    , b -> b -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS b
g b
g'
                                                    , c -> c -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS c
h c
h'
                                                    , d -> d -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS d
i d
i'
                                                    , e -> e -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS e
j e
j'
                                                    , f -> f -> MutantS
forall a. ShowMutable a => a -> a -> MutantS
mutantS f
k f
k' ]

mutantSTuple :: [MutantS] -> MutantS
mutantSTuple :: [MutantS] -> MutantS
mutantSTuple = [MutantS] -> MutantS
Tuple