{-
Tock: a compiler for parallel languages
Copyright (C) 2007  University of Kent

This program is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation, either version 2 of the License, or (at your
option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License along
with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

-- #ignore-exports

-- | A module for testing building a control flow-graph from an AST.
module FlowGraphTest (qcTests) where

import Control.Monad.Identity
import Control.Monad.State

import Data.Generics (Data)
import Data.Graph.Inductive
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import System.Random
import Test.HUnit hiding (Node, State, Testable)
import Test.QuickCheck

import qualified AST as A
import CompState
import Data.Generics.Polyplate.Route
import FlowGraph
import Metadata
import PrettyShow
import TestFramework
import TestUtils
import Traversal
import Utils

-- | Makes a distinctive metatag for testing.  The function is one-to-one.
makeMeta :: Int -> Meta
makeMeta n = Meta (Just "FlowGraphTest") n 0

m0, m1, m2, m3, m4, m5, m6, m7, m8, m9, m10, m11, mU :: Meta
-- To make typing the tests as short as possible (typing a function call means bracketing is needed, which is a pain):
m0 = makeMeta 0
m1 = makeMeta 1
m2 = makeMeta 2
m3 = makeMeta 3
m4 = makeMeta 4
m5 = makeMeta 5
m6 = makeMeta 6
m7 = makeMeta 7
m8 = makeMeta 8
m9 = makeMeta 9
m10 = makeMeta 10
m11 = makeMeta 11
-- | For meta tags that shouldn't be used in the graph:
mU = makeMeta (-1)

-- | A subscripting function for meta-tags produced by makeMeta
sub :: Meta -> Int -> Meta
sub m n = m {metaColumn = n}

sm0, sm1, sm2, sm3, sm4, sm5, sm6, sm7, {- sm8,-} sm9, sm10, sm11 :: A.Process
-- Various abbreviations for unique A.Process items
sm0 = A.Skip m0
sm1 = A.Skip m1
sm2 = A.Skip m2
sm3 = A.Skip m3
sm4 = A.Skip m4
sm5 = A.Skip m5
sm6 = A.Skip m6
sm7 = A.Skip m7
--sm8 = A.Skip m8
sm9 = A.Skip m9
sm10 = A.Skip m10
sm11 = A.Skip m11

rep :: Data a => Meta -> A.Structured a -> A.Structured a
rep m = A.Spec mU (A.Specification mU (simpleName "i") (A.Rep m (A.For m undefined
  undefined undefined)))

-- | Shows a graph as a node and edge list.
showGraph :: (Graph g, Show a, Show b) => g a b -> String
showGraph g = " Nodes: " ++ show (labNodes g) ++ " Edges: " ++ show (labEdges g)

-- | A shortcut for nextId' 1.
nextId :: Data t => t -> State (Map.Map Meta Int) Int
nextId = nextId' 1

-- | Given an AST fragment, returns a unique integer associated with that meta-tag.
-- This is for when you may add nodes based on a certain meta-tag to the tree multiple times,
-- and you want to be able to differentiate between each use.
nextId' :: Data t => Int -> t -> State (Map.Map Meta Int) Int
nextId' inc t
  = do mp <- get
       case Map.lookup m mp of
         Just n -> do put $ Map.adjust ((+) inc) m mp
                      return n
         Nothing -> do put $ Map.insert m inc mp
                       return 0
       where m = findMeta_Data t

-- | Given a test name, a list of nodes, a list of root nodes, a list of edges and an AST fragment, tests that the
-- CFG produced from the given AST matches the nodes and edges.  The nodes do not have to have
-- the exact correct identifiers produced by the graph-building.  Instead, the graphs are checked
-- for being isomorphic, based on the meta-tag node labels (node E in the expected list is 
-- isomorphic to node A in the actual list if their meta tags are the same).
testGraph :: String -> [(Int, Meta)] -> [Int] -> [(Int, Int, EdgeLabel)] -> A.Process -> Test
testGraph testName nodes roots edges proc = testGraphF testName nodes roots edges (buildFlowGraphP testOps $ A.Only emptyMeta proc)

testGraph' :: String -> [(Int, Meta)] -> [Int] -> [(Int, Int, EdgeLabel)] -> A.AST -> Test
testGraph' testName nodes roots edges str = testGraphF testName nodes roots edges (buildFlowGraph testOps str)

testOps :: GraphLabelFuncs (State (Map.Map Meta Int)) Int
testOps = GLF nextId nextId nextId nextId nextId nextId nextId (nextId . snd) (nextId' 100) (nextId' 100)

testGraphF :: Data structType => String -> [(Int, Meta)] -> [Int] -> [(Int, Int, EdgeLabel)] -> State (Map.Map Meta Int) (Either String (FlowGraph' Identity Int structType, [Node],
  [Node])) -> Test
testGraphF testName nodes roots edges grF
  = TestCase $ 
      case evalState grF Map.empty of
        Left err -> assertFailure (testName ++ " graph building failed: " ++ err)
        Right gr -> checkGraphEquality (nodes, roots, edges) gr -- :: (FlowGraph' Identity Int structType, [Node]))
  where  
    -- Checks two graphs are equal by creating a node mapping from the expected graph to the real map (checkNodeEquality),
    -- then mapping the edges across (transformEdge) and checking everything is right (in checkGraphEquality)
    
--    deNode :: Monad m => FNode' m a b -> (Meta, a)
    deNode nd = (getNodeMeta nd, getNodeData nd)
        
    checkGraphEquality :: (Data a, Monad m) => ([(Int, Meta)], [Int], [(Int, Int, EdgeLabel)]) -> (FlowGraph' m Int a, [Int],
      [Int]) -> Assertion
    checkGraphEquality (nodes, roots, edges) (g, actRoots, _)
      = do let (remainingNodes, nodeLookup, ass) = foldl checkNodeEquality (Map.fromList (map revPair nodes),Map.empty, return ()) (map (transformPair id deNode) $ labNodes g)
           ass
           assertBool (testName ++ " Expected graph had nodes not found in the real graph: " ++ show remainingNodes ++ ", real graph: " ++ showGraph g) (Map.null remainingNodes)
           roots' <- mapM (transformNode nodeLookup) roots
           assertEqual (testName ++ " Root lists not equal") (sort roots') (sort actRoots)
           edges' <- mapM (transformEdge nodeLookup) edges
           assertEqual (testName ++ " Edge lists not equal") (sort $ edges') (sort $ labEdges g)
    
    checkNodeEquality :: (Map.Map Meta Int, Map.Map Int Int, Assertion) -> (Node, (Meta, Int)) -> (Map.Map Meta Int, Map.Map Int Int, Assertion)
    checkNodeEquality (metaToTestId, realToTestId, ass) (nodeId, (metaTag,metaSub))
      = case Map.lookup (sub metaTag metaSub) metaToTestId of
          Nothing -> (metaToTestId, realToTestId, ass >> assertFailure (testName ++ " Node with meta tag " ++ show (sub metaTag metaSub) ++ " not found in expected test data"))
          Just testId -> let realToTestId' = Map.insert testId nodeId realToTestId in
                         let metaToTestId' = Map.delete (sub metaTag metaSub) metaToTestId in
                         (metaToTestId', realToTestId', ass)
    transformEdge :: Show b => Map.Map Int Int -> (Int, Int, b) -> IO (Int, Int, b)
    transformEdge nodeMap e@(start, end, label)
      = case mergeMaybe (Map.lookup start nodeMap) (Map.lookup end nodeMap) of
          Nothing -> do assertFailure ("Could not map test edge to real edge: " ++ show e)
                        return e
          Just (start', end') -> return (start', end', label)

    transformNode :: Map.Map Int Int -> Int -> IO Int
    transformNode m n = case Map.lookup n m of
      Just n' -> return n'
      Nothing -> assertFailure (testName ++ " could not find root node in new graph: " ++ show n) >> return n

-- | A helper function for making simple A.Specification items.
someSpec :: Meta -> A.Specification
someSpec m = A.Specification m (simpleName $ show m) (A.DataType m A.Int)
               
testSeq :: Test
testSeq = TestLabel "testSeq" $ TestList
 [
   testSeq' 0 [(0,m1)] [] (A.Several m1 [])
  ,testSeq' 1 [(0,m2)] [] (A.Only m1 sm2)
  ,testSeq' 2 [(0,m3)] [] (A.Several m1 [A.Only m2 sm3])
  ,testSeq' 3 [(0,m3),(1,m5)] [(0,1,ESeq Nothing)] (A.Several m1 [A.Only m2 sm3,A.Only m4 sm5])
  ,testSeq' 4 [(0,m3),(1,m5),(2,m7)] [(0,1,ESeq Nothing),(1,2,ESeq Nothing)] (A.Several m1 [A.Only m2 sm3,A.Only m4 sm5,A.Only m6 sm7])
  ,testSeq' 5 [(0,m3),(1,m5)] [(0,1,ESeq Nothing)] (A.Several m1 [A.Several m1 [A.Only m2 sm3],A.Several m1 [A.Only m4 sm5]])
  ,testSeq' 6 [(0,m3),(1,m5),(2,m7),(3,m9)] [(0,1,ESeq Nothing),(1,2,ESeq Nothing),(2,3,ESeq Nothing)] 
    (A.Several m1 [A.Several m1 [A.Only m2 sm3,A.Only m4 sm5,A.Only m6 sm7], A.Only m8 sm9])
    
  ,testSeq' 10 [(0,m1),(1,m4),(100,sub m1 100)] [(0,1,ESeq Nothing),(1,100,ESeq Nothing)] (A.Spec mU (someSpec m1) $ A.Only m3 sm4)
  ,testSeq'' 11
    [(1,m1),(3,m4),(5,m5),(7,m7),(9,m10),(101,sub m1 100),(105,sub m5 100),(107,sub m7 100)] [1]
    [(1,3,ESeq Nothing),(3,101,ESeq Nothing),(101,5,ESeq Nothing),(5,7,ESeq Nothing),(7,9,ESeq Nothing),(9,107,ESeq Nothing),(107,105,ESeq Nothing)]
    (A.Several m11 [A.Spec mU (someSpec m1) $ A.Only m3 sm4,A.Spec mU (someSpec m5) $ A.Spec mU (someSpec m7) $ A.Only m9 sm10])

  ,testSeq' 12 [(0,m1),(4,m4),(100,sub m1 100)] [(0,4,ESeq Nothing),(4,100,ESeq Nothing)] (A.Spec mU (someSpec m1) $ A.Several m4 [])

  -- Replicated SEQ:
  
  ,testSeq' 100 [(0,m10), (1,m3), (2,m5)] [(0,1,ESeq Nothing), (1,2,ESeq Nothing), (2,0,ESeq Nothing)]
    (rep m10 $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5])

  ,testSeq'' 101 [(0,m8), (1,m3), (2,m5),(3,m9),(4,m11)] [3] [(3,0,ESeq Nothing),(0,1,ESeq Nothing), (1,2,ESeq Nothing), (2,0,ESeq Nothing),(0,4,ESeq Nothing)]
    (A.Only mU $ A.Seq m6 $ A.Several m7
      [A.Only mU sm9
      ,(rep m8 $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5])
      ,A.Only mU sm11])

  ,testSeq' 102 [(0,m10), (1,m1)] [(0,1,ESeq Nothing), (1,0,ESeq Nothing)]
    (rep m10 $ A.Several m1 [])

  ,testSeq' 103 [(1,m10), (0,m1), (2,m2), (3,m3)] [(0,1,ESeq Nothing),(1,3,ESeq Nothing), (3,1,ESeq Nothing),(1,2,ESeq Nothing)]
    (A.Several mU [A.Only mU sm1, (rep m10 $ A.Several m3 []), A.Only mU sm2])

 ]
  where
    testSeq' :: Int -> [(Int, Meta)] -> [(Int, Int, EdgeLabel)] -> A.Structured A.Process -> Test
    testSeq' n a b s = testSeq'' n a [0] b s

    testSeq'' :: Int -> [(Int, Meta)] -> [Int] -> [(Int, Int, EdgeLabel)] -> A.Structured A.Process -> Test
    testSeq'' n a r b s = testGraph ("testSeq " ++ show n) a r b (A.Seq m0 s)
    
testPar :: Test
testPar = TestLabel "testPar" $ TestList
 [
   testPar' 0 [] [(0,99,ESeq Nothing)] (A.Several m1 [])
  ,testPar' 1 [(1,m2)] [(0,1,EStartPar 0), (1,99,EEndPar 0)] (A.Only m1 sm2)
  ,testPar' 2 [(1,m3)] [(0,1,EStartPar 0), (1,99,EEndPar 0)] (A.Several m1 [A.Only m2 sm3])
  ,testPar' 3 [(1, m3), (2, m5)]
              [(0,1,EStartPar 0),(1,99,EEndPar 0), (0,2,EStartPar 0), (2,99,EEndPar 0)]
              (A.Several m1 [A.Only m2 sm3,A.Only m4 sm5])
  ,testPar' 4 [(3,m3),(5,m5),(7,m7)]
              [(0,3,EStartPar 0),(3,99,EEndPar 0),(0,5,EStartPar 0),(5,99,EEndPar 0),(0,7,EStartPar 0),(7,99,EEndPar 0)] 
              (A.Several m1 [A.Only m2 sm3,A.Only m4 sm5,A.Only m6 sm7])
  ,testPar' 5 [(1, m3), (2, m5)]
              [(0,1,EStartPar 0),(1,99,EEndPar 0), (0,2,EStartPar 0), (2,99,EEndPar 0)]
              (A.Several mU [A.Several mU [A.Only m2 sm3],A.Several mU [A.Only m4 sm5]])
  ,testPar' 6 [(3,m3),(5,m5),(7,m7),(9,m9)]
              [(0,3,EStartPar 0), (0,5,EStartPar 0), (0,7,EStartPar 0), (0,9,EStartPar 0)
              ,(3,99,EEndPar 0), (5,99,EEndPar 0), (7,99,EEndPar 0), (9,99,EEndPar 0)]
              (A.Several m1 [A.Several m10 [A.Only m2 sm3,A.Only m4 sm5,A.Only m6 sm7], A.Only m8 sm9])

  ,testPar' 10 [(1, m3), (2, m5), (6, m6),(106,sub m6 100)]
               [(0,6,EStartPar 0),(6,1,ESeq Nothing),(1,106,ESeq Nothing),(106,99,EEndPar 0), (0,2,EStartPar 0), (2,99,EEndPar 0)]
               (A.Several m1 [A.Spec mU (someSpec m6) $ A.Only m2 sm3,A.Only m4 sm5])
  ,testPar' 11 [(1, m3), (2, m5), (3,m7), (6, m6),(106,sub m6 100)]
               [(0,6,EStartPar 0),(6,1,EStartPar 1),(6,2,EStartPar 1),(1,106,EEndPar 1),(2,106,EEndPar 1)
               ,(106,99,EEndPar 0), (0,3,EStartPar 0), (3,99,EEndPar 0)]
               (A.Several m1 [A.Spec mU (someSpec m6) $ A.Several mU [A.Only mU sm3, A.Only mU sm5], A.Only mU sm7])

  ,testPar' 20 [(1,m1),(100,sub m1 100)] [(0,1,EStartPar 0),(1,100,ESeq Nothing),(100,99,EEndPar 0)] (A.Spec mU (someSpec m1) $ A.Several m4 [])

  --TODO test nested pars

  
  -- Replicated PAR:
  
  ,testPar' 100 [(1,m6), (2,m3), (3,m5), (4, sub m6 1)]
    [(0,1,EStartPar 0), (1,2,EStartPar 1), (2,4,EEndPar 1), (1,3,EStartPar 1), (3,4,EEndPar 1), (4,99,EEndPar 0)]
    (rep m6 $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5])  

  ,testPar' 101 [(1,m1), (2,m2), (3,m3), (11,sub m1 1), (4,m4), (5,m5), (6,m6), (7,m7), (15, sub m5 1)]
    -- The links in the main PAR:
    [(0,1,EStartPar 0), (11,99,EEndPar 0), (0,4,EStartPar 0), (4,99,EEndPar 0), (0,5,EStartPar 0), (15,99,EEndPar 0)
    -- The links in the first replication:
    ,(1,2,EStartPar 1), (2,11,EEndPar 1), (1,3,EStartPar 1), (3,11,EEndPar 1)
    -- The links in the second replication:
    ,(5,6,EStartPar 2), (6,15,EEndPar 2), (5,7,EStartPar 2), (7,15,EEndPar 2)]
      
    (A.Several mU
      [(rep m1 $ A.Several mU [A.Only mU sm2,A.Only mU sm3])
      ,A.Only mU sm4
      ,(rep m5 $ A.Several mU [A.Only mU sm6,A.Only mU sm7])])

  ,testPar' 102 [(1,m6), (4, sub m6 1)]
    [(0,1,EStartPar 0), (1,4,ESeq Nothing), (4,99,EEndPar 0)]
    (rep m6 $ A.Several mU [])
 ]
  where
    testPar' :: Int -> [(Int, Meta)] -> [(Int, Int, EdgeLabel)] -> A.Structured A.Process -> Test
    testPar' n a b s = testGraph ("testPar " ++ show n) (a ++ [(0,m0), (99,sub m0 1)]) [0] b (A.Par m0 A.PlainPar s)

testWhile :: Test
testWhile = TestLabel "testWhile" $ TestList
 [
    testGraph "testWhile 0" [(0,m0), (1,m1), (2, m2)] [0] [(0,1,ESeq $ Just (0,
      Just True)), (1,0,ESeq $ Just (0, Nothing)), (0,2, ESeq $ Just (0, Just False))]
      (A.While m2 (A.True m0) sm1)

   ,testGraph "testWhile 1" [(2,m2), (3, m3), (5, m5), (8, m8)] [2]
      [(2,3,ESeq $ Just (0, Just True)), (3,2,ESeq $ Just (0, Nothing)), (8,5,ESeq Nothing), (2,8, ESeq
        $ Just (0, Just False))] 
      (A.Seq m0 $ A.Several m1 [A.Only m9 $ A.While m8 (A.True m2) sm3,A.Only m4 sm5])

   ,testGraph "testWhile 2" [(2,m2), (3, m3), (5, m5), (7, m7), (8, m8)] [7]
     [(7,2,ESeq Nothing), (2,3,ESeq $ Just (0, Just True)), (3,2,ESeq $ Just (0, Nothing)),
      (2, 8, ESeq $ Just (0, Just False)), (8,5,ESeq Nothing)] 
      (A.Seq m0 $ A.Several m1 [A.Only m6 sm7,A.Only m9 $ A.While m8 (A.True m2) sm3,A.Only m4 sm5])

   ,testGraph "testWhile 3" [(2,m2), (3, m3), (5, m5), (7, m7), (9, m9), (8, m8)] [7]
     [(7,2,ESeq Nothing), (2,3,ESeq $ Just (0, Just True)), (3,9,ESeq Nothing), (9,2,ESeq $
       Just (0, Nothing)), (2, 8, ESeq $ Just (0, Just False)), (8,5,ESeq Nothing)] 
      (A.Seq m0 $ A.Several m1 [A.Only m6 sm7,A.Only mU $ A.While m8 (A.True m2) $ A.Seq mU $ A.Several mU [A.Only mU sm3,A.Only mU sm9],A.Only m4 sm5])
 ]

testCase :: Test
testCase = TestLabel "testCase" $ TestList
 [
   testGraph "testCase 0" [(0,m10),(1,m0),(2,m3)] [0] [(0,2,ESeq Nothing),(2,1,ESeq Nothing)] (A.Case m0 (A.True m10) $ cases m1 [A.Else m2 sm3])
  ,testGraph "testCase 1"
     [(0,m10),(1,m0),(2,m2),(3,m3)] [0]
     [(0,2,ESeq Nothing),(2,3,ESeq Nothing),(3,1,ESeq Nothing)]
     (A.Case m0 (A.True m10) $ cases mU [A.Option mU [A.True m2] sm3])
  ,testGraph "testCase 2"
     [(0,m10),(1,m0), (2,m2), (3,m3), (4, m4), (5,m5)] [0]
     [(0,2,ESeq Nothing), (2,3,ESeq Nothing), (3,1,ESeq Nothing), (0,4,ESeq Nothing), (4,5,ESeq Nothing), (5,1,ESeq Nothing)]
     (A.Case m0 (A.True m10) $ cases m1 [A.Option mU [A.True m2] sm3, A.Option mU [A.True m4] sm5])
  --TODO test case statements that have specs
 ]
 where
   cases :: Meta -> [A.Option] -> A.Structured A.Option
   cases m = (A.Several m) . (map (A.Only mU))

testIf :: Test
testIf = TestLabel "testIf" $ TestList
 [
   -- Remember that the last branch of an IF doesn't link to the end of the IF, because
   -- occam stops if no option is found.
 
   testGraph "testIf 0" [(0,m0), (1,sub m0 1), (2,m2), (4, sub m2 1), (3,m3), (5,
     sub m0 2)] [0]
     [(0,2,nt),(2,3,tr 0), (2,4, fal 0), (3,1,nt), (1, 5, inv 0)]
     (A.If m0 $ ifs mU [(A.True m2, sm3)])

  ,testGraph "testIf 1" [(0,m0), (1,sub m0 1), (2,m2), (12, m2 `sub` 1), (3,m3),
                         (4,m4), (14, m4 `sub` 1), (5, m5), (11, sub m0 2), (21,
                           sub m0 3)] [0]
                        [(0,2,nt),(2,3,tr 0),(3,1,nt),(2,12, fal 0), (12, 4, nt),
                         (4,5,tr 1),(5,1,nt),(4,14,fal 1), (1, 11, inv 1), (11,
                           21, inv 0)]
                        (A.If m0 $ ifs mU [(A.True m2, sm3), (A.True m4, sm5)])

  ,testGraph "testIf 2" [(0,m0), (1,sub m0 1), (2,m2), (12, m2 `sub` 1), (3,m3),
                         (4,m4), (14, m4 `sub` 1), (5, m5), (6, m6), (16, m6 `sub` 1),(7, m7),
                         (11, sub m0 2), (21, sub m0 3), (31, sub m0 4)] [0]
                        [(0,2,nt),(2,3,tr 0),(3,1,nt),(2,12,fal 0),(12,4,nt),
                         (4,5,tr 1),(5,1,nt),(4,14,fal 1),
                         (14,6,nt),(6,7,tr 2),(7,1,nt),(6,16,fal 2),
                         (1,11,inv 2), (11, 21, inv 1), (21, 31, inv 0)]
                        (A.If m0 $ ifs mU [(A.True m2, sm3), (A.True m4, sm5), (A.True m6, sm7)])

{-
  -- TODO test specs in Ifs
  #error
   testGraph "testIf 3" [(0,m0), (1,sub m0 1), (2,m2), (3,m3), (4,m4), (5, sub m4 1), (6, sub m4 2)] [0]
     [(0,4,nt),(4,2,nt),(2,3,nt),(3,5,nt), (5,1,nt), ]
     (A.If m0 $ A.Spec mU (someSpec m4) $ ifs mU [(A.True m2, sm3)])  
-}     

  ,testGraph "testIf 10" [(0,m0), (1,sub m0 1), (2,m2), (12, m2 `sub` 1), (3,m3), (5, m5),
      (11, sub m0 2)] [0]
    [(0,5,nt), (5,2,nt), (2,3,tr 0), (3,1,nt), (2,12, fal 0), (12, 5, nt), (1, 11, inv 0)]
    (A.If m0 $ rep m5 $ ifs mU [(A.True m2, sm3)])

  ,testGraph "testIf 11" [(0,m0), (1,sub m0 1), (2,m2), (12, m2 `sub` 1), (3,m3), (5, m5), (6, m6), (16,
    m6 `sub` 1), (7, m7), (11, sub m0 2), (21, sub m0 3)] [0]
    [(0,5,nt), (5,2,nt), (2,3,tr 0), (3,1,nt), (2,12,fal 0), (12, 6, nt), (6,7,tr
      1), (7,1,nt), (6,16,fal 1),(16, 5, nt), (1, 11, inv 1), (11, 21, inv 0)]
    (A.If m0 $ rep m5 $ ifs mU [(A.True m2, sm3), (A.True m6, sm7)])    

  ,testGraph "testIf 12" [(0,m0), (1,sub m0 1), (2,m2), (3,m3), (5, m5), (6, m6), (7, m7), (8, m8), (9, m9),
    (12, m2 `sub` 1), (16,  m6 `sub` 1), (18,  m8 `sub` 1), (11, sub m0 2),  (21,
      sub m0 3), (31, sub m0 4)] [0]
    [(0,5,nt), (5,2,nt), (2,3,tr 0), (3,1,nt), (2,12,fal 0), (12, 6, nt),
     (6,7,tr 1), (7,1,nt), (6,16,fal 1), (16, 5, nt), (5,8,nt),
     (8,9,tr 2), (9,1,nt),(8,18,fal 2), (1,11, inv 2), (11, 21, inv 1), (21, 31,
       inv 0)]
    (A.If m0 $ A.Several mU [rep m5 $ ifs mU [(A.True m2, sm3), (A.True m6, sm7)]
                            , ifs mU [(A.True m8, sm9)]])
 ]
 where
   fal n = ESeq $ Just (n, Just False)
   tr n = ESeq $ Just (n, Just True)
   inv n = ESeq $ Just (n, Nothing)
   nt = ESeq Nothing
   
   ifs :: Meta -> [(A.Expression, A.Process)] -> A.Structured A.Choice
   ifs m = (A.Several m) . (map (\(e,p) -> A.Only mU $ A.Choice (findMeta e) e p))

testProcFuncSpec :: Test
testProcFuncSpec = TestLabel "testProcFuncSpec" $ TestList
  [
   -- Single spec of process (with SKIP body) in AST (not connected up):
    testGraph' "testProcFuncSpec 0" [(0, m0), (5,m5)] [5] [(5,0,ESeq Nothing)]
      (A.Spec mU (A.Specification m1 undefined $ A.Proc m5 undefined undefined $ Just sm0) $ A.Several mU [])
      
   -- Single spec of process (with body with SEQ SKIP SKIP):
   ,testGraph' "testProcFuncSpec 1" [(0, m3), (4,m5), (9,m9)] [9] ([(9,0,ESeq Nothing), (0,4,ESeq Nothing)])
      (A.Spec mU (A.Specification m6 undefined $ A.Proc m9 undefined undefined $
        Just $ A.Seq m0 $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5]
      ) $ A.Several mU [])
   -- Nested spec of process (with bodies with SEQ SKIP SKIP):
   ,testGraph' "testProcFuncSpec 2" [(3,m2),(4,m3),(5,m4),(6,m5), (10,m10), (11, m11)] [10,11]
      ([(10,3,ESeq Nothing), (3,4,ESeq Nothing)] ++ [(11,5,ESeq Nothing), (5,6,ESeq Nothing)])
      (A.Spec mU (A.Specification m6 undefined $ A.Proc m10 undefined undefined $
        Just $ A.Seq mU $ A.Several mU [A.Only mU sm2,A.Only mU sm3]
      ) $ 
       A.Spec mU (A.Specification m7 undefined $ A.Proc m11 undefined undefined $
        Just $ A.Seq mU $ A.Several mU [A.Only mU sm4,A.Only mU sm5]
      )  
      $ A.Several mU [])
      
   -- Single spec of process (with SKIP body) in a SEQ (connected up):
   ,testGraph "testProcFuncSpec 10" [(0, m0),(1,m1),(2,sub m1 100), (3, m3), (5,m5)] [1,5] [(5,0,ESeq Nothing), (1,3,ESeq Nothing), (3,2,ESeq Nothing)]
      (A.Seq mU $ A.Spec mU (A.Specification m1 undefined $ A.Proc m5 undefined undefined $ Just sm0) $ A.Several m3 [])
      
  ]

testAlt :: Test
testAlt = TestLabel "testAlt" $ TestList
  [
    -- ALTs have a control-flow pattern of going through all the specs, scoping them in, then
    -- branching to a guard, then doing the guard and body, then scoping everything out.
    
    testGraph "testAlt 0" [(0, m1), (1, sub m1 1), (4,m4), (5,m5)] [0]
      [(0,4,ESeq Nothing), (4,5,ESeq Nothing), (5,1,ESeq Nothing)]
      (A.Alt m1 False $ A.Only mU guard45)
   ,testGraph "testAlt 1" [(0, m1), (1, sub m1 1), (4,m4), (5,m5), (6, m6), (7, m7)] [0]
      [(0,4,ESeq Nothing), (0,6,ESeq Nothing), (4,5,ESeq Nothing), (6,7,ESeq Nothing), (5,1,ESeq Nothing), (7,1,ESeq Nothing)]
      (A.Alt m1 False $ A.Several mU $ map (A.Only mU) [guard45, guard67])

   ,testGraph "testAlt 2" [(0, m1), (1, sub m1 1), (4,m4), (5,m5), (8,m8), (18, sub m8 100)] [0]
      [(0,8,ESeq Nothing), (8,4,ESeq Nothing), (4,5,ESeq Nothing), (5,18,ESeq Nothing), (18,1,ESeq Nothing)]
      (A.Alt m1 False $ spec8 $ A.Only mU guard45)
   ,testGraph "testAlt 3" [(0, m1), (1, sub m1 1), (4,m4), (5,m5), (8,m8), (18, sub m8 100), (9,m9), (19, sub m9 100)] [0]
      [(0,8,ESeq Nothing), (8,9,ESeq Nothing), (9,4,ESeq Nothing), (4,5,ESeq Nothing), (5,19,ESeq Nothing), (19,18,ESeq Nothing), (18,1,ESeq Nothing)]
      (A.Alt m1 False $ spec8 $ spec9 $ A.Only mU guard45)      

   ,testGraph "testAlt 4" [(0, m1), (1, sub m1 1), (4,m4), (5,m5), (6, m6), (7, m7), (8,m8), (18, sub m8 100)] [0]
      [(0,8,ESeq Nothing), (8,4,ESeq Nothing), (8,6,ESeq Nothing), (4,5,ESeq Nothing), (6,7,ESeq Nothing), (5,18,ESeq Nothing), (7,18,ESeq Nothing), (18, 1, ESeq Nothing)]
      (A.Alt m1 False $ A.Several mU $ [A.Only mU guard45, spec8 $ A.Only mU guard67])

   ,testGraph "testAlt 5" [(0, m1), (1, sub m1 1), (4,m4), (5,m5), (6, m6), (7, m7), (8,m8), (18, sub m8 100), (9,m9), (19, sub m9 100)] [0]
      [(0,9,ESeq Nothing), (9,8,ESeq Nothing),(8,4,ESeq Nothing), (8,6,ESeq Nothing), (4,5,ESeq Nothing), (6,7,ESeq Nothing), (5,18,ESeq Nothing), (7,18,ESeq Nothing), (18, 19, ESeq Nothing), (19,1,ESeq Nothing)]
      (A.Alt m1 False $ A.Several mU $ [spec9 $ A.Only mU guard45, spec8 $ A.Only mU guard67])

   -- TODO test replicated ALTs
   -- TODO test specs inside replicated ALTs

  ]
  where
    guard45 = A.AlternativeSkip m4 (A.True mU) sm5
    guard67 = A.Alternative m6 (A.True mU) (variable "c") (A.InputSimple mU []) sm7

    spec8, spec9 :: Data a => A.Structured a -> A.Structured a
    spec8 = A.Spec mU (A.Specification m8 undefined undefined)
    spec9 = A.Spec mU (A.Specification m9 undefined undefined)

--TODO occam stuff:
--TODO test input-case statements
--TODO test replicated ifs


-- The idea here is that each time we generate an interesting node,
-- we want to generate its replaced version too.  Then combine these as
-- we go back up the tree to form a set of all possible trees (which is like the powerset of possible replacements, I think).
-- We also want to ensure that the meta tags are unique (to label replacements), and I don't think
-- QuickCheck easily supports that.

-- So how to do this, given that QuickCheck expects something of type Gen a to come
-- back out of Arbitrary?  We could generate Gen [a], with the understanding that the head
-- is the source, all the others are possible replacements.  But then we need to label the replacements,
-- which means we'd want Gen [([Meta],a)]

-- However, in order to ensure we make unique meta tags, we have to add the StateT Int wrapper:

-- | A newtype based on Int, to avoid confusion with other uses of Int.
newtype Id = Id Int

-- | Turns the Id newtype back into a plain Int
fromId :: Id -> Int
fromId (Id n) = n

-- | Similar to makeMeta, but takes an Id as its argument.
makeMeta' :: Id -> Meta
makeMeta' = makeMeta . fromId

-- | The monad type for generating ASTs.  The StateT wrapped is needed for making
-- the meta tags unique, and the reason for the strange generation type is explained in
-- earlier comments.
type GenL a = StateT Id Gen [([Meta], a)]

-- | A helper function for making a simple meta-tag replacement operation.
replaceMeta :: Meta -> Meta
replaceMeta m = sub m 8

-- | Given a meta tag, returns the standard and replaced versions of it.
genMeta :: Meta -> GenL Meta
genMeta m = return [([],m),([m],replaceMeta m)]

-- Helper functions for dealing with the AST:

-- | The genElemN functions take an AST constructor (that has Meta as its first item)
-- then the appropriate Meta tag and optional further arguments, and returns the standard
-- and replaced combinations across all of them using the combN functions.
genElem1 :: (Meta -> b) -> Meta -> GenL b
genElem1 f m = comb1 f (genMeta m)

genElem2 :: (Meta -> a0 -> b) -> Meta -> GenL a0 -> GenL b
genElem2 f m = comb2 f (genMeta m)

genElem3 :: (Meta -> a0 -> a1 -> b) -> Meta -> GenL a0 -> GenL a1 -> GenL b
genElem3 f m = comb3 f (genMeta m) 

genElem4 :: (Meta -> a0 -> a1 -> a2 -> b) -> Meta -> GenL a0 -> GenL a1 -> GenL a2 -> GenL b
genElem4 f m = comb4 f (genMeta m) 

-- | A helper function for turning any item that can't be replaced into a GenL form (esp.
-- for use as a parameter of genElemN).
comb0 :: forall a. a -> GenL a
comb0 x = return [([],x)]

