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

import Control.Applicative ((<$>), (<*>), pure)
import Control.Monad (void, join)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.State as State
import Data.Maybe (isNothing, fromJust)
import Data.Monoid (mempty, (<>))
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(..))

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 action = do
  out <- newStrRef
  let checkOut exp_str = liftIO $ readIORef out `shouldReturn` exp_str
  action out checkOut

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'

inputAll :: Ord i => WB.Binding s i -> s -> [i] -> IO (WB.Binding s i)
inputAll b _ [] = return b
inputAll binding state (i:rest) = case WB.boundAction binding state i of
  Nothing -> inputAll binding state rest
  Just act -> join $ inputAll <$> WB.actDo act <*> return state <*> return rest

execAll :: Ord i => s -> [i] -> State.StateT (WB.Binding s i) IO ()
execAll state inputs = do
  b <- State.get
  next_b <- liftIO $ inputAll b state inputs
  State.put next_b

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 "")

evalStateEmpty :: State.StateT (WB.Binding SampleState SampleInput) IO () -> IO ()
evalStateEmpty s = State.evalStateT s mempty_stateless

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

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