-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}

{- |

Module    :  Test.BDD.Language
Copyright :  (c) Paolo Veronelli, Pavlo Kerestey 2017
License   :  BSD3
Maintainer:  paolo.veronelli@gmail.com
Stability :  experimental
Portability: non-portable


The constrained language to define behaviors in BDD terminology

@
exampleL :: TestTree
exampleL = testBehavior "Test sequence"
    $ Given (print "Some effect")
    $ Given (print "Another effect")
    $ GivenAndAfter (print "Aquiring resource" >> return "Resource 1")
                   (print . ("Release "++))
    $ GivenAndAfter (print "Aquiring resource" >> return "Resource 2")
                   (print . ("Release "++))
    $ When (print "Action returning" >> return ([1..10]++[100..106]) :: IO [Int])
    $ Then (@?= ([1..10]++[700..706]))
    $ End
@
-}
module Test.BDD.Language
    ( Language (..)
    , BDDPreparing
    , BDDTesting
    , BDDTest (..)
    , TestContext (..)
    , context
    , whenAction
    , tests
    , interpret
    , Phase (..)
    )
where

import Lens.Micro

-- | Separating the 2 phases by type
data Phase = Preparing | Testing

-- | Recording given actions and type related teardowns
data TestContext m = forall r. TestContext (m r) (r -> m ())

-- | Bare hoare language
data Language m t q a where
    -- | action to prepare the test
    Given
        :: m ()
        -> Language m t q 'Preparing
        -> Language m t q 'Preparing
    -- | action to prepare the test, and related teardown action
    GivenAndAfter
        :: m r
        -> (r -> m ())
        -> Language m t q 'Preparing
        -> Language m t q 'Preparing
    -- | core logic of the test (last preparing action)
    When
        :: m t
        -> Language m t q 'Testing
        -> Language m t q 'Preparing
    -- | action producing a test
    Then
        :: (t -> m q)
        -> Language m t q 'Testing
        -> Language m t q 'Testing
    -- | final placeholder
    End :: Language m t q 'Testing

-- | Result of this module interpreter
data BDDTest m t q = BDDTest
    { forall (m :: * -> *) t q. BDDTest m t q -> [t -> m q]
_tests :: [t -> m q]
    -- ^ tests from @t@
    , forall (m :: * -> *) t q. BDDTest m t q -> [TestContext m]
_context :: [TestContext m]
    -- ^ test context
    , forall (m :: * -> *) t q. BDDTest m t q -> m t
_when :: m t
    -- ^ when action to compute @t@
    }

-- | Lens for the ordered preparation actions and their teardowns.
context
    :: (Functor f)
    => ([TestContext m] -> f [TestContext m])
    -> BDDTest m t q
    -> f (BDDTest m t q)
context :: forall (f :: * -> *) (m :: * -> *) t q.
Functor f =>
([TestContext m] -> f [TestContext m])
-> BDDTest m t q -> f (BDDTest m t q)
context [TestContext m] -> f [TestContext m]
f (BDDTest [t -> m q]
ts [TestContext m]
c m t
w) = (\[TestContext m]
c' -> [t -> m q] -> [TestContext m] -> m t -> BDDTest m t q
forall (m :: * -> *) t q.
[t -> m q] -> [TestContext m] -> m t -> BDDTest m t q
BDDTest [t -> m q]
ts [TestContext m]
c' m t
w) ([TestContext m] -> BDDTest m t q)
-> f [TestContext m] -> f (BDDTest m t q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TestContext m] -> f [TestContext m]
f [TestContext m]
c

-- | Lens for the assertions, allowing their result type to change.
tests
    :: (Functor f)
    => ([t -> m q1] -> f [t -> m q2])
    -> BDDTest m t q1
    -> f (BDDTest m t q2)
tests :: forall (f :: * -> *) t (m :: * -> *) q1 q2.
Functor f =>
([t -> m q1] -> f [t -> m q2])
-> BDDTest m t q1 -> f (BDDTest m t q2)
tests [t -> m q1] -> f [t -> m q2]
f (BDDTest [t -> m q1]
ts [TestContext m]
c m t
w) = (\[t -> m q2]
ts' -> [t -> m q2] -> [TestContext m] -> m t -> BDDTest m t q2
forall (m :: * -> *) t q.
[t -> m q] -> [TestContext m] -> m t -> BDDTest m t q
BDDTest [t -> m q2]
ts' [TestContext m]
c m t
w) ([t -> m q2] -> BDDTest m t q2)
-> f [t -> m q2] -> f (BDDTest m t q2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t -> m q1] -> f [t -> m q2]
f [t -> m q1]
ts

{- | Lens for the action whose result is supplied to the assertions.

Named @whenAction@ so that it can be imported unqualified next to
@Control.Monad.when@.
-}
whenAction
    :: (Functor f)
    => (m t -> f (m t))
    -> BDDTest m t q
    -> f (BDDTest m t q)