-- | The combN functions (N >= 1) take a constructor, then the appropriate number of GenL
-- items, and works out all possible combinations of replacements and so on.  The number
-- of replacements can get very large (2^K, where K is the number of GenL parameters that
-- can be replaced).
comb1 :: forall a0 b. (a0 -> b) -> GenL a0 -> GenL b
comb1 func list0 = list0 >>* map process1
  where
    process1 :: ([Meta], a0) -> ([Meta],b)
    process1 = transformPair id func

comb2 :: forall a0 a1 b. (a0 -> a1 -> b) -> GenL a0 -> GenL a1 -> GenL b
comb2 func list0 list1 = (liftM2 (,)) list0 list1 >>* product2 >>* map (uncurry process2)
  where
    process2 :: ([Meta], a0) -> ([Meta], a1) -> ([Meta],b)
    process2 (keys0, val0) (keys1, val1) = (keys0++keys1, func val0 val1)
    
comb3 :: forall a0 a1 a2 b. (a0 -> a1 -> a2 -> b) -> GenL a0 -> GenL a1 -> GenL a2 -> GenL b
comb3 func list0 list1 list2 = (liftM3 (,,)) list0 list1 list2 >>* product3 >>* map (uncurry3 process3)
  where
    process3 :: ([Meta], a0) -> ([Meta], a1) -> ([Meta],a2) -> ([Meta],b)
    process3 (keys0, val0) (keys1, val1) (keys2, val2) = (keys0++keys1++keys2, func val0 val1 val2)


