{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}
module Web.Stripe.Test.Prelude
       ( ($)
       , (-&-)
       , Char
       , Functor
       , IO
       , String
       , error
       , module GHC.Num
       , id
       , (.)
       , length
       , undefined
       , return
       , (>>=)
       , (>>)
       , fail
       , void
       , liftIO
       , fromString
       , stripeLift
       , module Test.Hspec
       , Eq(..)
       , Bool(..)
       , Maybe(..)
       , Stripe
       , StripeRequestF(..)
       , StripeSpec
       ) where

import           Data.Aeson      (Value, Result(..), FromJSON, fromJSON)
import           Data.Either     (Either)
import           Data.String     (fromString)
import           Data.Maybe      (Maybe(..))
import           GHC.Num         (fromInteger)
import           Prelude         (Bool(..), Eq(..), Functor(..), ($), IO, Char, String, error, undefined, (.), id, length)
import           Test.Hspec
import           Test.Hspec.Core.Spec (SpecM)
import qualified Control.Monad       as M
import qualified Control.Monad.Trans as M
import           Control.Monad.Trans.Free (FreeT(..), liftF)
import           Web.Stripe.Client

------------------------------------------------------------------------------
-- Stripe free monad

data StripeRequestF ret = forall req. StripeRequestF
    { getStripeRequest :: StripeRequest req
    , decode           :: Value -> Result ret
    }

instance Functor StripeRequestF where
  fmap f (StripeRequestF req d) = StripeRequestF req (fmap f . d)

toStripeRequestF
    :: (FromJSON ret, StripeReturn req ~ ret)
    => StripeRequest req
    -> StripeRequestF ret
toStripeRequestF (StripeRequest m e q) =
  StripeRequestF (StripeRequest m e q) fromJSON

type Stripe = FreeT StripeRequestF IO
type StripeSpec = (forall a. Stripe a -> IO (Either StripeError a)) -> Spec

------------------------------------------------------------------------------
-- A class which lifts 'StripeRequest a' to the 'Stripe' monad and
-- leaves everything else alone.
--
class StripeLift a where
  type LiftedType a
  stripeLift :: a -> (LiftedType a)

instance (FromJSON (StripeReturn req)) => StripeLift (StripeRequest req) where
    type LiftedType (StripeRequest req) = Stripe (StripeReturn req)
    stripeLift req = liftF $ toStripeRequestF req

instance StripeLift (Stripe a) where
  type LiftedType (Stripe a) = Stripe a
  stripeLift = id

instance StripeLift (IO a) where
  type LiftedType (IO a) = IO a
  stripeLift = id

instance StripeLift (SpecM a r) where
  type LiftedType (SpecM a r) = SpecM a r
  stripeLift = id

------------------------------------------------------------------------------
-- hack the do-syntax and related functions to automatically turn
-- StripeReq values into monadic functions.
--
-- This is useful in the test suite where we a running a bunch of
-- back-to-back stripe transactions with little business logic in
-- between.

(>>=) :: (StripeLift t, M.Monad m, LiftedType t ~ m a) =>
         t -> (a -> m b) -> m b
m >>= f = (stripeLift m) M.>>= f

(>>) :: (StripeLift t, M.Monad m, LiftedType t ~ m a) => t -> m b -> m b
(>>) m n = m >>= \_ -> n

void :: (FromJSON (StripeReturn a)) => StripeRequest a -> Stripe ()
void req = M.void (stripeLift req)

fail :: (M.Monad m) => String -> m a
fail = M.fail

return :: (M.Monad m) => a -> m a
return = M.return

liftIO :: IO a -> Stripe a
liftIO io = M.liftIO io