{-# LANGUAGE TemplateHaskell #-}

-- | This file should not be imported directly. Import "Test.OITestGenerator"
--   instead.
module Test.OITestGenerator.Op (
    Arg(), Op(),
    op, arg,
    but, only, withGens, withConstraint,
    op_name, op_args, op_gens, op_has_constraint, op_constraint, op_maybe_constraint
) where

import Control.Monad
import Data.Label
import Data.List
import Data.Maybe
import Language.Haskell.TH
import Prelude
import Test.OITestGenerator.GenHelper
import Test.OITestGenerator.HasGens

-- | An operation. Contains information about the operation's name, which
-- arguments may be tested (all by default), which generators should be used for
-- each argument ('arbitrary' by default) and possibly a constraint function.
data Op = Op {
    _name :: Name,
    _argis :: Q [Int],
    _gens :: Q [Name],
    _constraint :: Maybe Name
}

mkLabel ''Op

type Arg = Int

-- | 'Arg' constructor. Only for readability.
arg :: Int -> Arg
arg = id

-- | 'Op' constructor.
op :: Name -> Op
op name' = Op {
    _name = name',
    _argis = liftM (enumFromTo 1) $ num_args_name name',
    _gens = return [],
    _constraint = Nothing
}

-- | @but o i@ excludes the @i@-th argument from @o@ when generating tests.
--
-- Example:
--
-- > op 'dequeue `but` arg 1
but :: Op -> Arg -> Op
but op' excl = modify argis (liftM $ delete excl) op'

-- | @only o i@ excludes all but the @i@-th argument from @o@ when generating tests.
--
-- Example:
--
-- > op 'dequeue `only` arg 1
only :: Op -> Arg -> Op
only op' argi = modify argis (>>= \args ->
        if argi `elem` args
        then return [argi]
        else fail $ "Argument #" ++ show argi ++ " is not in " ++ show args
    ) op'

instance HasGens Op where
    op' `withGens` gens' = flip (set gens) op' $
                            let qargn = num_args_name nm
                                nm = get name op'
                            in qargn >>= \argn ->
                               if argn == length gens'
                               then return gens'
                               else fail $ "Operator " ++ show nm ++ " has "
                                   ++ show argn ++ " arguments, but "
                                   ++ show (length gens') ++ " Gens are given"

-- | @op `withConstraint` f@ adds a constraint function @f@ to @op@. @f@ must
-- take arguments of the same type as @op@ and return a 'Bool'. 
withConstraint :: Op -> Name -> Op
op' `withConstraint` constraint' = set constraint (Just constraint') op'

op_name :: Op -> Name
op_name = get name

op_args :: Op -> Q [Int]
op_args = get argis

op_gens :: Op -> Q [Name]
op_gens = get gens

op_has_constraint :: Op -> Bool
op_has_constraint = isJust . get constraint

op_constraint :: Op -> Name
op_constraint = fromJust . get constraint

op_maybe_constraint :: Op -> Maybe Name
op_maybe_constraint = get constraint