comb4 :: forall a0 a1 a2 a3 b. (a0 -> a1 -> a2 -> a3 -> b) -> GenL a0 -> GenL a1 -> GenL a2 -> GenL a3 -> GenL b
comb4 func list0 list1 list2 list3 = (liftM4 (,,,)) list0 list1 list2 list3 >>* product4 >>* map (uncurry4 process4)
  where
    process4 :: ([Meta], a0) -> ([Meta], a1) -> ([Meta],a2) -> ([Meta],a3) -> ([Meta],b)
    process4 (keys0, val0) (keys1, val1) (keys2, val2) (keys3, val3) = (keys0++keys1++keys2++keys3, func val0 val1 val2 val3)


-- | Wrapper for Quickcheck.
-- In order to stop conflict with Quickcheck's in-built rules for things such as pairs
-- (which do not allow overlapping instances), we have to wrap such types ourself.
newtype QC a = QC a deriving (Eq)

-- | We don't allow size zero for generating trees.
-- So we cheat by changing the size to 1, if it is 0.
enforceSize1 :: Gen a -> Gen a
enforceSize1 f = sized $ \n -> if n == 0 then resize 1 f else f

-- | An instance of Arbitrary for A.Structured that wraps the "genStructured" function.
instance Arbitrary (QC (A.Process, Map.Map [Meta] A.Process)) where
  arbitrary = enforceSize1 $ sized $ \n -> evalStateT (genProcess n) (Id 0) >>* findEmpty >>* QC
    where
      -- Copies the value for the empty-list key into the first element of the tuple:
      findEmpty :: [([Meta], a)] -> (a, Map.Map [Meta] a)
      findEmpty xs = (fromJust $ Map.lookup [] m, m)
        where m = Map.fromList xs

  -- coarbitrary is for defined "twiddle" functions over data generated by arbitrary.
  -- For example, we could have the twiddle functions changing an expression
  -- in the tree.  I don't think this would be of use right now, given what we're testing

