{-# LANGUAGE RankNTypes, OverloadedStrings #-}
module WildBind.BindingSpec (main, spec) where

import Control.Applicative ((<$>), (<*>), pure)
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.Reader as Reader
import qualified Control.Monad.Trans.State as State
import Data.Maybe (isNothing, fromJust)
import Data.Monoid (mempty, (<>), mconcat)
import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef)
import qualified Lens.Micro as Lens
import Test.Hspec
import Test.QuickCheck (Gen, Arbitrary(arbitrary), property, listOf, sample')

import qualified WildBind.Binding as WB
import WildBind.ForTest
  ( SampleInput(..), SampleState(..), SampleBackState(..),
    inputAll, execAll, evalStateEmpty, boundDescs, boundDescs',
    checkBoundDescs,
    withRefChecker
  )

main :: IO ()
main = hspec spec

data BiggerSampleBackState = BSB { _lSB :: SampleBackState, _rSB :: SampleBackState }
                           deriving (Show, Eq, Ord)

lSB :: Lens.Lens' BiggerSampleBackState SampleBackState
lSB = Lens.lens _lSB (\bsb sb -> bsb { _lSB = sb })

rSB :: Lens.Lens' BiggerSampleBackState SampleBackState
rSB = Lens.lens _rSB (\bsb sb -> bsb { _rSB = sb })

-- 'view' is since microlens-0.3.5.0
view :: Lens.Lens' s a -> s -> a
view l s = s Lens.^. l

newStrRef :: MonadIO m => m (IORef String)
newStrRef = liftIO $ newIORef []

withStrRef :: MonadIO m => (IORef String -> (String -> m ()) -> m ()) -> m ()
withStrRef = withRefChecker []

outOn :: MonadIO m => IORef [a] -> i -> a -> (i, WB.Action m ())
outOn out_ref input out_elem = (input, WB.Action "" $ liftIO $ modifyIORef out_ref (++ [out_elem]))

outOnS :: MonadIO m => IORef [a] -> i -> a -> (s -> s) -> (i, WB.Action (State.StateT s m) ())
outOnS out_ref input out_elem modifier = (,) input $ WB.Action "" $ do
  State.modify modifier
  liftIO $ modifyIORef out_ref (++ [out_elem])

genStatelessBinding :: Arbitrary a => IORef [a] -> Gen (WB.Binding s SampleInput)
genStatelessBinding out_list =
  WB.binding <$> (listOf $ (,) <$> arbitrary <*> (WB.Action "" <$> outputRandomElem))
  where
    outputRandomElem = do
      out_elem <- arbitrary
      return $ modifyIORef out_list (out_elem :)
  
generate :: Gen a -> IO a
generate = fmap head . sample'

execAll' :: Ord i => [i] -> State.StateT (WB.Binding SampleState i) IO ()
execAll' = execAll (SS "")

mempty_stateless :: WB.Binding SampleState SampleInput
mempty_stateless = mempty

checkMappend :: (WB.Binding SampleState SampleInput -> WB.Binding SampleState SampleInput) -> IO ()
checkMappend append_op = do
  out_ref <- newStrRef
  rand_binding <- generate $ genStatelessBinding out_ref
  let execute b = void $ inputAll b (SS "") =<< generate (listOf arbitrary)
  execute rand_binding
  out_orig <- readIORef out_ref
  writeIORef out_ref []
  execute (append_op rand_binding)
  readIORef out_ref `shouldReturn` out_orig

actRun :: Maybe (WB.Action IO a) -> IO ()
actRun = void . WB.actDo . fromJust

checkInputsS :: (Show i, Eq i) => s -> [i] -> State.StateT (WB.Binding s i) IO ()
checkInputsS state exp_in = State.get >>= \b -> lift $ WB.boundInputs b state `shouldMatchList` exp_in

checkInputsS' :: (Show i, Eq i) => [i] -> State.StateT (WB.Binding SampleState i) IO ()
checkInputsS' = checkInputsS (SS "")

spec :: Spec
spec = do
  spec_stateless
  spec_conversions
  spec_convBack
  spec_stateful
  spec_extend
  spec_conditionBoth
  spec_monadic
  spec_reader
  spec_revise

spec_stateless :: Spec
spec_stateless = do
  describe "Binding (Monoid instances)" $ do
    it "mempty returns empty binding" $ property
      ( isNothing <$> (WB.boundAction mempty_stateless <$> arbitrary <*> arbitrary) )
    it "mempty `mappend` random == mempty" $ do
      checkMappend (mempty <>)
    it "random `mappend` mempty == mempty" $ do
      checkMappend (<> mempty)
  describe "binding" $ do
    it "returns a stateless Binding" $ withStrRef $ \out checkOut -> do
      let b = WB.binding [outOn out SIa 'A', outOn out SIb 'B']
      WB.boundInputs b (SS "") `shouldMatchList` [SIa, SIb]
      WB.boundAction b (SS "") SIc `shouldSatisfy` isNothing
      actRun $ WB.boundAction b (SS "") SIa
      checkOut "A"
      actRun $ WB.boundAction b (SS "") SIb
      checkOut "AB"
    it "prefers the latter action if multiple actions are bound to the same input" $ withStrRef $ \out checkOut -> do
      let b = WB.binding [ outOn out SIa '1',
                           outOn out SIa '2',
                           outOn out SIa '3'
                         ]
      actRun $ WB.boundAction b (SS "") SIa
      checkOut "3"
  describe "whenFront" $ do
    it "adds a condition on the front-end state" $ withStrRef $ \out checkOut -> do
      let b = WB.whenFront (\(SS s) -> s == "hoge") $ WB.binding [outOn out SIa 'A']
      WB.boundInputs b (SS "") `shouldMatchList` []
      WB.boundAction b (SS "") SIa `shouldSatisfy` isNothing
      WB.boundInputs b (SS "foobar") `shouldMatchList` []
      WB.boundAction b (SS "foobar") SIa `shouldSatisfy` isNothing
      WB.boundInputs b (SS "hoge") `shouldMatchList` [SIa]
      actRun $ WB.boundAction b (SS "hoge") SIa
      checkOut "A"
    it "is AND condition" $ withStrRef $ \out checkOut -> do
      let raw_b = WB.binding [outOn out SIa 'A']
          b = WB.whenFront ((<= 5) . length . unSS) $ WB.whenFront ((3 <=) . length . unSS) $ raw_b
      WB.boundInputs b (SS "ho") `shouldMatchList` []
      WB.boundAction b (SS "ho") SIa `shouldSatisfy` isNothing
      WB.boundInputs b (SS "hogehoge") `shouldMatchList` []
      WB.boundAction b (SS "hogehoge") SIa `shouldSatisfy` isNothing
      WB.boundInputs b (SS "hoge") `shouldMatchList` [SIa]
      actRun $ WB.boundAction b (SS "hoge") SIa
      checkOut "A"
    it "should be effective for derived Bindings" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      let raw_b = WB.binding [outOn out SIa 'A']
      State.put $ WB.whenFront (\(SS s) -> s == "foobar") $ raw_b
      checkInputsS (SS "hoge") []
      checkInputsS (SS "foobar") [SIa]
      execAll (SS "foobar") [SIa]
      checkOut "A"
      checkInputsS (SS "hoge") []
      checkInputsS (SS "foobar") [SIa]
  describe "ifFront" $ do
    it "chooses from independent Bindings" $ withStrRef $ \out checkOut -> do
      let b = WB.ifFront (\(SS s) -> length s <= 5)
              (WB.binding [outOn out SIa 'A']) (WB.binding [outOn out SIb 'B'])
      WB.boundInputs b (SS "hoge") `shouldMatchList` [SIa]
      WB.boundInputs b (SS "foobar") `shouldMatchList` [SIb]
      actRun $ WB.boundAction b (SS "foobar") SIb
      checkOut "B"
    it "adds AND conditions when nested" $ withStrRef $ \out checkOut -> do
      let b1 = WB.ifFront (\(SS s) -> length s <= 5)
               (WB.binding [outOn out SIa 'A']) (WB.binding [outOn out SIb 'B'])
          b = WB.ifFront (\(SS s) -> length s >= 3) b1 $ WB.binding [outOn out SIc 'C']
      WB.boundInputs b (SS "") `shouldMatchList` [SIc]
      WB.boundInputs b (SS "foo") `shouldMatchList` [SIa]
      WB.boundInputs b (SS "hoge") `shouldMatchList` [SIa]
      WB.boundInputs b (SS "foobar") `shouldMatchList` [SIb]
      actRun $ WB.boundAction b (SS "ho") SIc
      checkOut "C"
  describe "Binding (mappend)" $ do
    it "combines two stateless Bindings" $ withStrRef $ \out checkOut -> do
      let b1 = WB.binding [outOn out SIa 'A']
          b2 = WB.binding [outOn out SIb 'B']
          b = b1 <> b2
      WB.boundInputs b (SS "") `shouldMatchList` [SIa, SIb]
      void $ inputAll b (SS "") [SIa, SIb]
      checkOut "AB"
    it "front-end conditions are preserved" $ withStrRef $ \out _ -> do
      let b1 = WB.whenFront ((3 <=) . length . unSS) $ WB.binding [outOn out SIa 'A']
          b2 = WB.whenFront ((<= 5) . length . unSS) $ WB.binding [outOn out SIb 'B']
          b = b1 <> b2
      WB.boundInputs b (SS "aa") `shouldMatchList` [SIb]
      WB.boundInputs b (SS "aabb") `shouldMatchList` [SIa, SIb]
      WB.boundInputs b (SS "aabbcc") `shouldMatchList` [SIa]
    it "prefers the latter Binding" $ withStrRef $ \out checkOut -> do
      let b1 = WB.binding [outOn out SIa '1', outOn out SIb 'B']
          b2 = WB.binding [outOn out SIa '2']
          b = b1 <> b2
      WB.boundInputs b (SS "") `shouldMatchList` [SIa, SIb]
      actRun $ WB.boundAction b (SS "") SIa
      checkOut "2"
    it "preserves implicit back-end states" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      let b1 = WB.startFrom (SB 0)
               $ WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIa '0' (\_ -> SB 1)])
               $ WB.ifBack (== (SB 1)) (WB.binding' [outOnS out SIa '1' (\_ -> SB 0)])
               $ mempty
          b2 = WB.startFrom (SB 0)
               $ WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIb '2' (\_ -> SB 1)])
               $ WB.ifBack (== (SB 1)) (WB.binding' [outOnS out SIb '3' (\_ -> SB 0)])
               $ mempty
      State.put (b1 <> b2)
      checkInputsS (SS "") [SIa, SIb]
      execAll (SS "") [SIa]
      checkOut "0"
      checkInputsS (SS "") [SIa, SIb]
      execAll (SS "") [SIb]
      checkOut "02"
      checkInputsS (SS "") [SIa, SIb]
      execAll (SS "") [SIa]
      checkOut "021"
      checkInputsS (SS "") [SIa, SIb]
      execAll (SS "") [SIb]
      checkOut "0213"
      checkInputsS (SS "") [SIa, SIb]
      execAll (SS "") [SIa]
      checkOut "02130"

spec_conversions :: Spec
spec_conversions = do
  describe "convFront" $ do
    it "converts front-end state" $ withStrRef $ \out checkOut -> do
      let orig_b = WB.whenFront (("hoge" ==) . unSS) $ WB.binding [outOn out SIa 'A']
          b = WB.convFront SS orig_b
      WB.boundInputs b "" `shouldMatchList` []
      WB.boundInputs b "hoge" `shouldMatchList` [SIa]
      actRun $ WB.boundAction b "hoge" SIa
      checkOut "A"
  describe "convInput" $ do
    it "converts input symbols" $ withStrRef $ \out checkOut -> do
      let orig_b = WB.binding [outOn out SIa 'A']
          b = WB.convInput show orig_b
      WB.boundInputs b (SS "") `shouldMatchList` ["SIa"]
      actRun $ WB.boundAction b (SS "") "SIa"
      checkOut "A"
  describe "advice" $ do
    it "converts all actions in Binder" $ withStrRef $ \out checkOut -> do
      let convert_action a = a { WB.actDescription = WB.actDescription a <> "!!",
                                 WB.actDo = WB.actDo a >> (modifyIORef out (++ "!"))
                               }
          b = WB.binds $ WB.advice convert_action $ do
            WB.on SIa `WB.as` "action a" `WB.run` modifyIORef out (++ "A")
            WB.on SIb `WB.as` "action b" `WB.run` modifyIORef out (++ "B")
      (WB.actDescription <$> WB.boundAction b () SIa) `shouldBe` Just "action a!!"
      (WB.actDescription <$> WB.boundAction b () SIb) `shouldBe` Just "action b!!"
      void $ inputAll b () [SIa]
      checkOut "A!"
      void $ inputAll b () [SIb]
      checkOut "A!B!"
    it "preserves the order of binding." $ withStrRef $ \out checkOut -> do
      let b = WB.binds $ WB.advice (WB.before $ modifyIORef out (++ "A")) $ do
            WB.on SIa `WB.run` modifyIORef out (++ "1")
            WB.on SIa `WB.run` modifyIORef out (++ "2")
            WB.on SIa `WB.run` modifyIORef out (++ "3")
      void $ inputAll b () [SIa]
      checkOut "A3"
    it "can nest" $ withStrRef $ \out checkOut -> do
      let b = WB.binds $ do
            WB.on SIa `WB.run` modifyIORef out (++ "1")
            WB.advice (WB.before $ modifyIORef out (++ "*")) $ do
              WB.on SIb `WB.run` modifyIORef out (++ "3")
              WB.advice (WB.after $ modifyIORef out (++ "@")) $ do
                WB.on SIa `WB.run` modifyIORef out (++ "4")
                WB.on SIc `WB.run` modifyIORef out (++ "5")
              WB.advice (WB.after $ modifyIORef out (++ "#")) $ do
                WB.on SIb `WB.run` modifyIORef out (++ "6")
                WB.on SIc `WB.run` modifyIORef out (++ "7")
              WB.on SIa `WB.run` modifyIORef out (++ "8")
      void $ inputAll b () [SIa]
      checkOut "*8"
      void $ inputAll b () [SIb]
      checkOut "*8*6#"
      void $ inputAll b () [SIc]
      checkOut "*8*6#*7#"
  describe "before" $ do
    it "prepends a monadic action" $ withStrRef $ \out checkOut -> do
      let act = WB.Action { WB.actDescription = "desc",
                            WB.actDo = modifyIORef out (++ "ORIG")
                          }
          got = WB.before (modifyIORef out (++ "before")) act
      WB.actDescription got `shouldBe` "desc"
      WB.actDo got
      checkOut "beforeORIG"
  describe "after" $ do
    it "appends a monadic action" $ withStrRef $ \out checkOut -> do
      let act = WB.Action { WB.actDescription = "desc",
                            WB.actDo = modifyIORef out (++ "ORIG")
                          }
          got = WB.after (modifyIORef out (++ "after")) act
      WB.actDescription got `shouldBe` "desc"
      WB.actDo got
      checkOut "ORIGafter"

spec_convBack :: Spec
spec_convBack = do
  describe "convBack" $ do
    it "can convert the back-end state by isomorphism" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      let act = do
            out_elem <- head <$> show <$> unSB <$> State.get
            liftIO $ modifyIORef out (++ [out_elem])
            State.modify succ
          orig_b = WB.binding' [(SIa, WB.Action "" act)]
          b = WB.convBack (\s _-> unSB s) SB orig_b
      State.put $ WB.startFrom 0 b
      checkInputsS' [SIa]
      execAll' [SIa]
      checkOut "0"
      execAll' [SIa]
      checkOut "01"
      execAll' [SIa]
      checkOut "012"
    it "can convert the back-end state by a lens" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      let bl = WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIa '0' (\_ -> SB 1)])
               $ WB.whenBack (== (SB 1)) (WB.binding' [outOnS out SIa '1' (\_ -> SB 0)])
          br = WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIb '2' (\_ -> SB 1)])
               $ WB.whenBack(== (SB 1)) (WB.binding' [outOnS out SIb '3' (\_ -> SB 0)])
          bg = WB.whenBack (== (BSB (SB 0) (SB 0))) $ WB.binding' [outOnS out SIc '4' (\_ -> BSB (SB 1) (SB 1))]
          convBackByLens :: Lens.Lens' s a -> WB.Binding' a f i -> WB.Binding' s f i
          convBackByLens l = WB.convBack (Lens.set l) (view l)
          b = (convBackByLens lSB bl) <> (convBackByLens rSB br) <> bg
      State.put $ WB.startFrom (BSB (SB 0) (SB 0)) b
      checkInputsS' [SIa, SIb, SIc]
      execAll' [SIa]
      checkOut "0"
      checkInputsS' [SIa, SIb]
      execAll' [SIb]
      checkOut "02"
      checkInputsS' [SIa, SIb]
      execAll' [SIb]
      checkOut "023"
      checkInputsS' [SIa, SIb]
      execAll' [SIa]
      checkOut "0231"
      checkInputsS' [SIa, SIb, SIc]
      execAll' [SIc]
      checkOut "02314"
      checkInputsS' [SIa, SIb]
      execAll' [SIa, SIb]
      checkOut "0231413"
    

spec_stateful :: Spec
spec_stateful = do
  describe "binding'" $ do
    it "returns a stateful Binding" $ withStrRef $ \out checkOut -> do
      let act = do
            out_elem <- head <$> show <$> unSB <$> State.get
            liftIO $ modifyIORef out (++ [out_elem])
            State.modify succ
          b = WB.binding' [(SIa, WB.Action "" act)]
      WB.boundInputs' b (SB 0)  (SS "") `shouldBe` [SIa]
      WB.boundInputs' b (SB 10) (SS "hoge") `shouldBe` [SIa]
      void $ inputAll (WB.startFrom (SB 0) b) (SS "") $ replicate 12 SIa
      checkOut "012345678911"
    it "prefers the latter action if multiple actions are bound to the same input" $ withStrRef $ \out checkOut -> do
      let b = WB.startFrom (SB 0) $ WB.binding' [ outOn out SIa '1',
                                                  outOn out SIa '2',
                                                  outOn out SIa '3'
                                                ]
      actRun $ WB.boundAction b (SS "") SIa
      checkOut "3"
    it "can create a stateful Binding with different bound inputs for different back-end state" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      State.put $ WB.startFrom (SB 0)
        $ WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIa 'A' (\_ -> SB 1)])
        $ WB.ifBack (== (SB 1)) (WB.binding' [outOnS out SIb 'B' (\_ -> SB 2)])
        $ WB.ifBack (== (SB 2)) (WB.binding' [outOnS out SIc 'C' (\_ -> SB 0)])
        $ mempty
      checkOut ""
      checkInputsS (SS "") [SIa]
      execAll (SS "") [SIa]
      checkOut "A"
      checkInputsS (SS "") [SIb]
      execAll (SS "") [SIb]
      checkOut "AB"
      checkInputsS (SS "") [SIc]
      execAll (SS "") [SIc]
      checkOut "ABC"
      checkInputsS (SS "") [SIa]
  describe "Binding (mappend, stateful)" $ do
    it "shares the explicit back-end state" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      let b1 = WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIa 'A' (\_ -> SB 1)])
               $ WB.ifBack (== (SB 1)) ( WB.binding' [outOnS out SIb 'B' (\_ -> SB 2),
                                                    outOnS out SIc 'b' (\_ -> SB 2)]
                                       )
               $ WB.ifBack (== (SB 2)) (WB.binding' [outOnS out SIc 'C' (\_ -> SB 0)])
               $ mempty
          b2 = WB.whenBack (== (SB 1)) $ WB.binding' [outOnS out SIb 'D' (\_ -> SB 0)]
          b = b1 <> b2
      State.put $ WB.startFrom (SB 0) b
      checkInputsS (SS "") [SIa]
      execAll (SS "") [SIa]
      checkOut "A"
      checkInputsS (SS "") [SIb, SIc]
      execAll (SS "") [SIb]
      checkOut "AD"
      checkInputsS (SS "") [SIa]
      execAll (SS "") [SIa, SIc]
      checkOut "ADAb"
      checkInputsS (SS "") [SIc]
      execAll (SS "") [SIc]
      checkOut "ADAbC"
      checkInputsS (SS "") [SIa]
      
  describe "ifBack" $ do
    it "chooses from unconditional bindings" $ withStrRef $ \out checkOut -> do
      let b = WB.ifBack (\(SB sb) -> sb < 5)
              (WB.binding [outOn out SIa 'A']) (WB.binding [outOn out SIb 'B'])
          ba = WB.startFrom (SB 4) b
          bb = WB.startFrom (SB 5) b
      WB.boundInputs ba (SS "") `shouldMatchList` [SIa]
      actRun $ WB.boundAction ba (SS "") SIa
      checkOut "A"
      WB.boundInputs bb (SS "") `shouldMatchList` [SIb]
      actRun $ WB.boundAction bb (SS "") SIb
      checkOut "AB"
    it "combines an extended stateless binding with a stateful binding" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      let b_stateless = WB.binding [outOn out SIa 'A']
          b = WB.ifBack (\(SB sb) -> sb < 5)
              (b_stateless <> WB.binding' [outOnS out SIb 'B' $ const (SB 10)])
              $ WB.binding' [outOnS out SIc 'C' $ const (SB 3)]
      State.put $ WB.startFrom (SB 0) b
      checkInputsS' [SIa, SIb]
      execAll' [SIa]
      checkOut "A"
      checkInputsS' [SIa, SIb]
      execAll' [SIb]
      checkOut "AB"
      checkInputsS' [SIc]
      execAll' [SIc]
      checkOut "ABC"
      checkInputsS' [SIa, SIb]
    it "combines implicit stateful binding with a binding with newly introduced states" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      let b1 = WB.startFrom (SB 0)
               $ WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIa 'A' $ const (SB 1)])
               $ WB.binding' [outOnS out SIb 'B' $ const (SB 0)]
          b = WB.startFrom (SB 0)
              $ WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIa 'a' $ const (SB 1)])
              $ WB.extend b1 <> WB.binding' [outOnS out SIc 'c' $ const (SB 0)]
      State.put b
      checkInputsS' [SIa]
      execAll' [SIa]
      checkOut "a"
      checkInputsS' [SIa, SIc]
      execAll' [SIa]
      checkOut "aA"
      checkInputsS' [SIb, SIc]
      execAll' [SIb]
      checkOut "aAB"
      checkInputsS' [SIa, SIc]
      execAll' [SIc]
      checkOut "aABc"
      checkInputsS' [SIa]

  describe "whenBack" $ do
    it "adds a condition to the back-end state" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      let raw_b = WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIa '0' (\_ -> SB 1)])
                  $ WB.ifBack (== (SB 1)) (WB.binding' [outOnS out SIb '1' (\_ -> SB 0)])
                  $ mempty
          b = WB.whenBack (== SB 0) $ raw_b
      State.put $ WB.startFrom (SB 0) b
      checkInputsS' [SIa]
      execAll' [SIa]
      checkOut "0"
      checkInputsS' []

spec_extend :: Spec
spec_extend = do
  describe "extend" $ do
    it "extends a stateless Binding" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      let bl :: WB.Binding SampleState SampleInput
          bl = WB.binding [
            outOn out SIa 'a',
            outOn out SIb 'b',
            outOn out SIc 'c']
          bs = WB.ifBack (== (SB 0)) (WB.binding' [outOnS out SIa 'A' (\_ -> SB 1)])
               $ WB.ifBack (== (SB 1)) (WB.binding' [outOnS out SIb 'B' (\_ -> SB 2)])
               $ WB.ifBack (== (SB 2)) (WB.binding' [outOnS out SIc 'C' (\_ -> SB 0)])
               $ mempty
      State.put $ WB.startFrom (SB 0) $ (WB.extend bl <> bs)
      checkInputsS' [SIa, SIb, SIc]
      execAll' [SIb, SIc, SIa]
      checkOut "bcA"
      checkInputsS' [SIa, SIb, SIc]
      execAll' [SIa, SIc, SIb]
      checkOut "bcAacB"
      checkInputsS' [SIa, SIb, SIc]
      execAll' [SIa, SIb, SIc]
      checkOut "bcAacBabC"

spec_conditionBoth :: Spec
spec_conditionBoth = do
  describe "ifBoth" $ do
    it "chooses bindings according to front-end and back-end states" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      let b = WB.ifBoth (\ _ (SS fs) -> fs == "hoge") ( WB.binding' [ outOnS out SIa 'a' (SB . succ . unSB),
                                                                      outOnS out SIb 'b' (const $ SB 0)
                                                                    ]
                                                    )
              $ WB.ifBoth (\ (SB bs) (SS fs) -> length fs < bs)
                (WB.binding' [ outOnS out SIc 'c' (SB . pred . unSB) ])
                (WB.binding' [ outOnS out SIb 'B' (SB . succ . unSB) ])
      State.put $ WB.startFrom (SB 10) $ b
      checkInputsS (SS "hoge") [SIa, SIb]
      checkInputsS (SS "") [SIc]
      checkInputsS (SS "foooooobaaaaaa") [SIb]
      execAll (SS "hoge") [SIb]
      checkOut "b"
      checkInputsS (SS "") [SIb]
      execAll (SS "") [SIb]
      checkOut "bB"
      checkInputsS (SS "hoge") [SIa, SIb]
      checkInputsS (SS "") [SIc]
      checkInputsS (SS "a") [SIb]
      execAll (SS "") [SIc]
      checkOut "bBc"
      checkInputsS (SS "hoge") [SIa, SIb]
      checkInputsS (SS "") [SIb]
      checkInputsS (SS "a") [SIb]
      execAll (SS "hoge") $ replicate 5 SIa
      checkOut "bBcaaaaa"
      checkInputsS (SS "hoge") [SIa, SIb]
      checkInputsS (SS "fooo") [SIc]
      checkInputsS (SS "foooo") [SIb]
            
  describe "whenBoth" $ do
    let incr' out ret = outOnS out SIa ret (\(SB num) -> SB (num + 1))
        decr' out ret = outOnS out SIb ret (\(SB num) -> SB (num - 1))
    it "adds a condition to both front-end and back-end states" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      let incr = incr' out
          decr = decr' out
          raw_b = WB.ifBack (== (SB 0)) (WB.binding' [incr '+']) (WB.binding' [incr '+', decr '-'])
          b = WB.whenBoth (\(SB num) (SS str) -> length str == num) $ raw_b
      State.put $ WB.startFrom (SB 0) $ b
      checkInputsS (SS "hoge") []
      checkInputsS (SS "") [SIa]
      execAll (SS "") [SIa]
      checkOut "+"
      checkInputsS (SS "") []
      checkInputsS (SS "e") [SIa, SIb]
      execAll (SS "e") [SIa]
      checkOut "++"
      checkInputsS (SS "e") []
      checkInputsS (SS "eg") [SIa, SIb]
      execAll (SS "eg") [SIb]
      checkOut "++-"
      checkInputsS (SS "e") [SIa, SIb]
    it "creates independent conditions when combined with <>" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      let incr = incr' out
          decr = decr' out
          bn = WB.ifBack (== (SB 0)) (WB.binding' [incr '+']) (WB.binding' [incr '+', decr '-'])
          bn' = WB.whenBoth (\(SB num) (SS str) -> length str == num) bn
          ba = WB.ifBack (== (SB 0)) (WB.binding' [incr 'p']) (WB.binding' [incr 'p', decr 'm'])
          ba' = WB.whenBoth (\(SB num) (SS str) -> read str == num) ba
      State.put $ WB.startFrom (SB 1) (bn' <> ba')
      checkInputsS (SS "10") []
      checkInputsS (SS "4") [SIa, SIb]
      execAll (SS "4") [SIa]
      checkOut "+"
      checkInputsS (SS "2") [SIa, SIb]
      execAll (SS "2") [SIa]
      checkOut "+p"
      checkInputsS (SS "342") [SIa, SIb]
      execAll (SS "342") [SIb]
      checkOut "+p-"
      execAll (SS "2") [SIb]
      checkOut "+p-m"
      checkInputsS (SS "1") [SIa, SIb]
      execAll (SS "1") [SIb]
      checkOut "+p-mm"
      
spec_monadic :: Spec
spec_monadic = describe "Monadic construction of Binding" $ do
  describe "binds" $ do
    it "constructs stateless Binding" $ withStrRef $ \out checkOut -> do
      let putOut c = modifyIORef out (++ [c])
          b = WB.binds $ do
            WB.on SIa `WB.run` putOut 'a'
            WB.on SIb `WB.run` do
              putOut 'b'
              putOut 'B'
      actRun $ WB.boundAction b (SS "") SIa
      checkOut "a"
      actRun $ WB.boundAction b (SS "") SIb
      checkOut "abB"
    it "prefers the latter action if multiple actions are bound to the same input" $ withStrRef $ \out checkOut -> do
      let b = WB.binds $ do
            WB.on SIa `WB.run` modifyIORef out (++ "1")
            WB.on SIa `WB.run` modifyIORef out (++ "2")
            WB.on SIa `WB.run` modifyIORef out (++ "3")
      actRun $ WB.boundAction b (SS "") SIa
      checkOut "3"
  describe "Binder" $ do
    it "can bind actions with different result types" $ withStrRef $ \out checkOut -> do
      let ret_b :: String
          ret_b = "return by b"
          b = WB.binds $ do  -- it's ok if it compiles..
            WB.on SIa `WB.run` do
              modifyIORef out (++ "a")
              return ()
            WB.on SIb `WB.run` do
              modifyIORef out (++ "b")
              return ret_b
      actRun $ WB.boundAction b (SS "") SIb
      checkOut "b"
  describe "binds'" $ do
    it "constructs stateful Binding" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      State.put $ WB.startFrom (SB 0) $ WB.binds' $ do
        WB.on SIa `WB.run` (State.modify $ \(SB v) -> SB (v + 1))
        WB.on SIb `WB.run` (State.modify $ \(SB v) -> SB (v - 1))
        WB.on SIc `WB.run` do
          (SB cur) <- State.get
          liftIO $ modifyIORef out (++ show cur)
      execAll' [SIa, SIa, SIa]
      checkOut ""
      execAll' [SIc]
      checkOut "3"
      execAll' [SIb, SIb]
      checkOut "3"
      execAll' [SIc]
      checkOut "31"
    it "prefers the latter action if multiple actions are bound to the same input" $ withStrRef $ \out checkOut -> do
      let b = WB.startFrom (SB 0) $ WB.binds' $ do
            WB.on SIa `WB.run` (liftIO $ modifyIORef out (++ "1"))
            WB.on SIa `WB.run` (liftIO $ modifyIORef out (++ "2"))
            WB.on SIa `WB.run` (liftIO $ modifyIORef out (++ "3"))
      actRun $ WB.boundAction b (SS "") SIa
      checkOut "3"
  describe "as" $ do
    it "sets ActionDescription" $ do
      let b = WB.binds $ do
            WB.on SIa `WB.as` "action for a" `WB.run` return ()
            WB.on SIb `WB.as` "action for b" `WB.run` return ()
      (WB.actDescription <$> WB.boundAction b (SS "") SIa) `shouldBe` Just "action for a"
      (WB.actDescription <$> WB.boundAction b (SS "") SIb) `shouldBe` Just "action for b"
      (WB.actDescription <$> WB.boundAction b (SS "") SIc) `shouldBe` Nothing

spec_reader :: Spec
spec_reader = describe "binding with ReaderT action" $ do
  describe "bindsF" $ do
    it "allows actions to access front-end state" $ withStrRef $ \out checkOut -> do
      let b = WB.bindsF $ do
            WB.on SIa `WB.run` do
              fs <- Reader.ask
              liftIO $ modifyIORef out (++ unSS fs)
      actRun $ WB.boundAction b (SS "hoge") SIa
      checkOut "hoge"
      actRun $ WB.boundAction b (SS "_foobar") SIa
      checkOut "hoge_foobar"
  describe "bindsF'" $ do
    it "allows stateful actions to access front-end state" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      let ba = WB.bindsF' $ do
            WB.on SIa `WB.run` do
              (SB bs) <- State.get
              (SS fs) <- lift $ Reader.ask
              if bs >= 0
                then liftIO $ modifyIORef out (++ fs)
                else liftIO $ modifyIORef out (++ reverse fs)
          bb = WB.binds' $ do
            WB.on SIb `WB.run` State.modify (\(SB bs) -> SB (bs + 1))
          bc = WB.binds' $ do
            WB.on SIc `WB.run` State.modify (\(SB bs) -> SB (bs - 1))
          b = WB.startFrom (SB 0) (bb <> ba <> bc)
      State.put b
      execAll (SS "abc") [SIa, SIb, SIb]
      checkOut "abc"
      execAll (SS "123") [SIc, SIc, SIc, SIc, SIa]
      checkOut "abc321"
      execAll (SS "xyz") [SIa, SIb, SIb, SIa]
      checkOut "abc321zyxxyz"

spec_revise :: Spec
spec_revise = do
  describe "revise" $ do
    it "should allow unbinding" $ do
      let b = WB.binds $ do
            WB.on SIa `WB.as` "a" `WB.run` return ()
            WB.on SIb `WB.as` "b" `WB.run` return ()
          rev () _ i act = if i == SIa then Nothing else Just act
          got = WB.revise rev b
      boundDescs got (SS "")  `shouldMatchList` [(SIb, "b")]
    it "should allow revising description" $ do
      let b = WB.binds $ do
            WB.on SIa `WB.as` "a" `WB.run` return ()
            WB.on SIb `WB.as` "b" `WB.run` return ()
          rev () _ _ act = Just $ act { WB.actDescription = mconcat $ replicate 3 $ WB.actDescription act }
          got = WB.revise rev b
      boundDescs got (SS "") `shouldMatchList` [(SIa, "aaa"), (SIb, "bbb")]
    it "should revise conditionally on front-end state" $ do
      let b = WB.binds $ do
            WB.on SIa `WB.as` "a" `WB.run` return ()
            WB.on SIb `WB.as` "b" `WB.run` return ()
          rev () (SS fs) i act = if i == SIa && length fs >= 3
                                 then Nothing else Just act
          got = WB.revise rev b
      boundDescs got (SS "")  `shouldMatchList` [(SIa, "a"), (SIb, "b")]
      boundDescs got (SS "xx") `shouldMatchList` [(SIa, "a"), (SIb, "b")]
      boundDescs got (SS "xxx") `shouldMatchList` [(SIb, "b")]
      boundDescs got (SS "xxxx") `shouldMatchList` [(SIb, "b")]
    it "should revise conditionally on back-end state" $ do
      let b = WB.binds $ do
            WB.on SIa `WB.as` "a" `WB.run` return ()
            WB.on SIb `WB.as` "b" `WB.run` return ()
          rev (SB bs) _ i act = if bs >= 5 && i == SIb
                                then Nothing
                                else Just act
          got = WB.revise rev $ WB.extend b
      boundDescs' got (SB 3) (SS "") `shouldMatchList` [(SIa, "a"), (SIb, "b")]
      boundDescs' got (SB 5) (SS "") `shouldMatchList` [(SIa, "a")]
      boundDescs' got (SB 7) (SS "") `shouldMatchList` [(SIa, "a")]
    it "should allow modifying the action" $ withStrRef $ \out checkOut -> do
      let b = WB.binds' $ do
            WB.on SIa `WB.as` "a" `WB.run` do
              (SB bs) <- State.get
              liftIO $ modifyIORef out (++ show bs)
          rev (SB bs) (SS fs) _ = WB.justBefore bf . WB.after af
            where
              bf = modifyIORef out (++ replicate bs 'X')
              af = modifyIORef out (++ fs)
          got = WB.revise rev b
      actRun $ WB.boundAction' got (SB 4) (SS "FF") SIa
      checkOut "XXXX4FF"
    it "should be effective after change of back-end state" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      let b = WB.startFrom (SB 0) $ WB.binds' $ do
            WB.on SIa `WB.run` do
              (SB bs) <- State.get
              liftIO $ modifyIORef out (++ show bs)
              State.put (SB $ bs + 1)
          rev _ _ _ = WB.justAfter $ modifyIORef out (++ "X")
          got = WB.revise rev b
      State.put got
      execAll (SS "") [SIa]
      checkOut "0X"
      execAll (SS "") [SIa]
      checkOut "0X1X"
      execAll (SS "") [SIa]
      checkOut "0X1X2X"
  describe "revise'" $ do
    it "should allow modifying the back-end state" $ evalStateEmpty $ withStrRef $ \out checkOut -> do
      let b = WB.binds' $ do
            WB.on SIa `WB.as` "a" `WB.run` do
              (SB bs) <- State.get
              liftIO $ modifyIORef out (++ show bs)
          rev _ (SS fs) _ = WB.justAfter af . WB.before bf
            where
              bf = State.modify (\(SB s) -> SB (s + 1))
              af = State.put $ SB $ length fs
          got = WB.startFrom (SB 0) $ WB.revise' rev b
      State.put got
      execAll (SS "abc") [SIa]
      checkOut "1"
      execAll (SS "a") [SIa]
      checkOut "14"
      execAll (SS "") [SIa]
      checkOut "142"
    it "should allow unbind conditionally" $ evalStateEmpty $ do
      let b = WB.binds' $ do
            WB.on SIa `WB.as` "a" `WB.run` State.modify (\(SB bs) -> SB $ bs + 1)
            WB.on SIb `WB.as` "b" `WB.run` return ()
          rev (SB bs) (SS fs) i orig = if i == SIb && bs >= 3 && bs <= 6 && fs /= "XXX"
                                       then Nothing
                                       else Just orig
          got = WB.startFrom (SB 0) $ WB.revise' rev b
      State.put got
      checkBoundDescs (SS "") [(SIa, "a"), (SIb, "b")]
      execAll (SS "") [SIa, SIa]
      checkBoundDescs (SS "") [(SIa, "a"), (SIb, "b")]
      execAll (SS "") [SIa]
      checkBoundDescs (SS "") [(SIa, "a")]
      checkBoundDescs (SS "XXX") [(SIa, "a"), (SIb, "b")]
      execAll (SS "") [SIa, SIa, SIa]
      checkBoundDescs (SS "") [(SIa, "a")]
      execAll (SS "") [SIa]
      checkBoundDescs (SS "") [(SIa, "a"), (SIb, "b")]