high-dsl.purs

module Main where

import Prelude

import Control.Monad.Aff (launchAff, delay, forkAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (REF, newRef, writeRef, readRef)
import Control.Monad.Eff.Console (CONSOLE, log)
import CSS (fromString)
import Data.Array as A
import Data.Argonaut as J
import Data.Either (Either(..))
import Data.Newtype (un)
import Data.Symbol (SProxy(..))
import Data.Time.Duration (Milliseconds)
import Data.Traversable as T
import Data.Exists (mkExists, runExists, Exists)
import Data.String as Str
import Text.Chalky as TC
import Run as R
import Run.Except as RE
import Lunapark.Utils (catch, throwLeft)
import Lunapark.Types as LT
import Lunapark as LP
--import Unsafe.Coerce (unsafeCoerce)

--import Debug.Trace as DT

data LogF r a
  = Section String (R.Run r a)

derive instance functorLogF ∷ Functor (LogF r)

_log = SProxy ∷ SProxy "log"
type LOG r = R.FProxy (LogF r)
type WithLog r a = R.Run (log ∷ LOG r|r) a

liftLog ∷ ∀ r. LogF r ~> WithLog r
liftLog = R.lift _log

section ∷ ∀ r. String → R.Run r ~> WithLog r
section str action = liftLog $ Section str action

interpret
  ∷ ∀ e r
  . WithLog (eff ∷ R.EFF (console ∷ CONSOLE|e)|r)
  ~> R.Run (eff ∷ R.EFF (console ∷ CONSOLE|e)|r)
interpret = loop
  where
  handle = R.on _log Left Right
  bar = "========================================"
  loop r = case R.peel r of
    Left a → case handle a of
      Left logF → case logF of
        Section ann others → do
          R.liftEff do
            log ""
            log $ TC.magenta bar
            log $ TC.magenta ann
            log $ TC.magenta bar
            log ""
          result ← loop =<< others
          R.liftEff do
            log ""
            log $ TC.magenta bar
            log $ TC.green $ "OK: " <> ann <> " passed"
            log $ TC.magenta bar
            log ""
          pure result
      Right others → loop =<< R.send others
    Right a → pure a


data BindE m a b = BindE (m b) (b → m a)
newtype BindF m a = BindF (Exists (BindE m a))

mkBindF ∷ ∀ m a b. m b → (b → m a) → BindF m a
mkBindF mb bma = BindF $ mkExists (BindE mb bma)

runBindF ∷ ∀ a m. Monad m ⇒ BindF m a → m a
runBindF (BindF st) = runExists (\(BindE mb bma) → bma =<< mb) st

instance functorBindF ∷ Functor m ⇒ Functor (BindF m) where
  map f (BindF st) = runExists (\(BindE mb bma) → mkBindF mb $ map f <<< bma) st

data FlowF m a
  = Await (BindF m a)
  | AwaitNot (BindF m a) a
  | Expect (BindF m a)

derive instance functorFlowF ∷ Functor m ⇒ Functor (FlowF m)

_flow = SProxy ∷ SProxy "flow"
type FLOW m = R.FProxy (FlowF m)
type WithFlow r a = R.Run (flow ∷ FLOW (R.Run r)|r) a

liftFlow ∷ ∀ r. FlowF (R.Run r) ~> WithFlow r
liftFlow = R.lift _flow

await ∷ ∀ r a b. R.Run r a → (a → R.Run r b) → WithFlow r b
await ra arb = liftFlow $ Await $ mkBindF ra arb

awaitNot ∷ ∀ r a b. R.Run r a → (a → R.Run r b) → WithFlow r Unit
awaitNot ra arb = liftFlow $ AwaitNot (mkBindF ra (arb >>> void)) unit

expect ∷ ∀ r a b. R.Run r a → (a → R.Run r b) → WithFlow r b
expect ra arb = liftFlow $ Expect $ mkBindF ra arb

runFlow
  ∷ ∀ r eff lval
  . RetryInput
  → lval
  → WithFlow (eff ∷ R.EFF (ref ∷ REF|eff), aff ∷ R.AFF (ref ∷ REF|eff), except ∷ RE.EXCEPT lval|r)
  ~> R.Run (eff ∷ R.EFF (ref ∷ REF|eff), aff ∷ R.AFF (ref ∷ REF|eff), except ∷ RE.EXCEPT lval|r)
runFlow rt awaitNotError = loop
  where
  lrRun = R.on _flow Left Right
  loop r = case R.peel r of
    Right a → pure a
    Left cont → runFlow rt awaitNotError =<< case lrRun cont of
      Right others → R.send others
      Left f → case f of
        Await bind → retry rt (runBindF bind)
        AwaitNot (BindF bind) next →
          runExists (\(BindE ma amb) → catch ((ma >>= amb) *> RE.throw awaitNotError) (\_ → pure next)) bind
        Expect (BindF bind) →
          runExists (\(BindE ma amb) → retry rt ma >>= amb) bind


type RetryInput =
  { step ∷ Milliseconds
  , total ∷ Milliseconds
  }

data MoonshineF el r a
  = WithLabel String (el → a)
  | WithTitle String (el → a)
  | WithText String (el → a)
  | Before el (WithMoonshine el r a)
  | After el (WithMoonshine el r a)

derive instance functorMoonshineF ∷ Functor (MoonshineF el r)

_moonshine = SProxy ∷ SProxy "moonshine"
type MOONSHINE el r = R.FProxy (MoonshineF el r)
type WithMoonshine el r a = R.Run (moonshine ∷ MOONSHINE el r|r) a
liftMoonshine ∷ ∀ el r. MoonshineF el r ~> WithMoonshine el r
liftMoonshine = R.lift _moonshine

withLabel ∷ ∀ el r. String → WithMoonshine el r el
withLabel txt = liftMoonshine $ WithLabel txt id

withTitle ∷ ∀ el r. String → WithMoonshine el r el
withTitle txt = liftMoonshine $ WithTitle txt id

withText ∷ ∀ el r. String → WithMoonshine el r el
withText txt = liftMoonshine $ WithText txt id

before ∷ ∀ el r. el → WithMoonshine el r ~> WithMoonshine el r
before el a = liftMoonshine $ Before el a

after ∷ ∀ el r. el → WithMoonshine el r ~> WithMoonshine el r
after el a = liftMoonshine $ After el a

before_ ∷ ∀ el r. WithMoonshine el r el → WithMoonshine el r el → WithMoonshine el r el
before_ b s = b >>= \a → before a s

after_ ∷ ∀ el r. WithMoonshine el r el → WithMoonshine el r el → WithMoonshine el r el
after_ b s = b >>= \a → after a s

runMoonshine ∷ ∀ r. WithMoonshine LT.Element (lunapark ∷ LP.LUNAPARK|r) ~> R.Run (lunapark ∷ LP.LUNAPARK|r)
runMoonshine = loop
  where
  handleMoonshine = R.on _moonshine Left Right
  loop r = case R.peel r of
    Right a → pure a
    Left rr → case handleMoonshine rr of
      Right others → loop =<< R.send others
      Left mf → case mf of
        WithLabel txt cont →
          loop =<< (map cont $ LP.findElement $ LT.ByCss $ fromString "*")
        WithTitle txt cont →
          loop =<< (map cont $ LP.findElement $ LT.ByCss $ fromString "*")
        WithText txt cont →
          loop =<< (map cont $ LP.findElement $ LT.ByCss $ fromString "*")
        Before el moon → do
          loop $ join moon
        After el moon →
          loop $ join moon

newtype TableDescription = TableDescription Void

data ExpectationF el a
  = Exists el a
  | IsChecked el a
  | IsEnabled el a
  | HasSelection String el a
  | Table TableDescription el a

derive instance functorExpectationF ∷ Functor (ExpectationF el)

_expectation = SProxy ∷ SProxy "expectation"
type EXPECTATION el = R.FProxy (ExpectationF el)
type WithExpectation el r a = R.Run (expectation ∷ EXPECTATION el|r) a

liftExpectation ∷ ∀ el r. ExpectationF el ~> WithExpectation el r
liftExpectation = R.lift _expectation

exists ∷ ∀ el r. el → WithExpectation el r Unit
exists el = liftExpectation $ Exists el unit

isChecked ∷ ∀ el r. el → WithExpectation el r Unit
isChecked el = liftExpectation $ IsChecked el unit

isEnabled ∷ ∀ el r. el → WithExpectation el r Unit
isEnabled el = liftExpectation $ IsEnabled el unit

hasSelection ∷ ∀ el r. String → el → WithExpectation el r Unit
hasSelection txt el = liftExpectation $ HasSelection txt el unit

table ∷ ∀ el r. TableDescription → el → WithExpectation el r Unit
table descr el = liftExpectation $ Table descr el unit

runExpectation
  ∷ ∀ r
  . WithExpectation LT.Element (lunapark ∷ LP.LUNAPARK, except ∷ RE.EXCEPT LP.Error|r)
  ~> R.Run (lunapark ∷ LP.LUNAPARK, except ∷ RE.EXCEPT LP.Error |r)
runExpectation = R.interpretRec (R.on _expectation handleExpectation R.send)
  where
  handleExpectation ∷ ExpectationF LT.Element ~> R.Run (lunapark ∷ LP.LUNAPARK, except ∷ RE.EXCEPT LP.Error |r)
  handleExpectation = case _ of
    Exists el next → do
      j ← LP.executeScript { script: "var el = arguments[0]; return !!el", args: [LT.encodeElement el ] }
      res ← throwLeft $ J.decodeJson j
      unless res $ RE.throw
        { error: LP.StaleElementReference
        , message: "The element " <> un LT.Element el <> " doesn't exist"
        , stacktrace: ""
        }
      pure next
    IsChecked el next → do
      res ← LP.isSelected el
      unless res $ RE.throw
        { error: LP.UnknownError
        , message: "The element " <> un LT.Element el <> " is not selected"
        , stacktrace: ""
        }
      pure next
    IsEnabled el next → do
      res ← LP.isEnabled el
      unless res $ RE.throw
        { error: LP.UnknownError
        , message: "The element " <> un LT.Element el <> " is not enabled"
        , stacktrace: ""
        }
      pure next
    HasSelection txt el next → do
      opts ← LP.childElements el $ LT.ByCss $ fromString $ "option[text='" <> txt <> "']"
      inputs ← LP.childElements el $ LT.ByCss $ fromString "input"
      values ← T.for inputs $ flip LP.getProperty "value"
      let compatibles = flip T.foldMap values \j → case J.decodeJson j of
            Left _ → [ ]
            Right c → if Str.contains (Str.Pattern txt) c then [c] else [ ]
      unless (A.length compatibles + A.length opts > 0) $ RE.throw
        { error: LP.UnknownError
        , message: "The element " <> un LT.Element el <> " has now " <> txt <> " selection"
        , stacktrace: ""
        }
      pure next
    Table _ _ next → pure next


retry
  ∷ ∀ e a lval r
  . RetryInput
  → R.Run (eff ∷ R.EFF (ref ∷ REF|e), aff ∷ R.AFF (ref ∷ REF|e), except ∷ RE.EXCEPT lval|r) a
  → R.Run (eff ∷ R.EFF (ref ∷ REF|e), aff ∷ R.AFF (ref ∷ REF|e), except ∷ RE.EXCEPT lval|r) a
retry { step, total } action = do
  elapsed ← R.liftEff $ newRef false
  _ ← R.liftAff $ forkAff do
    delay total
    liftEff $ writeRef elapsed true
  let attempt = action `catch` \err → do
        shouldRethrow ← R.liftEff $ readRef elapsed
        if shouldRethrow
          then RE.throw err
          else do
          R.liftAff $ delay step
          attempt
  attempt


main ∷ ∀ e. Eff (console ∷ CONSOLE|e) Unit
main = void $ launchAff do
  R.runBaseAff' $ interpret do
    section "section" do
      R.liftEff $ log "ZZZ"

tst ∷ _
tst = section "foo" do
  await (withText "foo") isEnabled
  await (before_ (withText "foo") (withLabel "bar")) $ hasSelection "baz"
  awaitNot (withText "booz") exists
  expect (withText "quux") exists
--  _ ← await (pure 2) \x → pure $ x + 2
--  void $ await (pure "") \x → pure $ x <> ""
--  awaitNot (pure 1.0) \x → pure $ x + 1.0
--  expect (pure 1.0) \x → pure $ x * 2.0