instance Show (QC (A.Process, Map.Map [Meta] A.Process)) where
  show (QC (p,m)) = pshow (p,nub $ concat $ Map.keys m)

-- | A function inside a StateT monad that returns the next unique Id.
nextIdT :: Monad m => StateT Id m Id
nextIdT = modify' incId
  where
    incId :: Id -> Id
    incId (Id n) = (Id $ n+1)

-- | A function similar to the QuickCheck oneof function, that works on GenL stuff rather than Gen.
oneofL :: [GenL a] -> GenL a
oneofL [] = fail "Empty list fed to oneofL"
oneofL gs = do i <- lift $ choose (0,length gs-1)
               gs !! i

-- | A function that takes in a list of sized items.  The first thing in the pair is the minimum size
-- of an item produced, and the second is a function that maps a size into a GenL.  One of these
-- functions is chosen and returned, with the obvious constraint that only generators whose
-- minimum size is satisfied will be called.
--
-- TODO at the moment I think I've generally estimated size.  Size should refer to the number of items
-- that can potentially be replaced, but I'm not sure that is always strictly kept to.  Still, it's
-- a close enough approximation.
oneofLS :: [(Int, Int -> GenL a)] -> Int -> GenL a
oneofLS fs n = oneofL $ applyAll n filtered
  where
    filtered = filterFuncs n fs
  
    filterFuncs :: Int -> [(Int, Int -> GenL a)] -> [Int -> GenL a]
    filterFuncs sz = map snd . filter ((<= sz) . fst)