whenAction :: forall (f :: * -> *) (m :: * -> *) t q.
Functor f =>
(m t -> f (m t)) -> BDDTest m t q -> f (BDDTest m t q)
whenAction m t -> f (m t)
f (BDDTest [t -> m q]
ts [TestContext m]
c m t
w) = [t -> m q] -> [TestContext m] -> m t -> BDDTest m t q
forall (m :: * -> *) t q.
[t -> m q] -> [TestContext m] -> m t -> BDDTest m t q
BDDTest [t -> m q]
ts [TestContext m]
c (m t -> BDDTest m t q) -> f (m t) -> f (BDDTest m t q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m t -> f (m t)
f m t
w

-- | Preparing language types
type BDDPreparing m t q = Language m t q 'Preparing

-- | Testing language types
type BDDTesting m t q = Language m t q 'Testing

-- | An interpreter collecting the actions
interpret :: (Monad m) => Language m t q a -> BDDTest m t q
interpret :: forall (m :: * -> *) t q (a :: Phase).
Monad m =>
Language m t q a -> BDDTest m t q
interpret (Given m ()
given Language m t q 'Preparing
p) =
    Language m t q 'Preparing -> BDDTest m t q
forall (m :: * -> *) t q (a :: Phase).
Monad m =>
Language m t q a -> BDDTest m t q
interpret (Language m t q 'Preparing -> BDDTest m t q)
-> Language m t q 'Preparing -> BDDTest m t q
forall a b. (a -> b) -> a -> b
$ m ()
-> (() -> m ())
-> Language m t q 'Preparing
-> Language m t q 'Preparing
forall (m :: * -> *) r t q.
m r
-> (r -> m ())
-> Language m t q 'Preparing
-> Language m t q 'Preparing
GivenAndAfter m ()
given (m () -> () -> m ()
forall a b. a -> b -> a
const (m () -> () -> m ()) -> m () -> () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Language m t q 'Preparing
p
interpret (GivenAndAfter m r
given r -> m ()
after Language m t q 'Preparing
p) =
    ASetter
  (BDDTest m t q) (BDDTest m t q) [TestContext m] [TestContext m]
-> ([TestContext m] -> [TestContext m])
-> BDDTest m t q
-> BDDTest m t q
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (BDDTest m t q) (BDDTest m t q) [TestContext m] [TestContext m]
forall (f :: * -> *) (m :: * -> *) t q.
Functor f =>
([TestContext m] -> f [TestContext m])
-> BDDTest m t q -> f (BDDTest m t q)
context ((:) (TestContext m -> [TestContext m] -> [TestContext m])
-> TestContext m -> [TestContext m] -> [TestContext m]
forall a b. (a -> b) -> a -> b
$ m r -> (r -> m ()) -> TestContext m
forall (m :: * -> *) r. m r -> (r -> m ()) -> TestContext m
TestContext m r
given r -> m ()
after) (BDDTest m t q -> BDDTest m t q) -> BDDTest m t q -> BDDTest m t q
forall a b. (a -> b) -> a -> b
$
        Language m t q 'Preparing -> BDDTest m t q
forall (m :: * -> *) t q (a :: Phase).
Monad m =>
Language m t q a -> BDDTest m t q
interpret Language m t q 'Preparing
p
interpret (When m t
fa Language m t q 'Testing
p) =
    ASetter (BDDTest m t q) (BDDTest m t q) (m t) (m t)
-> m t -> BDDTest m t q -> BDDTest m t q
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (BDDTest m t q) (BDDTest m t q) (m t) (m t)
forall (f :: * -> *) (m :: * -> *) t q.
Functor f =>
(m t -> f (m t)) -> BDDTest m t q -> f (BDDTest m t q)
whenAction m t
fa (BDDTest m t q -> BDDTest m t q) -> BDDTest m t q -> BDDTest m t q
forall a b. (a -> b) -> a -> b
$ Language m t q 'Testing -> BDDTest m t q
forall (m :: * -> *) t q (a :: Phase).
Monad m =>
Language m t q a -> BDDTest m t q
interpret Language m t q 'Testing
p
interpret (Then t -> m q
ca Language m t q 'Testing
p) = ASetter (BDDTest m t q) (BDDTest m t q) [t -> m q] [t -> m q]
-> ([t -> m q] -> [t -> m q]) -> BDDTest m t q -> BDDTest m t q
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (BDDTest m t q) (BDDTest m t q) [t -> m q] [t -> m q]
forall (f :: * -> *) t (m :: * -> *) q1 q2.
Functor f =>
([t -> m q1] -> f [t -> m q2])
-> BDDTest m t q1 -> f (BDDTest m t q2)
tests (t -> m q
ca (t -> m q) -> [t -> m q] -> [t -> m q]
forall a. a -> [a] -> [a]
:) (BDDTest m t q -> BDDTest m t q) -> BDDTest m t q -> BDDTest m t q
forall a b. (a -> b) -> a -> b
$ Language m t q 'Testing -> BDDTest m t q
forall (m :: * -> *) t q (a :: Phase).
Monad m =>
Language m t q a -> BDDTest m t q
interpret Language m t q 'Testing
p
interpret Language m t q a
End =
    [t -> m q] -> [TestContext m] -> m t -> BDDTest m t q
forall (m :: * -> *) t q.
[t -> m q] -> [TestContext m] -> m t -> BDDTest m t q
BDDTest [] [] (m t -> BDDTest m t q) -> m t -> BDDTest m t q
forall a b. (a -> b) -> a -> b
$
        [Char] -> m t
forall a. HasCallStack => [Char] -> a
error [Char]
"End on its own does not make sense as a test"