content: {-# OPTIONS_GHC -fglasgow-exts -fallow-incoherent-instances -fallow-undecidable-instances #-}
  
  module Examples.Paper where
  
  import Data.Generics.PlayTypeable
  import Data.Typeable
  import Control.Monad.State
  
  
  data Expr  =  Val  Int         -- a literal value
             |  Var  String      -- a variable
             |  Neg  Expr        -- negation
             |  Add  Expr  Expr  -- addition
             |  Sub  Expr  Expr  -- subtraction
             |  Mul  Expr  Expr  -- multiplication
             |  Div  Expr  Expr  -- division
             deriving (Eq, Show)
  
  data Foo a = Foo a
  
  
  typename_Foo = mkTyCon "Foo"
  instance Typeable1 Foo where { typeOf1 _ = mkTyConApp typename_Foo [] }
  instance Typeable a => Typeable (Foo a) where { typeOf = typeOfDefault }
  
  
  typename_Expr = mkTyCon "Expr"
  instance Typeable Expr where
      typeOf _ = mkTyConApp typename_Expr []
  
  
  {-
  -- manually written instance
  instance Play Expr where
      replaceChildren x =
          case x of
              Neg  a    -> ([a]    , \[a']     -> Neg  a'     )
              Add  a b  -> ([a,b]  , \[a',b']  -> Add  a' b'  )
              Sub  a b  -> ([a,b]  , \[a',b']  -> Sub  a' b'  )
              Mul  a b  -> ([a,b]  , \[a',b']  -> Mul  a' b'  )
              Div  a b  -> ([a,b]  , \[a',b']  -> Div  a' b'  )
              _         -> ([]     , \[]       -> x           )
  -}
  
  instance Play Expr where
      replaceChildren = replaceChildrenAll
  
  instance (Typeable a, Play a) => PlayAll Expr a where
      playAll x =
          case x of
              Val a    -> play Val |- a
              Var a    -> play Var |- a
              Neg a    -> play Neg |+ a
              Add a b  -> play Add |+ a |+ b
              Sub a b  -> play Add |+ a |+ b
              Mul a b  -> play Add |+ a |+ b
              Div a b  -> play Add |+ a |+ b
  
  
  
  {-
  instance Typeable a => Typeable (Foo a) where
      typeOf _ = mkTyConApp typename_Foo
  -}
  
  instance (PlayAll a (Foo a), Typeable a) => Play (Foo a) where
      replaceChildren = replaceChildrenAll
  
  
  instance (Typeable b, Typeable a, Play b, PlayAll a b) => PlayAll (Foo a) b where
      playAll (Foo x) = play Foo |+ x
  
  
  
  
  
  variables_bad :: Expr -> [String]
  variables_bad (Var  x    ) = [x]
  variables_bad (Val  x    ) = []
  variables_bad (Neg  x    ) = variables_bad x
  variables_bad (Add  x y  ) = variables_bad x ++ variables_bad y
  variables_bad (Sub  x y  ) = variables_bad x ++ variables_bad y
  variables_bad (Mul  x y  ) = variables_bad x ++ variables_bad y
  variables_bad (Div  x y  ) = variables_bad x ++ variables_bad y
  
  
  variables :: Expr -> [String]
  variables x = [y | Var y <- everything x]
  
  
  countDivZero :: Expr -> Int
  countDivZero x = length [() | Div _ (Val 0) <- everything x]
  
  
  simplify x = traverse f x
      where  f (Sub x y)           = Add x (Neg y)
             f (Add x y) | x == y  = Mul (Val 2) x
             f x                   = x
  
  
  mutants :: Expr -> [Expr]
  mutants x =  [gen (Val j)
               | (Val i, gen) <- everythingContext x
               , j <- [i-1, i+1]]
  
  
  depth :: Expr -> Int
  depth = fold (foldr max 0) $ const (+1)
  
  
  uniqueVars :: Expr -> Expr
  uniqueVars x = evalState (traverseM f x) vars
      where
          vars = ['x':show i | i <- [1..]]
  
          f (Var i)  = do  y:ys <- get
                           put ys
                           return (Var y)
          f x        = return x
  
  
  
  instance Play [alpha] where
      replaceChildren []     = ([]  , const [])
      replaceChildren (x:xs) = ([xs], \[xs] -> x:xs)
  
  