-- | A function that takes a "find" parameter, a "replace" parameter, and returns a monadic function
-- (for convenience) that performs the check\/replacement.
replaceM :: (Eq a, Monad m) => a -> a -> (a -> m a)
replaceM find replace x | find == x = return replace
                        | otherwise = return x

-- | A little helper function for generating random lists of numbers.  Given a total,
-- this generates a list of random numbers that sum to that total.  The function is of course recursive,
-- and each number is between 1 and the remaining total (evenly distributed).  This does mean
-- that the earlier items in the list will tend to be larger than the later items, and I think
-- there is a high chance of the last item in the list being 1.  But hopefully for our tests this
-- isn't major limitation.
genNumsToTotal :: Int -> Gen [Int]
genNumsToTotal 0 = return []
genNumsToTotal n = do ch <- choose (1,n)
                      chs <- genNumsToTotal (n-ch)
                      return (ch:chs)

-- | A function that takes a generator for an item, and generates a list of those,
-- dividing up the size at random.  The list will be length log_2(N) on average, I think.
genList :: (Int -> GenL a) -> Int -> GenL [a]
genList _ 0 = return [([],[])]
genList f n = (lift $ genNumsToTotal n) >>= mapM f >>= foldList
  where
    foldList :: [[([Meta], a)]] -> StateT Id Gen [([Meta], [a])]
    foldList [g] = comb1 singleton (return g)
    foldList gs = return $ foldr foldX [] gs
    
    foldX :: [([Meta], a)] -> [([Meta], [a])] -> [([Meta], [a])]
    foldX xs [] = map (uncurry mix) (zip xs $ repeat ([],[]))
    foldX xs ys = map (uncurry mix) (product2 (xs,ys))
    
    mix :: ([Meta], a) -> ([Meta], [a]) -> ([Meta], [a])
    mix (ms0,x) (ms1,xs) = (ms0++ms1,x:xs)

-- Helper functions for subtraction.
sub1 :: Int -> Int
sub1 x = x-1

sub2 :: Int -> Int
sub2 x = x-2

sub3 :: Int -> Int
sub3 x = x-3

-- Be careful with the test generators; there should always be an option with value 1 (or 0)
-- in every list.  Recursion should always decrease the test size, and you
-- should take the recursion into account in the required size (generally, recursive
-- generators will have value 2 at least).  If you cannot have something of size 1 in the list,
-- (such as for A.Alternative) you need to take account of this in its parent items, and bump
-- up the required size for them accordingly.

-- | Generates a simple expression (A.True m).
genExpression :: GenL A.Expression
genExpression = nextIdT >>* makeMeta' >>= genElem1 A.True

-- | Generates a simple, empty, expression list.
genExpressionList :: GenL A.ExpressionList
genExpressionList = nextIdT >>* makeMeta' >>= (flip $ genElem2 A.ExpressionList) (comb0 [])

-- | Generates an A.Alternative.  Currently always A.AlternativeSkip.
genAlternative :: Int -> GenL A.Alternative
genAlternative n = nextIdT >>* makeMeta' >>= \m -> (flip oneofLS) n
  [
    (3, genElem3 A.AlternativeSkip m genExpression . genProcess . sub2)
  ]

genAlternative' :: (Int, Int -> GenL A.Alternative)
genAlternative' = (3, genAlternative)

-- | Generates a A.Specification.
genSpecification :: GenL A.Specification
genSpecification = nextIdT >>* makeMeta' >>= \m -> genElem3 A.Specification m (comb0 $ simpleName "x") genSpecType
  where
    genSpecType :: GenL A.SpecType
    genSpecType = nextIdT >>* makeMeta' >>= \m -> oneofL
      [
        genElem2 A.Declaration m (comb0 A.Int)
       ,genElem2 A.Declaration m (comb0 A.Int)
       ,genElem2 (\m e -> A.Is m A.ValAbbrev A.Int $ A.ActualExpression e) m genExpression
       --TODO proc and function declaration
      ]

genChoice :: Int -> GenL A.Choice
genChoice n = nextIdT >>* makeMeta' >>= \m -> (comb2 (\e p -> A.Choice emptyMeta e p) genExpression . genProcess . sub2) n

genChoice' :: (Int, Int -> GenL A.Choice)
genChoice' = (3, genChoice)

genOption :: Int -> GenL A.Option
genOption = comb1 (A.Else emptyMeta) . genProcess

genOption' :: (Int, Int -> GenL A.Option)
genOption' = (1, genOption)

genReplicator :: GenL A.Replicator
genReplicator = nextIdT >>* makeMeta' >>= \m -> genElem4 A.For m genExpression genExpression genExpression

class ReplicatorAnnotation a where
  replicatorItem :: (Int, Int -> GenL a) -> Maybe (Int, Int -> GenL (A.Structured a))

replicatorItem' :: (ReplicatorAnnotation a, Data a) => (Int, Int -> GenL a) -> (Int, Int -> GenL (A.Structured a))
replicatorItem' x = (4, comb2 (A.Spec emptyMeta . A.Specification emptyMeta
  (simpleName "i") . A.Rep emptyMeta) genReplicator . genStructured x . sub3)

   --Replicators are allowed in ALTs, IFs, SEQs and PARs:
instance ReplicatorAnnotation A.Process where replicatorItem = Just . replicatorItem'
instance ReplicatorAnnotation A.Alternative where replicatorItem = Just . replicatorItem'
instance ReplicatorAnnotation A.Choice where replicatorItem = Just . replicatorItem'

instance ReplicatorAnnotation A.Option where replicatorItem = const Nothing

-- | Generates a A.Structured, obeying the given OnlyAllowed structure.
genStructured :: (Data a, ReplicatorAnnotation a) => (Int, Int -> GenL a) -> Int -> GenL (A.Structured a)
genStructured (no,genOnly) n = nextIdT >>* makeMeta' >>= \m -> (flip oneofLS) n
 ([{-
    cond (onlyP allowed) (2,genElem2 A.Only m . genProcess . sub1 )
   ,cond (onlyO allowed) (2,comb1 (A.Only emptyMeta . A.Else emptyMeta) . genProcess . sub1 )
   ,cond (onlyC allowed) (3,comb2 (\e p -> A.Only emptyMeta $ A.Choice emptyMeta e p) genExpression . genProcess . sub2)
   ,cond (onlyA allowed) (4,genElem2 A.Only m . genAlternative . sub1 )
-}   
   -- As below, we subtract one to ensure termination
   (no + 1, comb1 (A.Only m) . genOnly . sub1)

   -- Specs currently don't work with Case statements TODO
   ,(3,genElem3 A.Spec m genSpecification . genStructured (no, genOnly) . sub2 )
   
   -- We don't have to subtract 1 here, but we do to ensure test termination
   -- Otherwise we could infinitely nest Seqs with Severals with Only Seqs with Severals...
   ,(1,comb1 (A.Several emptyMeta) . genList (genStructured (no, genOnly)) . sub1)
  ] ++ maybeToList (replicatorItem (no,genOnly)) )

-- | Generates a A.Process.
genProcess :: Int -> GenL A.Process
genProcess n = nextIdT >>* makeMeta' >>= \m -> (flip oneofLS) n
  [
    (1,const $ genElem1 A.Skip m)
   ,(1,const $ genElem1 A.Stop m)
   ,(1,comb1 (A.Seq emptyMeta) . genStructured genProcess')
   ,(1,comb1 (A.Par emptyMeta A.PlainPar) . genStructured genProcess')
   ,(1,comb1 (A.If emptyMeta) . genStructured genChoice')
   ,(2,comb2 (A.Case emptyMeta) genExpression . genStructured genOption' . sub1)
   ,(2,const $ genElem3 A.Assign m (comb0 [variable "x"]) genExpressionList)
   ,(2,comb1 (A.Alt emptyMeta True) . genStructured genAlternative' . sub1)
  ]

genProcess' :: (Int, Int -> GenL A.Process)
genProcess' = (1, genProcess)

-- | Generates a flow-graph from the given AST.
-- TODO put this in proper error monad
genGraph :: A.Structured A.Process -> FlowGraph' Identity () A.Process
genGraph s = either (\e -> error $ "QuickCheck graph did not build properly: " ++ e ++ ", from: " ++ pshow s)
  (\(x,_,_) -> x) $ runIdentity $ buildFlowGraphP funcs s
  where
    funcs :: GraphLabelFuncs Identity ()
    funcs = mkLabelFuncsConst (return ())

-- | Given a flow-graph, it returns a list of all the identity alteration functions,
-- for each node.  Applying any, many or all of these functions to the source AST
-- should leave it unchanged.
pickFuncId :: (Data a, Monad m) => FlowGraph' m () a -> [A.Structured a -> m (A.Structured a)]
pickFuncId g = map (applyFunc . getFunc) (labNodes g)
  where
    getFunc (_,n) = getNodeFunc n
    
    applyFunc (AlterAlternative f) = routeModify f return
    applyFunc (AlterProcess f) = routeModify f return
    applyFunc (AlterExpression f) = routeModify f return
    applyFunc (AlterExpressionList f) = routeModify f return
    applyFunc (AlterReplicator f) = routeModify f return
    applyFunc (AlterSpec f) = routeModify f return
    applyFunc (AlterNothing _) = return

-- | Given a flow-graph, it returns a list of the meta-tag replacement alteration functions,
-- for each meta-tag (i.e. each node).
pickFuncRep :: (Data a, Monad m) => FlowGraph' m () a -> Map.Map Meta (A.Structured a -> m (A.Structured a))
pickFuncRep gr = Map.fromList $ filter ((/= emptyMeta) . fst) $ map (helpApplyFunc . getMetaFunc) (labNodes gr)
  where
    getMetaFunc (_,n) = (getNodeMeta n,getNodeFunc n)
    
    helpApplyFunc (m,f) = (m, applyFunc (m,f))
    
    applyFunc (m,AlterAlternative f) = routeModify f (g m)
    applyFunc (m,AlterProcess f) = routeModify f (g m)
    applyFunc (m,AlterExpression f) = routeModify f (g m)
    applyFunc (m,AlterExpressionList f) = routeModify f (g m)
    applyFunc (m,AlterReplicator f) = routeModify f (g m)
    applyFunc (m,AlterSpec f) = routeModify f (g m)
    applyFunc (m,AlterNothing _) = return
    
    g m = applyBottomUpM $ replaceM m (replaceMeta m)


-- | It is important to have these functions in the right ratio.  The number of possible trees is
-- 2^N, where N is the test size.  Therefore I suggest keeping N <= 10 as a sensible limit.
-- Hence, if there are 1000 tests, we divide the test number by 100 to get the test size.
configForSize :: Int -> Config
configForSize n = defaultConfig { configMaxTest = n, configSize = \x -> x `div` scale }
  where
    scale = n `div` 10

deepCheck :: Testable a => a -> QuickCheckTest
deepCheck test level = (flip testCheck) test $ configForSize $
  case level of 
    QC_Low -> 100
    QC_Medium -> 1000
    QC_High -> 5000
    QC_Extensive -> 10000

testModify :: [LabelledQuickCheckTest]
testModify =
 [
   ("Control-Flow Graph Identity Transformations", deepCheck (runTest . prop_Id))
  ,("Control-Flow Graph Replacement Transformations", deepCheck (runTest . prop_Rep))
  ,("Random List Generation", deepCheck (runTest . prop_gennums))
 ]
  where
    -- | Checks that applying any set (from the powerset of identity functions) of identity functions
    -- does not change the AST.
    prop_Id :: QC (A.Process, Map.Map [Meta] A.Process) -> QCProp
    prop_Id (QC (g,_)) = sequence_ $ (flip map) (map (foldFuncsM) $ powerset $ pickFuncId $ genGraph g') $ \f -> runIdentity (f g') *==* g'
      where
        g' = A.Only emptyMeta g

    -- | Checks that applying any set (from the powerset of replacement functions) of replacement functions
    -- produces the expected result.
    prop_Rep :: QC (A.Process, Map.Map [Meta] A.Process) -> QCProp
    prop_Rep (QC (g,rest)) = sequence_ $ (flip map) (helper $ pickFuncRep $ genGraph g') $ 
        \(funcs,ms) -> testEqual (show ms)
          (Just (runIdentity (applyMetas ms funcs g'))) (Map.lookup ms rest >>* A.Only emptyMeta)
      where
        g' = A.Only emptyMeta g
  
    -- | This tests our genNumsToTotal function, which is itself a test generator; nasty!
    prop_gennums :: Int -> QCProp
    prop_gennums n = generate 0 (mkStdGen 0) (genNumsToTotal n >>* sum) *==* n

    -- | Repeatedly pairs the map with each element of the powerset of its keys
    helper :: Monad m => Map.Map Meta (A.Structured a -> m (A.Structured a)) -> [(Map.Map Meta (A.Structured a -> m (A.Structured a)), [Meta])]
    helper fs = zip (repeat fs) (powerset $ Map.keys fs)

    -- | Applies the functions associated with the given meta tags
    applyMetas :: Monad m => [Meta] -> Map.Map Meta (A.Structured a -> m (A.Structured a)) -> (A.Structured a -> m (A.Structured a))
    applyMetas ms funcs = foldFuncsM $ mapMaybe (\m -> Map.lookup m funcs) ms

-- | Returns the list of tests:
qcTests :: (Test, [LabelledQuickCheckTest])
qcTests = (TestLabel "FlowGraphTest" $ TestList
 [
   testAlt
  ,testCase
  ,testIf
  ,testPar
  ,testProcFuncSpec
  ,testSeq
  ,testWhile
 ]
 ,testModify)