Fix test

Fix test

module Test.Spec.GenTransSpec (genTransSpec) where

import Prelude
import Debug.Trace
import Data.Tuple (Tuple(..))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)
import Data.List (List(..), toList, length, fromList, singleton)
import Data.Map (Map(..))
import qualified Data.Map as Map
import qualified Data.Array as A
import Data.Foldable (for_, intercalate)
import Control.Monad.Eff.Exception (error, throwException)
import qualified Text.Parsing.Parser as P

import Language.Docopt
import Language.Docopt.ParserGen (genParser, runParser)
import qualified Language.Docopt.ParserGen.Trans as T

import Test.Assert (assert)
import Test.Spec (describe, it, Spec())
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff, prettyPrintMap)
import Test.Support.Docopt

(:>) = Tuple
infixr 0 :>

newtype Test = Test {
  i :: Array (Tuple Argument Value)
, o :: Array (Tuple String Value)
}

shouldBecome :: Array (Tuple Argument Value)
             -> Array (Tuple String Value)
             -> Test
shouldBecome i o = Test { i: i, o: o }

genTransSpec = \_ ->
  describe "The output transformer" do

    let tests = [
          [ opt  'i' "input" (oa "BAR" $ str "Foo") :> str "qux"
          , optR 'i' "input" (oa_ "BAR")            :> str "xuq" ]
            `shouldBecome`
              [ "-i"     :> str "xuq"
              , "--input" :> str "xuq"
              ]
        ]

    for_ tests \(Test test) -> do

      let inp = Map.fromList $ toList test.i
          exp = Map.fromList $ toList test.o
          out = T.byName inp

      describe (prettyPrintIn inp) do
        it (prettyPrintOut exp) do
          vliftEff do
            if exp == out
                then return unit
                else throwException $ error $
                      "Unexpected output:\n"
                        ++ prettyPrintOut out

  where
    pretty :: forall k. Map k Value -> (k -> String) -> String
    pretty m = flip (prettyPrintMap m) prettyPrintValue

    prettyPrintIn :: Map Argument Value -> String
    prettyPrintIn m = "\n\t" ++ (pretty m prettyPrintArg)

    prettyPrintOut :: Map String Value -> String
    prettyPrintOut m = "\n\t" ++ (pretty m show)

module Test.Spec.GenTransSpec (genTransSpec) where

import Prelude
import Debug.Trace
import Data.Tuple (Tuple(..))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)
import Data.List (List(..), toList, length, fromList, singleton)
import Data.Map (Map(..))
import qualified Data.Map as Map
import qualified Data.Array as A
import Data.Foldable (for_, intercalate)
import Control.Monad.Eff.Exception (error, throwException)
import qualified Text.Parsing.Parser as P

import Language.Docopt
import Language.Docopt.ParserGen (genParser, runParser)
import qualified Language.Docopt.ParserGen.Trans as T

import Test.Assert (assert)
import Test.Spec (describe, it, Spec())
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff, prettyPrintMap)
import Test.Support.Docopt

(:>) = Tuple
infixr 0 :>

newtype Test = Test {
  i :: Array (Tuple Argument Value)
, o :: Array (Tuple String Value)
}

shouldBecome :: Array (Tuple Argument Value)
             -> Array (Tuple String Value)
             -> Test
shouldBecome i o = Test { i: i, o: o }

genTransSpec = \_ ->
  describe "The output transformer" do

    let tests = [
          [ opt  'i' "input" (oa "BAR" $ str "Foo") :> str "qux"
          , optR 'i' "input" (oa_ "BAR")            :> str "xuq" ]
            `shouldBecome`
              [ "i"     :> str "xuq"
              , "input" :> str "xuq"
              ]
        ]

    for_ tests \(Test test) -> do

      let inp = Map.fromList $ toList test.i
          exp = Map.fromList $ toList test.o
          out = T.byName inp

      describe (prettyPrintIn inp) do
        it (prettyPrintOut exp) do
          vliftEff do
            if exp == out
                then return unit
                else throwException $ error $
                      "Unexpected output:\n"
                        ++ prettyPrintOut out

  where
    pretty :: forall k. Map k Value -> (k -> String) -> String
    pretty m = flip (prettyPrintMap m) prettyPrintValue

    prettyPrintIn :: Map Argument Value -> String
    prettyPrintIn m = "\n\t" ++ (pretty m prettyPrintArg)

    prettyPrintOut :: Map String Value -> String
    prettyPrintOut m = "\n\t" ++ (pretty m show)


Get tests running by not rendering inactive guides

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Component
  ( component
  , module SlamData.Workspace.Component.Query
  ) where

import SlamData.Prelude

import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (makeVar, peekVar, takeVar, putVar)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff.Ref (readRef)
import Control.Monad.Fork (fork)
import Control.UI.Browser as Browser

import Data.List as List
import Data.Time.Duration (Milliseconds(..))

import DOM.Classy.Event (currentTarget, target) as DOM
import DOM.Classy.Node (toNode) as DOM

import Halogen as H

import Halogen.Component.Utils (busEventSource)
import Halogen.Component.Utils.Throttled (throttledEventSource_)
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.FileSystem.Resource as R
import SlamData.GlobalError as GE
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.Guide.StepByStep.Component as Guide
import SlamData.Header.Component as Header
import SlamData.Header.Gripper.Component as Gripper
import SlamData.Monad (Slam)
import SlamData.Notification.Component as NC
import SlamData.Quasar as Quasar
import SlamData.Quasar.Auth.Authentication as Authentication
import SlamData.Quasar.Error as QE
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Card.Table.Model as JT
import SlamData.Workspace.Class (navigate, Routes(..))
import SlamData.Workspace.Component.ChildSlot (ChildQuery, ChildSlot, cpDeck, cpGuide, cpHeader, cpNotify)
import SlamData.Workspace.Component.Query (Query(..))
import SlamData.Workspace.Component.State (State, initialState)
import SlamData.Workspace.Deck.Component as Deck
import SlamData.Workspace.Eval.Deck as ED
import SlamData.Workspace.Eval.Persistence as P
import SlamData.Workspace.Eval.Traverse as ET
import SlamData.Workspace.Guide (GuideType(..))
import SlamData.Workspace.Guide as GuideData
import SlamData.Workspace.StateMode (StateMode(..))

import Utils (endSentence)
import Utils.DOM (onResize, nodeEq)
import Utils.LocalStorage as LocalStorage

type WorkspaceHTML = H.ParentHTML Query ChildQuery ChildSlot Slam
type WorkspaceDSL = H.ParentDSL State Query ChildQuery ChildSlot Void Slam

component ∷ AT.AccessType → H.Component HH.HTML Query Unit Void Slam
component accessType =
  H.lifecycleParentComponent
    { initialState: const initialState
    , render: render accessType
    , eval
    , initializer: Just $ Init unit
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ AT.AccessType → State → WorkspaceHTML
render accessType state =
  HH.div
    [ HP.classes
        $ (guard (AT.isReadOnly accessType) $> HH.ClassName "sd-published")
        ⊕ [ HH.ClassName "sd-workspace" ]
    , HE.onClick (HE.input DismissAll)
    ]
    [ header
    , deck
    , notifications
    , cardGuide
    , flipGuide
    ]
  where
  renderError err =
    HH.div
      [ HP.classes [ HH.ClassName "sd-workspace-error" ] ]
      [ HH.h1_
          [ HH.text "Couldn't load this SlamData workspace." ]
      , HH.p_
          [ HH.text $ endSentence $ QE.printQError err ]
      , if (QE.isUnauthorized err)
          then HH.p_ (renderSignInButton <$> state.providers)
          else HH.text ""
      ]

  renderSignInButton providerR =
    HH.button
      [ HE.onClick $ HE.input_ $ SignIn providerR
      , HP.classes [ HH.ClassName "btn", HH.ClassName "btn-primary" ]
      , HP.type_ HP.ButtonButton
      ]
      [ HH.text $ "Sign in with " ⊕ providerR.displayName ]

  cardGuide =
    if state.guide ≡ Just CardGuide
      then HH.div_ [ HH.slot' cpGuide CardGuide Guide.component GuideData.cardGuideSteps (HE.input (HandleGuideMessage CardGuide)) ]
      else HH.text ""

  flipGuide =
    if state.guide ≡ Just FlipGuide
      then HH.div_ [ HH.slot' cpGuide FlipGuide Guide.component GuideData.flipGuideSteps (HE.input (HandleGuideMessage FlipGuide)) ]
      else HH.text ""

  notifications =
    HH.slot' cpNotify unit (NC.component (NC.renderModeFromAccessType accessType)) unit (const Nothing)

  header =
    if AT.isEditable accessType
      then HH.slot' cpHeader unit Header.component unit absurd
      else HH.text ""

  deck =
    case state.stateMode, state.cursor of
      Error error, _ → renderError error
      Loading, _ →
        HH.div
          [ HP.class_ $ HH.ClassName "sd-pending-overlay" ]
          [ HH.div_
              [ HH.i_ []
              , HH.span_ [ HH.text "Please wait while the workspace loads" ]
              ]
          ]
      _, List.Cons deckId cursor →
        HH.slot' cpDeck deckId (Deck.component { accessType, cursor, displayCursor: mempty, deckId }) unit (const Nothing)
      _, _ → HH.text "Error"

eval ∷ Query ~> WorkspaceDSL
eval = case _ of
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (H.request ∘ PresentStepByStepGuide) bus.stepByStep
    H.subscribe $ throttledEventSource_ (Milliseconds 100.0) onResize (H.request Resize)
    pure next
  PresentStepByStepGuide guideType reply → do
    H.modify (_ { guide = Just guideType })
    pure $ reply H.Listening
  DismissAll ev next → do
    void $ H.query' cpHeader unit $ H.action Header.Dismiss
    H.gets _.cursor >>= List.head >>> traverse_ \deckId → do
      eq ← H.liftEff $ nodeEq (DOM.toNode (DOM.target ev)) (DOM.toNode (DOM.currentTarget ev))
      when eq $ Wiring.focusDeck deckId
    pure next
  Resize reply → do
    queryDeck (H.action Deck.UpdateCardSize)
    pure $ reply H.Listening
  New next → do
    st ← H.get
    when (List.null st.cursor) do
      fork $ runFreshWorkspace mempty
      initializeGuides
    pure next
  ExploreFile res next → do
    st ← H.get
    when (List.null st.cursor) do
      fork $ runFreshWorkspace
        [ CM.Open (R.File res)
        , CM.Table JT.emptyModel
        ]
      initializeGuides
    pure next
  Load cursor next → do
    st ← H.get
    case st.stateMode of
      Loading → do
        rootId ← H.lift P.loadWorkspace
        case rootId of
          Left err → do
            providers ←
              Quasar.retrieveAuthProviders <#> case _ of
                Right (Just providers) → providers
                _ → []
            H.modify _
              { stateMode = Error err
              , providers = providers
              }
            for_ (GE.fromQError err) GE.raiseGlobalError
          Right _ → loadCursor cursor
      _ → loadCursor cursor
    initializeGuides
    pure next
  SignIn providerR next → do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ takeVar idToken)
    pure next
  HandleGuideMessage slot Guide.Dismissed next → do
    case slot of
      CardGuide → do
        H.lift $ LocalStorage.setLocalStorage GuideData.dismissedCardGuideKey true
        void $ queryDeck $ H.action Deck.DismissedCardGuide
      FlipGuide → do
        H.lift $ LocalStorage.setLocalStorage GuideData.dismissedFlipGuideKey true
    H.modify (_ { guide = Nothing })
    pure next
  HandleNotification msg next →
    handleNotification msg $> next

  where
  loadCursor cursor = do
    cursor' ←
      if List.null cursor
        then do
          wiring ← H.lift Wiring.expose
          rootId ← H.liftAff $ peekVar wiring.eval.root
          pure (pure rootId)
        else
          hydrateCursor cursor
    H.modify _
      { stateMode = Ready
      , cursor = cursor'
      }
    for_ (List.head cursor') Wiring.focusDeck

  hydrateCursor cursor = H.lift do
    wiring ← Wiring.expose
    ET.hydrateCursor
      <$> Cache.snapshot wiring.eval.decks
      <*> Cache.snapshot wiring.eval.cards
      <*> pure cursor

  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  signInSuccess = do
    { auth } ← H.lift Wiring.expose
    H.liftAff $ Bus.write SignInSuccess $ auth.signIn
    H.liftEff Browser.reload

  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      for_ (Authentication.toNotificationOptions error) $
        flip Bus.write bus.notify
      Bus.write SignInFailure auth.signIn

runFreshWorkspace ∷ Array CM.AnyCardModel → WorkspaceDSL Unit
runFreshWorkspace cards = do
  { path, accessType, varMaps, bus } ← H.lift Wiring.expose
  deckId × cell ← H.lift $ P.freshWorkspace cards
  H.modify _
    { stateMode = Ready
    , cursor = pure deckId
    }
  Wiring.focusDeck deckId
  let
    wait =
      H.liftAff (Bus.read cell.bus) >>= case _ of
        ED.Pending _ → wait
        ED.Complete _ _ → wait
        ED.CardComplete _ → wait
        ED.CardChange _ → H.gets _.cursor
        ED.NameChange _ → H.gets _.cursor
  cursor ← wait
  H.lift P.saveWorkspace
  urlVarMaps ← H.liftEff $ readRef varMaps
  navigate $ WorkspaceRoute path cursor (WA.Load accessType) urlVarMaps

initializeGuides ∷ WorkspaceDSL Unit
initializeGuides = do
  { bus, accessType } ← H.lift Wiring.expose
  initialCardGuideStep >>= case _ of
    Nothing → do
      void $ queryDeck $ H.action Deck.DismissedCardGuide
    Just ix → when (AT.isEditable accessType) do
      void $ H.query' cpGuide CardGuide $ H.action $ Guide.SetActiveStep ix
      H.modify _ { guide = Just CardGuide }

handleNotification ∷ NC.Action → WorkspaceDSL Unit
handleNotification = case _ of
  NC.ExpandGlobalMenu → do
    queryHeaderGripper $ Gripper.StartDragging 0.0 unit
    queryHeaderGripper $ Gripper.StopDragging unit
  NC.Fulfill var →
    void $ H.liftAff $ Aff.attempt $ putVar var unit

queryHeaderGripper ∷ Gripper.Query Unit → WorkspaceDSL Unit
queryHeaderGripper q =
  void $ H.query' cpHeader unit $ Header.QueryGripper q unit

queryDeck ∷ ∀ a. Deck.Query a → WorkspaceDSL (Maybe a)
queryDeck q = do
  deckId ← H.gets (List.head ∘ _.cursor)
  join <$> for deckId \d → H.query' cpDeck d q

initialCardGuideStep ∷ WorkspaceDSL (Maybe Int)
initialCardGuideStep =
  H.lift
    $ either (const $ Just 0) (if _ then Nothing else Just 0)
    <$> LocalStorage.getLocalStorage GuideData.dismissedCardGuideKey

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Component
  ( component
  , module SlamData.Workspace.Component.Query
  ) where

import SlamData.Prelude

import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (makeVar, peekVar, takeVar, putVar)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff.Ref (readRef)
import Control.Monad.Fork (fork)
import Control.UI.Browser as Browser

import Data.List as List
import Data.Time.Duration (Milliseconds(..))

import DOM.Classy.Event (currentTarget, target) as DOM
import DOM.Classy.Node (toNode) as DOM

import Halogen as H

import Halogen.Component.Utils (busEventSource)
import Halogen.Component.Utils.Throttled (throttledEventSource_)
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.FileSystem.Resource as R
import SlamData.GlobalError as GE
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.Guide.StepByStep.Component as Guide
import SlamData.Header.Component as Header
import SlamData.Header.Gripper.Component as Gripper
import SlamData.Monad (Slam)
import SlamData.Notification.Component as NC
import SlamData.Quasar as Quasar
import SlamData.Quasar.Auth.Authentication as Authentication
import SlamData.Quasar.Error as QE
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Card.Table.Model as JT
import SlamData.Workspace.Class (navigate, Routes(..))
import SlamData.Workspace.Component.ChildSlot (ChildQuery, ChildSlot, cpDeck, cpGuide, cpHeader, cpNotify)
import SlamData.Workspace.Component.Query (Query(..))
import SlamData.Workspace.Component.State (State, initialState)
import SlamData.Workspace.Deck.Component as Deck
import SlamData.Workspace.Eval.Deck as ED
import SlamData.Workspace.Eval.Persistence as P
import SlamData.Workspace.Eval.Traverse as ET
import SlamData.Workspace.Guide (GuideType(..))
import SlamData.Workspace.Guide as GuideData
import SlamData.Workspace.StateMode (StateMode(..))

import Utils (endSentence)
import Utils.DOM (onResize, nodeEq)
import Utils.LocalStorage as LocalStorage

type WorkspaceHTML = H.ParentHTML Query ChildQuery ChildSlot Slam
type WorkspaceDSL = H.ParentDSL State Query ChildQuery ChildSlot Void Slam

component ∷ AT.AccessType → H.Component HH.HTML Query Unit Void Slam
component accessType =
  H.lifecycleParentComponent
    { initialState: const initialState
    , render: render accessType
    , eval
    , initializer: Just $ Init unit
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ AT.AccessType → State → WorkspaceHTML
render accessType state =
  HH.div
    [ HP.classes
        $ (guard (AT.isReadOnly accessType) $> HH.ClassName "sd-published")
        ⊕ [ HH.ClassName "sd-workspace" ]
    , HE.onClick (HE.input DismissAll)
    ]
    [ header
    , deck
    , notifications
    , cardGuide
    , flipGuide
    ]
  where
  renderError err =
    HH.div
      [ HP.classes [ HH.ClassName "sd-workspace-error" ] ]
      [ HH.h1_
          [ HH.text "Couldn't load this SlamData workspace." ]
      , HH.p_
          [ HH.text $ endSentence $ QE.printQError err ]
      , if (QE.isUnauthorized err)
          then HH.p_ (renderSignInButton <$> state.providers)
          else HH.text ""
      ]

  renderSignInButton providerR =
    HH.button
      [ HE.onClick $ HE.input_ $ SignIn providerR
      , HP.classes [ HH.ClassName "btn", HH.ClassName "btn-primary" ]
      , HP.type_ HP.ButtonButton
      ]
      [ HH.text $ "Sign in with " ⊕ providerR.displayName ]

  cardGuide =
    HH.div
      [ HP.classes (guard (state.guide /= Just CardGuide) $> B.hidden) ]
      [ HH.slot' cpGuide CardGuide Guide.component GuideData.cardGuideSteps (HE.input (HandleGuideMessage CardGuide)) ]

  flipGuide =
    HH.div
      [ HP.classes (guard (state.guide /= Just FlipGuide) $> B.hidden) ]
      [ HH.slot' cpGuide FlipGuide Guide.component GuideData.flipGuideSteps (HE.input (HandleGuideMessage FlipGuide)) ]

  notifications =
    HH.slot' cpNotify unit (NC.component (NC.renderModeFromAccessType accessType)) unit (const Nothing)

  header =
    if AT.isEditable accessType
      then HH.slot' cpHeader unit Header.component unit absurd
      else HH.text ""

  deck =
    case state.stateMode, state.cursor of
      Error error, _ → renderError error
      Loading, _ →
        HH.div
          [ HP.class_ $ HH.ClassName "sd-pending-overlay" ]
          [ HH.div_
              [ HH.i_ []
              , HH.span_ [ HH.text "Please wait while the workspace loads" ]
              ]
          ]
      _, List.Cons deckId cursor →
        HH.slot' cpDeck deckId (Deck.component { accessType, cursor, displayCursor: mempty, deckId }) unit (const Nothing)
      _, _ → HH.text "Error"

eval ∷ Query ~> WorkspaceDSL
eval = case _ of
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (H.request ∘ PresentStepByStepGuide) bus.stepByStep
    H.subscribe $ throttledEventSource_ (Milliseconds 100.0) onResize (H.request Resize)
    pure next
  PresentStepByStepGuide guideType reply → do
    H.modify (_ { guide = Just guideType })
    pure $ reply H.Listening
  DismissAll ev next → do
    void $ H.query' cpHeader unit $ H.action Header.Dismiss
    H.gets _.cursor >>= List.head >>> traverse_ \deckId → do
      eq ← H.liftEff $ nodeEq (DOM.toNode (DOM.target ev)) (DOM.toNode (DOM.currentTarget ev))
      when eq $ Wiring.focusDeck deckId
    pure next
  Resize reply → do
    queryDeck (H.action Deck.UpdateCardSize)
    pure $ reply H.Listening
  New next → do
    st ← H.get
    when (List.null st.cursor) do
      fork $ runFreshWorkspace mempty
      initializeGuides
    pure next
  ExploreFile res next → do
    st ← H.get
    when (List.null st.cursor) do
      fork $ runFreshWorkspace
        [ CM.Open (R.File res)
        , CM.Table JT.emptyModel
        ]
      initializeGuides
    pure next
  Load cursor next → do
    st ← H.get
    case st.stateMode of
      Loading → do
        rootId ← H.lift P.loadWorkspace
        case rootId of
          Left err → do
            providers ←
              Quasar.retrieveAuthProviders <#> case _ of
                Right (Just providers) → providers
                _ → []
            H.modify _
              { stateMode = Error err
              , providers = providers
              }
            for_ (GE.fromQError err) GE.raiseGlobalError
          Right _ → loadCursor cursor
      _ → loadCursor cursor
    initializeGuides
    pure next
  SignIn providerR next → do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ takeVar idToken)
    pure next
  HandleGuideMessage slot Guide.Dismissed next → do
    case slot of
      CardGuide → do
        H.lift $ LocalStorage.setLocalStorage GuideData.dismissedCardGuideKey true
        void $ queryDeck $ H.action Deck.DismissedCardGuide
      FlipGuide → do
        H.lift $ LocalStorage.setLocalStorage GuideData.dismissedFlipGuideKey true
    H.modify (_ { guide = Nothing })
    pure next
  HandleNotification msg next →
    handleNotification msg $> next

  where
  loadCursor cursor = do
    cursor' ←
      if List.null cursor
        then do
          wiring ← H.lift Wiring.expose
          rootId ← H.liftAff $ peekVar wiring.eval.root
          pure (pure rootId)
        else
          hydrateCursor cursor
    H.modify _
      { stateMode = Ready
      , cursor = cursor'
      }
    for_ (List.head cursor') Wiring.focusDeck

  hydrateCursor cursor = H.lift do
    wiring ← Wiring.expose
    ET.hydrateCursor
      <$> Cache.snapshot wiring.eval.decks
      <*> Cache.snapshot wiring.eval.cards
      <*> pure cursor

  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  signInSuccess = do
    { auth } ← H.lift Wiring.expose
    H.liftAff $ Bus.write SignInSuccess $ auth.signIn
    H.liftEff Browser.reload

  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      for_ (Authentication.toNotificationOptions error) $
        flip Bus.write bus.notify
      Bus.write SignInFailure auth.signIn

runFreshWorkspace ∷ Array CM.AnyCardModel → WorkspaceDSL Unit
runFreshWorkspace cards = do
  { path, accessType, varMaps, bus } ← H.lift Wiring.expose
  deckId × cell ← H.lift $ P.freshWorkspace cards
  H.modify _
    { stateMode = Ready
    , cursor = pure deckId
    }
  Wiring.focusDeck deckId
  let
    wait =
      H.liftAff (Bus.read cell.bus) >>= case _ of
        ED.Pending _ → wait
        ED.Complete _ _ → wait
        ED.CardComplete _ → wait
        ED.CardChange _ → H.gets _.cursor
        ED.NameChange _ → H.gets _.cursor
  cursor ← wait
  H.lift P.saveWorkspace
  urlVarMaps ← H.liftEff $ readRef varMaps
  navigate $ WorkspaceRoute path cursor (WA.Load accessType) urlVarMaps

initializeGuides ∷ WorkspaceDSL Unit
initializeGuides = do
  { bus, accessType } ← H.lift Wiring.expose
  initialCardGuideStep >>= case _ of
    Nothing → do
      void $ queryDeck $ H.action Deck.DismissedCardGuide
    Just ix → when (AT.isEditable accessType) do
      void $ H.query' cpGuide CardGuide $ H.action $ Guide.SetActiveStep ix
      H.modify _ { guide = Just CardGuide }

handleNotification ∷ NC.Action → WorkspaceDSL Unit
handleNotification = case _ of
  NC.ExpandGlobalMenu → do
    queryHeaderGripper $ Gripper.StartDragging 0.0 unit
    queryHeaderGripper $ Gripper.StopDragging unit
  NC.Fulfill var →
    void $ H.liftAff $ Aff.attempt $ putVar var unit

queryHeaderGripper ∷ Gripper.Query Unit → WorkspaceDSL Unit
queryHeaderGripper q =
  void $ H.query' cpHeader unit $ Header.QueryGripper q unit

queryDeck ∷ ∀ a. Deck.Query a → WorkspaceDSL (Maybe a)
queryDeck q = do
  deckId ← H.gets (List.head ∘ _.cursor)
  join <$> for deckId \d → H.query' cpDeck d q

initialCardGuideStep ∷ WorkspaceDSL (Maybe Int)
initialCardGuideStep =
  H.lift
    $ either (const $ Just 0) (if _ then Nothing else Just 0)
    <$> LocalStorage.getLocalStorage GuideData.dismissedCardGuideKey


Tweak driver for subscriptions

Tweak driver for subscriptions

Removes some dead code, shores up the loop condition, forks eval to
ensure async queries don’t enqueue.

module Halogen.Aff.Driver.Eval where

import Prelude

import Control.Applicative.Free (hoistFreeAp, retractFreeAp)
import Control.Coroutine as CR
import Control.Monad.Aff (Aff, killFiber)
import Control.Monad.Aff.Unsafe (unsafeCoerceAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Ref (Ref, modifyRef, readRef, writeRef)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Fork.Class (fork)
import Control.Monad.Free (foldFree)
import Control.Monad.Trans.Class (lift)
import Control.Parallel (parSequence_, parallel, sequential)
import Data.Coyoneda (Coyoneda, unCoyoneda)
import Data.Foldable (sequence_, traverse_)
import Data.List (List, (:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.StrMap as SM
import Data.Tuple (Tuple(..))
import Halogen.Aff.Driver.State (DriverState(..), LifecycleHandlers, unDriverStateX)
import Halogen.Aff.Effects (HalogenEffects)
import Halogen.Data.OrdBox (unOrdBox)
import Halogen.Query.EventSource (finalize)
import Halogen.Query.EventSource as ES
import Halogen.Query.ForkF as FF
import Halogen.Query.HalogenM (HalogenAp(..), HalogenF(..), HalogenM(..), SubscriptionId)
import Halogen.Query.InputF (InputF(..), RefLabel(..))
import Unsafe.Reference (unsafeRefEq)

handleLifecycle
  :: forall eff a
   . Ref (LifecycleHandlers eff)
  -> Eff (HalogenEffects eff) a
  -> Aff (HalogenEffects eff) a
handleLifecycle lchs f = do
  liftEff $ writeRef lchs { initializers: L.Nil, finalizers: L.Nil }
  result <- liftEff f
  { initializers, finalizers } <- liftEff $ readRef lchs
  traverse_ fork finalizers
  parSequence_ initializers
  pure result

type Renderer h r eff
  = forall s f z g p i o
   . Ref (LifecycleHandlers eff)
  -> Ref (DriverState h r s f z g p i o eff)
  -> Eff (HalogenEffects eff) Unit

eval
  :: forall h r eff s'' f z g'' p'' i o a
   . Renderer h r eff
  -> Ref (DriverState h r s'' f z g'' p'' i o eff)
  -> InputF a (z a)
  -> Aff (HalogenEffects eff) a
eval render r =
  case _ of
    RefUpdate (RefLabel p) el next -> do
      liftEff $ modifyRef r \(DriverState st) ->
        DriverState st { refs = SM.alter (const el) p st.refs }
      pure next
    Query q -> evalF r q

  where

  go
    :: forall s' f' z' g' p' i' o'
     . Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> HalogenF s' z' g' p' o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  go ref = case _ of
    State f -> do
      DriverState (st@{ state, lifecycleHandlers }) <- liftEff (readRef ref)
      case f state of
        Tuple a state'
          | unsafeRefEq state state' -> pure a
          | otherwise -> do
              liftEff $ writeRef ref (DriverState (st { state = state' }))
              handleLifecycle lifecycleHandlers (render lifecycleHandlers ref)
              pure a
    Subscribe sid es next -> do
      unsubscribe sid ref
      DriverState ({ subscriptions }) <- liftEff (readRef ref)
      _ ← fork do
        { producer, finalizer } <- ES.unEventSource es
        let
          done = do
            subs <- liftEff $ readRef subscriptions
            liftEff $ modifyRef subscriptions (map (M.delete sid))
            when (maybe false (M.member sid) subs) (finalize finalizer)
          consumer = do
            q <- CR.await
            subs <- lift $ liftEff (readRef subscriptions)
            when (M.member sid <$> subs == Just true) do
              _ <- lift $ fork $ evalF ref q
              consumer
        liftEff $ modifyRef subscriptions (map (M.insert sid done))
        CR.runProcess (consumer `CR.pullFrom` producer)
        done
      pure next
    Unsubscribe sid next -> do
      unsubscribe sid ref
      pure next
    Lift aff ->
      aff
    Halt msg ->
      throwError (error msg)
    GetSlots k -> do
      DriverState { children } <- liftEff (readRef ref)
      pure $ k $ map unOrdBox $ M.keys children
    CheckSlot p k -> do
      DriverState { component, children } <- liftEff (readRef ref)
      pure $ k $ M.member (component.mkOrdBox p) children
    ChildQuery p cq ->
      evalChildQuery ref p cq
    Raise o a -> do
      DriverState { handler, pendingOuts } <- liftEff (readRef ref)
      queuingHandler handler pendingOuts o
      pure a
    Par (HalogenAp p) ->
      sequential $ retractFreeAp $ hoistFreeAp (parallel <<< evalM ref) p
    Fork f ->
      FF.unFork (\(FF.ForkF fx k) -> do
        fiber <- fork (evalM ref fx)
        pure $ k (unsafeCoerceAff <<< flip killFiber fiber)) f
    GetRef (RefLabel p) k -> do
      DriverState { component, refs } <- liftEff (readRef ref)
      pure $ k $ SM.lookup p refs

  evalChildQuery
    :: forall s' f' z' g' p' i' o'
     . Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> p'
    -> Coyoneda g'
    ~> Aff (HalogenEffects eff)
  evalChildQuery ref p = unCoyoneda \k q -> do
    DriverState st <- liftEff (readRef ref)
    case M.lookup (st.component.mkOrdBox p) st.children of
      Just var -> do
        dsx <- liftEff (readRef var)
        unDriverStateX (\ds -> case ds.prjQuery q of
          Just q' -> k <$> evalF ds.selfRef q'
          Nothing -> throwError (error "Query projection failed for child query")) dsx
      Nothing -> throwError (error "Slot lookup failed for child query")

  evalF
    :: forall s' f' z' g' p' i' o'
     . Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> z'
    ~> Aff (HalogenEffects eff)
  evalF ref q = do
    DriverState st <- liftEff (readRef ref)
    case st.component.eval q of
      HalogenM fx -> foldFree (go ref) fx

  evalM
    :: forall s' f' z' g' p' i' o'
     . Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> HalogenM s' z' g' p' o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  evalM ref (HalogenM q) = foldFree (go ref) q

  unsubscribe
    :: forall s' f' z' g' p' i' o'
     . SubscriptionId
    -> Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> Aff (HalogenEffects eff) Unit
  unsubscribe sid ref = do
    DriverState ({ subscriptions }) <- liftEff (readRef ref)
    subs <- liftEff (readRef subscriptions)
    sequence_ (M.lookup sid =<< subs)

queuingHandler
  :: forall a eff
   . (a -> Aff (HalogenEffects eff) Unit)
  -> Ref (Maybe (List (Aff (HalogenEffects eff) Unit)))
  -> a
  -> Aff (HalogenEffects eff) Unit
queuingHandler handler ref message = do
  queue <- liftEff (readRef ref)
  case queue of
    Nothing ->
      handler message
    Just p ->
      liftEff $ writeRef ref (Just (handler message : p))

module Halogen.Aff.Driver.Eval where

import Prelude

import Control.Applicative.Free (hoistFreeAp, retractFreeAp)
import Control.Coroutine as CR
import Control.Monad.Aff (Aff, killFiber)
import Control.Monad.Aff.AVar as AV
import Control.Monad.Aff.Unsafe (unsafeCoerceAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Ref (Ref, modifyRef, readRef, writeRef)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Fork.Class (fork)
import Control.Monad.Free (foldFree)
import Control.Monad.Trans.Class (lift)
import Control.Parallel (parSequence_, parallel, sequential)
import Data.Coyoneda (Coyoneda, unCoyoneda)
import Data.Either (Either(..))
import Data.Foldable (sequence_, traverse_)
import Data.List (List, (:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.StrMap as SM
import Data.Tuple (Tuple(..))
import Halogen.Aff.Driver.State (DriverState(..), LifecycleHandlers, unDriverStateX)
import Halogen.Aff.Effects (HalogenEffects)
import Halogen.Data.OrdBox (unOrdBox)
import Halogen.Query.EventSource (finalize)
import Halogen.Query.EventSource as ES
import Halogen.Query.ForkF as FF
import Halogen.Query.HalogenM (HalogenAp(..), HalogenF(..), HalogenM(..), SubscriptionId)
import Halogen.Query.InputF (InputF(..), RefLabel(..))
import Unsafe.Reference (unsafeRefEq)

handleLifecycle
  :: forall eff a
   . Ref (LifecycleHandlers eff)
  -> Eff (HalogenEffects eff) a
  -> Aff (HalogenEffects eff) a
handleLifecycle lchs f = do
  liftEff $ writeRef lchs { initializers: L.Nil, finalizers: L.Nil }
  result <- liftEff f
  { initializers, finalizers } <- liftEff $ readRef lchs
  traverse_ fork finalizers
  parSequence_ initializers
  pure result

type Renderer h r eff
  = forall s f z g p i o
   . Ref (LifecycleHandlers eff)
  -> Ref (DriverState h r s f z g p i o eff)
  -> Eff (HalogenEffects eff) Unit

eval
  :: forall h r eff s'' f z g'' p'' i o a
   . Renderer h r eff
  -> Ref (DriverState h r s'' f z g'' p'' i o eff)
  -> InputF a (z a)
  -> Aff (HalogenEffects eff) a
eval render r =
  case _ of
    RefUpdate (RefLabel p) el next -> do
      liftEff $ modifyRef r \(DriverState st) ->
        DriverState st { refs = SM.alter (const el) p st.refs }
      pure next
    Query q -> evalF r q

  where

  go
    :: forall s' f' z' g' p' i' o'
     . Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> HalogenF s' z' g' p' o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  go ref = case _ of
    State f -> do
      DriverState (st@{ state, lifecycleHandlers }) <- liftEff (readRef ref)
      case f state of
        Tuple a state'
          | unsafeRefEq state state' -> pure a
          | otherwise -> do
              liftEff $ writeRef ref (DriverState (st { state = state' }))
              handleLifecycle lifecycleHandlers (render lifecycleHandlers ref)
              pure a
    Subscribe sid es next -> do
      unsubscribe sid ref
      DriverState ({ subscriptions }) <- liftEff (readRef ref)
      _ ← fork do
        { producer, finalizer } <- ES.unEventSource es
        cancel <- AV.makeEmptyVar
        let
          cancelProducer = CR.producer do
            AV.takeVar cancel $> Right unit
          finalizer' = do
            subs <- liftEff $ readRef subscriptions
            liftEff $ modifyRef subscriptions (map (M.delete sid))
            when (maybe false (M.member sid) subs) (finalize finalizer)
          consumer = do
            q <- CR.await
            subs <- lift $ liftEff (readRef subscriptions)
            when (isJust subs) do
              s <- lift $ evalF ref q
              consumer
        liftEff $ modifyRef subscriptions (map (M.insert sid finalizer'))
        CR.runProcess (consumer `CR.pullFrom` producer)
        finalizer'
      pure next
    Unsubscribe sid next -> do
      unsubscribe sid ref
      pure next
    Lift aff ->
      aff
    Halt msg ->
      throwError (error msg)
    GetSlots k -> do
      DriverState { children } <- liftEff (readRef ref)
      pure $ k $ map unOrdBox $ M.keys children
    CheckSlot p k -> do
      DriverState { component, children } <- liftEff (readRef ref)
      pure $ k $ M.member (component.mkOrdBox p) children
    ChildQuery p cq ->
      evalChildQuery ref p cq
    Raise o a -> do
      DriverState { handler, pendingOuts } <- liftEff (readRef ref)
      queuingHandler handler pendingOuts o
      pure a
    Par (HalogenAp p) ->
      sequential $ retractFreeAp $ hoistFreeAp (parallel <<< evalM ref) p
    Fork f ->
      FF.unFork (\(FF.ForkF fx k) -> do
        fiber <- fork (evalM ref fx)
        pure $ k (unsafeCoerceAff <<< flip killFiber fiber)) f
    GetRef (RefLabel p) k -> do
      DriverState { component, refs } <- liftEff (readRef ref)
      pure $ k $ SM.lookup p refs

  evalChildQuery
    :: forall s' f' z' g' p' i' o'
     . Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> p'
    -> Coyoneda g'
    ~> Aff (HalogenEffects eff)
  evalChildQuery ref p = unCoyoneda \k q -> do
    DriverState st <- liftEff (readRef ref)
    case M.lookup (st.component.mkOrdBox p) st.children of
      Just var -> do
        dsx <- liftEff (readRef var)
        unDriverStateX (\ds -> case ds.prjQuery q of
          Just q' -> k <$> evalF ds.selfRef q'
          Nothing -> throwError (error "Query projection failed for child query")) dsx
      Nothing -> throwError (error "Slot lookup failed for child query")

  evalF
    :: forall s' f' z' g' p' i' o'
     . Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> z'
    ~> Aff (HalogenEffects eff)
  evalF ref q = do
    DriverState st <- liftEff (readRef ref)
    case st.component.eval q of
      HalogenM fx -> foldFree (go ref) fx

  evalM
    :: forall s' f' z' g' p' i' o'
     . Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> HalogenM s' z' g' p' o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  evalM ref (HalogenM q) = foldFree (go ref) q

  unsubscribe
    :: forall s' f' z' g' p' i' o'
     . SubscriptionId
    -> Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> Aff (HalogenEffects eff) Unit
  unsubscribe sid ref = do
    DriverState ({ subscriptions }) <- liftEff (readRef ref)
    subs <- liftEff (readRef subscriptions)
    sequence_ (M.lookup sid =<< subs)

queuingHandler
  :: forall a eff
   . (a -> Aff (HalogenEffects eff) Unit)
  -> Ref (Maybe (List (Aff (HalogenEffects eff) Unit)))
  -> a
  -> Aff (HalogenEffects eff) Unit
queuingHandler handler ref message = do
  queue <- liftEff (readRef ref)
  case queue of
    Nothing ->
      handler message
    Just p ->
      liftEff $ writeRef ref (Just (handler message : p))


[CSM-151] Improve paper vend redeem code validation

module Daedalus.ClientApi where

import Prelude
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (getProfileLocale, mkCAddress, mkCCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit, mkCWalletRedeem, mkCWalletInitIgnoreChecksum, mkBackupPhrase, mkCInitialized, mkCPassPhrase, mkCPostVendWalletRedeem, emptyCPassPhrase)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.String.Base64 as B64
import Data.Base58 as B58
import Data.Array as A
import Data.String (length, stripSuffix, Pattern (..))
import Data.Maybe (isJust, maybe)
import Data.Function.Eff (EffFn1, mkEffFn1, EffFn2, mkEffFn2, EffFn4, mkEffFn4, EffFn3, mkEffFn3, EffFn6, mkEffFn6, EffFn7, mkEffFn7, mkEffFn5, EffFn5)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto

getLocale :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getLocale = fromAff $ map encodeJson (getProfileLocale <$> B.getProfile)

updateLocale :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
updateLocale = mkEffFn1 \locale -> fromAff <<< map encodeJson <<< B.updateProfile $ mkCProfile locale

getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWallets

getWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
getWallet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress

getHistory :: forall eff. EffFn3 (ajax :: AJAX | eff) String Int Int (Promise Json)
getHistory = mkEffFn3 \addr skip limit -> fromAff <<< map encodeJson $
    B.getHistory
        (mkCAddress addr)
        skip
        limit

searchHistory :: forall eff. EffFn4 (ajax :: AJAX | eff) String String Int Int (Promise Json)
searchHistory = mkEffFn4 \addr search skip limit -> fromAff <<< map encodeJson $
    B.searchHistory
        (mkCAddress addr)
        search
        skip
        limit

send :: forall eff. EffFn3 (ajax :: AJAX | eff) String String String (Promise Json)
send = mkEffFn3 \addrFrom addrTo amount -> fromAff <<< map encodeJson $
    B.send
        emptyCPassPhrase
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)

sendExtended :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String String (Promise Json)
sendExtended = mkEffFn6 \addrFrom addrTo amount curr title desc -> fromAff <<< map encodeJson $
    B.sendExtended
        emptyCPassPhrase
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)
        (mkCCurrency curr)
        title
        desc

generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
generateMnemonic = Crypto.generateMnemonic

-- | bip39.validateMnemonic and has at least len words
isValidMnemonic :: forall eff. EffFn2 (crypto :: Crypto.CRYPTO | eff) Int String Boolean
isValidMnemonic = mkEffFn2 \len -> pure <<< either (const false) (const true) <<< mkBackupPhrase len

newWallet :: forall eff . EffFn4 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String String
  (Promise Json)
newWallet = mkEffFn4 \wType wCurrency wName mnemonic -> fromAff <<< map encodeJson <<<
    either throwError (B.newWallet $ mkCPassPhrase "") $ mkCWalletInit wType wCurrency wName mnemonic

-- NOTE: https://issues.serokell.io/issue/DAE-33#comment=96-1798
-- Daedalus.ClientApi.newWallet(
--     'CWTPersonal'
--   , 'ADA'
--   , 'wallet name'
--   , function(mnemonics) {
--     // if this function finishes we will send request for wallet
--     // creation to the backend. That means user validated and
--     // stored mnemonics.
--     // if an exception is thrown new wallet request will be aborted
--     // and promise should return thrown error
--     if(userSavedMnemonics) {
--       // do nothing
--     } else {
--       throw new Error("Wallet canceled")
--     }
--   }
--   )()
--   .then(function(value) {
--     console.log('SUCCESS', value);
--   }, function(reason) {
--     console.log('ERROR', reason);
--   })
-- newWalletDeprecated :: forall eff . Fn4 String String String (EffFn1 (err :: EXCEPTION | eff) String Unit)
--   (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
-- newWalletDeprecated = mkFn4 \wType wCurrency wName wConfirmMnemonic -> fromAff $ map encodeJson $ do
--
--     mnemonic <- liftEff Crypto.generateMnemonic
--     -- FIXME: @jens how did we satisfy this with notify? I am having trouble again
--     isConfirmed <- liftEff' $ unsafeInterleaveEff $ runEffFn1 wConfirmMnemonic mnemonic
--     either throwError B.newWallet $ do
--         isConfirmed
--         mkCWalletInit wType wCurrency wName mnemonic

updateWallet :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Int (Promise Json)
updateWallet = mkEffFn6 \addr wType wCurrency wName wAssurance wUnit -> fromAff <<< map encodeJson <<<
    B.updateWallet
        (mkCAddress addr)
        $ mkCWalletMeta wType wCurrency wName wAssurance wUnit

updateTransaction :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Number (Promise Unit)
updateTransaction = mkEffFn6 \addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
    B.updateTransaction
        (mkCAddress addr)
        (mkCTxId ctxId)
        $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate

deleteWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Unit)
deleteWallet = mkEffFn1 $ fromAff <<< B.deleteWallet <<< mkCAddress

isValidAddress :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Boolean)
isValidAddress = mkEffFn2 \currency -> fromAff <<< B.isValidAddress (mkCCurrency currency)

notify :: forall eff. EffFn2 (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) (NotifyCb eff) (ErrorCb eff) Unit
notify = mkEffFn2 \messageCb errorCb -> do
    -- TODO (akegalj) grab global (mutable) state of  here
    -- instead of creating newRef
    conn <- newRef WSNotConnected
    openConn $ mkWSState conn messageCb errorCb

blockchainSlotDuration :: forall eff. Eff (ajax :: AJAX | eff) (Promise Int)
blockchainSlotDuration = fromAff B.blockchainSlotDuration

restoreWallet :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
restoreWallet = mkEffFn4 \wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase "") <<< mkCWalletInit wType wCurrency wName

restoreWalletIgnoreChecksum :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
restoreWalletIgnoreChecksum = mkEffFn4 \wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase "") <<< mkCWalletInitIgnoreChecksum wType wCurrency wName

nextUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
nextUpdate = fromAff $ map encodeJson B.nextUpdate

applyUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
applyUpdate = fromAff B.applyUpdate

systemVersion :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
systemVersion = fromAff $ map encodeJson B.systemVersion

redeemADA :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String (Promise Json)
redeemADA = mkEffFn2 \seed -> fromAff <<< map encodeJson <<< B.redeemADA <<< mkCWalletRedeem seed

postVendRedeemADA :: forall eff. EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String (Promise Json)
postVendRedeemADA = mkEffFn3 \seed mnemonic -> fromAff <<< map encodeJson <<< either throwError B.postVendRedeemADA <<< mkCPostVendWalletRedeem seed mnemonic

reportInit :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) Int Int (Promise Unit)
reportInit = mkEffFn2 \total -> fromAff <<< B.reportInit <<< mkCInitialized total

importKey :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
importKey = mkEffFn1 $ fromAff <<< map encodeJson <<< B.importKey

syncProgress :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
syncProgress = fromAff $ map encodeJson B.syncProgress

testReset :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
testReset = fromAff B.testReset

-- Valid redeem code is base64 encoded 32byte data
-- NOTE: this method handles both base64 and base64url base on rfc4648: see more https://github.com/menelaos/purescript-b64/blob/59e2e9189358a4c8e3eef8662ca281906844e783/src/Data/String/Base64.purs#L182
isValidRedeemCode :: String -> Boolean
isValidRedeemCode code = either (const false) (const $ endsWithEqual && 44 == length code) $ B64.decode code
  where
    -- Because it is 32byte base64 encoded
    endsWithEqual = isJust $ stripSuffix (Pattern "=") code

-- Valid postvend code is base58 encoded 32byte data
isValidPostVendRedeemCode :: String -> Boolean
isValidPostVendRedeemCode code = maybe false ((==) 32 <<< A.length) $ B58.decode code

module Daedalus.ClientApi where

import Prelude
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (getProfileLocale, mkCAddress, mkCCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit, mkCWalletRedeem, mkCWalletInitIgnoreChecksum, mkBackupPhrase, mkCInitialized, mkCPassPhrase, mkCPostVendWalletRedeem, emptyCPassPhrase)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.String.Base64 as B64
import Data.Base58 as B58
import Data.String (length, stripSuffix, Pattern (..))
import Data.Maybe (isJust, maybe)
import Data.Function.Eff (EffFn1, mkEffFn1, EffFn2, mkEffFn2, EffFn4, mkEffFn4, EffFn3, mkEffFn3, EffFn6, mkEffFn6, EffFn7, mkEffFn7, mkEffFn5, EffFn5)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto

getLocale :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getLocale = fromAff $ map encodeJson (getProfileLocale <$> B.getProfile)

updateLocale :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
updateLocale = mkEffFn1 \locale -> fromAff <<< map encodeJson <<< B.updateProfile $ mkCProfile locale

getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWallets

getWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
getWallet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress

getHistory :: forall eff. EffFn3 (ajax :: AJAX | eff) String Int Int (Promise Json)
getHistory = mkEffFn3 \addr skip limit -> fromAff <<< map encodeJson $
    B.getHistory
        (mkCAddress addr)
        skip
        limit

searchHistory :: forall eff. EffFn4 (ajax :: AJAX | eff) String String Int Int (Promise Json)
searchHistory = mkEffFn4 \addr search skip limit -> fromAff <<< map encodeJson $
    B.searchHistory
        (mkCAddress addr)
        search
        skip
        limit

send :: forall eff. EffFn3 (ajax :: AJAX | eff) String String String (Promise Json)
send = mkEffFn3 \addrFrom addrTo amount -> fromAff <<< map encodeJson $
    B.send
        emptyCPassPhrase
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)

sendExtended :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String String (Promise Json)
sendExtended = mkEffFn6 \addrFrom addrTo amount curr title desc -> fromAff <<< map encodeJson $
    B.sendExtended
        emptyCPassPhrase
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)
        (mkCCurrency curr)
        title
        desc

generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
generateMnemonic = Crypto.generateMnemonic

-- | bip39.validateMnemonic and has at least len words
isValidMnemonic :: forall eff. EffFn2 (crypto :: Crypto.CRYPTO | eff) Int String Boolean
isValidMnemonic = mkEffFn2 \len -> pure <<< either (const false) (const true) <<< mkBackupPhrase len

newWallet :: forall eff . EffFn4 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String String
  (Promise Json)
newWallet = mkEffFn4 \wType wCurrency wName mnemonic -> fromAff <<< map encodeJson <<<
    either throwError (B.newWallet $ mkCPassPhrase "") $ mkCWalletInit wType wCurrency wName mnemonic

-- NOTE: https://issues.serokell.io/issue/DAE-33#comment=96-1798
-- Daedalus.ClientApi.newWallet(
--     'CWTPersonal'
--   , 'ADA'
--   , 'wallet name'
--   , function(mnemonics) {
--     // if this function finishes we will send request for wallet
--     // creation to the backend. That means user validated and
--     // stored mnemonics.
--     // if an exception is thrown new wallet request will be aborted
--     // and promise should return thrown error
--     if(userSavedMnemonics) {
--       // do nothing
--     } else {
--       throw new Error("Wallet canceled")
--     }
--   }
--   )()
--   .then(function(value) {
--     console.log('SUCCESS', value);
--   }, function(reason) {
--     console.log('ERROR', reason);
--   })
-- newWalletDeprecated :: forall eff . Fn4 String String String (EffFn1 (err :: EXCEPTION | eff) String Unit)
--   (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
-- newWalletDeprecated = mkFn4 \wType wCurrency wName wConfirmMnemonic -> fromAff $ map encodeJson $ do
--
--     mnemonic <- liftEff Crypto.generateMnemonic
--     -- FIXME: @jens how did we satisfy this with notify? I am having trouble again
--     isConfirmed <- liftEff' $ unsafeInterleaveEff $ runEffFn1 wConfirmMnemonic mnemonic
--     either throwError B.newWallet $ do
--         isConfirmed
--         mkCWalletInit wType wCurrency wName mnemonic

updateWallet :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Int (Promise Json)
updateWallet = mkEffFn6 \addr wType wCurrency wName wAssurance wUnit -> fromAff <<< map encodeJson <<<
    B.updateWallet
        (mkCAddress addr)
        $ mkCWalletMeta wType wCurrency wName wAssurance wUnit

updateTransaction :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Number (Promise Unit)
updateTransaction = mkEffFn6 \addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
    B.updateTransaction
        (mkCAddress addr)
        (mkCTxId ctxId)
        $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate

deleteWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Unit)
deleteWallet = mkEffFn1 $ fromAff <<< B.deleteWallet <<< mkCAddress

isValidAddress :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Boolean)
isValidAddress = mkEffFn2 \currency -> fromAff <<< B.isValidAddress (mkCCurrency currency)

notify :: forall eff. EffFn2 (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) (NotifyCb eff) (ErrorCb eff) Unit
notify = mkEffFn2 \messageCb errorCb -> do
    -- TODO (akegalj) grab global (mutable) state of  here
    -- instead of creating newRef
    conn <- newRef WSNotConnected
    openConn $ mkWSState conn messageCb errorCb

blockchainSlotDuration :: forall eff. Eff (ajax :: AJAX | eff) (Promise Int)
blockchainSlotDuration = fromAff B.blockchainSlotDuration

restoreWallet :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
restoreWallet = mkEffFn4 \wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase "") <<< mkCWalletInit wType wCurrency wName

restoreWalletIgnoreChecksum :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
restoreWalletIgnoreChecksum = mkEffFn4 \wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase "") <<< mkCWalletInitIgnoreChecksum wType wCurrency wName

nextUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
nextUpdate = fromAff $ map encodeJson B.nextUpdate

applyUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
applyUpdate = fromAff B.applyUpdate

systemVersion :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
systemVersion = fromAff $ map encodeJson B.systemVersion

redeemADA :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String (Promise Json)
redeemADA = mkEffFn2 \seed -> fromAff <<< map encodeJson <<< B.redeemADA <<< mkCWalletRedeem seed

postVendRedeemADA :: forall eff. EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String (Promise Json)
postVendRedeemADA = mkEffFn3 \seed mnemonic -> fromAff <<< map encodeJson <<< either throwError B.postVendRedeemADA <<< mkCPostVendWalletRedeem seed mnemonic

reportInit :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) Int Int (Promise Unit)
reportInit = mkEffFn2 \total -> fromAff <<< B.reportInit <<< mkCInitialized total

importKey :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
importKey = mkEffFn1 $ fromAff <<< map encodeJson <<< B.importKey

syncProgress :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
syncProgress = fromAff $ map encodeJson B.syncProgress

testReset :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
testReset = fromAff B.testReset

-- Valid redeem code is base64 encoded 32byte data
-- NOTE: this method handles both base64 and base64url base on rfc4648: see more https://github.com/menelaos/purescript-b64/blob/59e2e9189358a4c8e3eef8662ca281906844e783/src/Data/String/Base64.purs#L182
isValidRedeemCode :: String -> Boolean
isValidRedeemCode code = either (const false) (const $ endsWithEqual && 44 == length code) $ B64.decode code
  where
    -- Because it is 32byte base64 encoded
    endsWithEqual = isJust $ stripSuffix (Pattern "=") code

-- Valid postvend code is base58 encoded 32byte data
isValidPostVendRedeemCode :: String -> Boolean
isValidPostVendRedeemCode code = maybe false (const true) $ B58.decode code


Update MutRec.purs

Update MutRec.purs

-- @shouldFailWith CycleInDeclaration
-- @shouldFailWith CycleInDeclaration
module MutRec where

import Prelude

x = y

y = x


Some more work on lexing

Some more work on lexing

module Language.PureScript.Parser.Lexer where

import Data.Either
import Data.String

import Language.PureScript.Keywords (opCharsString)

data Token
  = LParen
  | RParen
  | LBrace
  | RBrace
  | LAngle
  | RAngle
  | LSquare
  | RSquare

  | LName String
  | UName String
  | Symbol String

  | Indent
  | Dedent

  | LArrow
  | RArrow
  | LFatArrow
  | RFatArrow

  | Colon
  | DoubleColon
  | Equals
  | Pipe
  | Tick
  | Dot
  | Comma

  | StringLiteral String

  | Natural Number
  | Integer Number
  | Float Number
  | Hex Number

instance showToken :: Show Token where
  show LParen                = "LParen"
  show RParen                = "RParen"
  show LBrace                = "LBrace"
  show RBrace                = "RBrace"
  show LAngle                = "LAngle"
  show RAngle                = "RAngle"
  show LSquare               = "LSquare"
  show RSquare               = "RSquare"
  show (LName s)             = "LName (" ++ show s ++ ")"
  show (UName s)             = "UName (" ++ show s ++ ")"
  show (Symbol s)            = "Symbol (" ++ show s ++ ")"
  show Indent                = "Indent"
  show Dedent                = "Dedent"
  show LArrow                = "LArrow"
  show RArrow                = "RArrow"
  show LFatArrow             = "LFatArrow"
  show RFatArrow             = "RFatArrow"
  show Colon                 = "Colon"
  show DoubleColon           = "DoubleColon"
  show Equals                = "Equals"
  show Pipe                  = "Pipe"
  show Tick                  = "Tick"
  show Dot                   = "Dot"
  show Comma                 = "Comma"
  show (StringLiteral s)     = "StringLiteral (" ++ show s ++ ")"
  show (Natural n)           = "Natural (" ++ show n ++ ")"
  show (Integer n)           = "Integer (" ++ show n ++ ")"
  show (Float n)             = "Float (" ++ show n ++ ")"
  show (Hex n)               = "Hex (" ++ show n ++ ")"

type Indentation = Number

type Line = Number
type Column = Number

type Position = Number

foreign import unEscape
  "function unEscape(s) {\
  \  return function (sc) {\
  \    return function (fc) {\
  \      try {\
  \        return sc(JSON.parse('\"' + s + '\"'));\
  \      } catch (ex) {\
  \        return fc;\
  \      }\
  \    };\
  \  };\
  \}" :: forall r. String -> (String -> r) -> r -> r

lex :: String -> Either String [Token]
lex input =
  let wh = eatWhitespace 0 0 []
  in Data.Array.reverse <$> go 1 (wh.next + 1) wh.len wh.next []
  where
  go :: Line -> Column -> Indentation -> Position -> [Token] -> Either String [Token]
  go _    _   _   i ts | i >= length input = Right ts
  go line col ref i ts | charAt i input == " " = go line (col + 1) ref (i + 1) ts
  go line col ref i ts | charAt i input == "\r" = go line (col + 1) ref (i + 1) ts
  go line col ref i ts | charAt i input == "\n" =
    let wh = eatWhitespace (i + 1) ref ts
    in go (line + 1) (wh.len + 1) wh.len wh.next wh.toks

  go line col ref i ts | charAt i input == "(" = go line (col + 1) ref (i + 1) (LParen : ts)
  go line col ref i ts | charAt i input == ")" = go line (col + 1) ref (i + 1) (RParen : ts)
  go line col ref i ts | charAt i input == "{" = go line (col + 1) ref (i + 1) (LBrace : ts)
  go line col ref i ts | charAt i input == "}" = go line (col + 1) ref (i + 1) (RBrace : ts)
  go line col ref i ts | charAt i input == "[" = go line (col + 1) ref (i + 1) (LSquare : ts)
  go line col ref i ts | charAt i input == "]" = go line (col + 1) ref (i + 1) (RSquare : ts)
  go line col ref i ts | charAt i input == "." && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) ref (i + 1) (Dot : ts)
  go line col ref i ts | charAt i input == "<" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) ref (i + 1) (LAngle : ts)
  go line col ref i ts | charAt i input == ">" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) ref (i + 1) (RAngle : ts)
  go line col ref i ts | charAt i input == ":" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) ref (i + 1) (Colon : ts)
  go line col ref i ts | charAt i input == "=" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) ref (i + 1) (Equals : ts)
  go line col ref i ts | charAt i input == "|" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) ref (i + 1) (Pipe : ts)
  go line col ref i ts | charAt i input == "`" = go line (col + 1) ref (i + 1) (Tick : ts)
  go line col ref i ts | charAt i input == "," = go line (col + 1) ref (i + 1) (Comma : ts)

  go line col ref i ts | charAt i input == ":" && charAt (i + 1) input == ":" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) ref (i + 2) (DoubleColon : ts)
  go line col ref i ts | charAt i input == "<" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) ref (i + 2) (LArrow : ts)
  go line col ref i ts | charAt i input == "-" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) ref (i + 2) (RArrow : ts)
  go line col ref i ts | charAt i input == "<" && charAt (i + 1) input == "=" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) ref (i + 2) (LFatArrow : ts)
  go line col ref i ts | charAt i input == "=" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) ref (i + 2) (RFatArrow : ts)

  go line col ref i ts | isNumeric (charAt i input) =
    let ns = eatWhile i isNumeric
    in go line (col + length ns.str) ref ns.next (Natural (buildNat ns.str 0 0) : ts)
    where
    buildNat :: String -> Number -> Number -> Number
    buildNat s i acc | i >= length s = acc
    buildNat s i acc = buildNat s (i + 1) (acc * 10 + toDigit (charAt i s))

    toDigit :: String -> Number
    toDigit "0" = 0
    toDigit "1" = 1
    toDigit "2" = 2
    toDigit "3" = 3
    toDigit "4" = 4
    toDigit "5" = 5
    toDigit "6" = 6
    toDigit "7" = 7
    toDigit "8" = 8
    toDigit "9" = 9

  go line col ref i ts | isIdentStart (charAt i input) =
    let tok = eatWhile i isIdentChar
    in go line (col + length tok.str) ref tok.next (LName tok.str : ts)
  go line col ref i ts | isUpper (charAt i input) =
    let tok = eatWhile i isIdentChar
    in go line (col + length tok.str) ref tok.next (UName tok.str : ts)
  go line col ref i ts | isSymbolChar (charAt i input) =
    let tok = eatWhile i isSymbolChar
    in go line (col + length tok.str) ref tok.next (Symbol tok.str : ts)

  go line col ref i ts | charAt i input == "\"" =
    -- TODO: make this tail recursive
    case readStringLiteral (i + 1) of
      Left err -> Left err
      Right tok -> go line (col + tok.count) ref tok.next (StringLiteral tok.str : ts)

  go line col _ i _ = Left $ "Parse error at line " ++ show line ++ ", column " ++ show col ++ ": " ++ show (take 20 (drop i input))

  eatWhitespace :: Position -> Indentation -> [Token] -> { len :: Number, count :: Number, next :: Position, toks :: [Token] }
  eatWhitespace = eat 0 0
    where
    eat len count i ref ts | charAt i input == " " = eat (len + 1) (count + 1) (i + 1) ref ts
    eat len count i ref ts | charAt i input == "\r" = eat len (count + 1) (i + 1) ref ts
    eat len count i ref ts | len > ref = { len: len, count: count, next: i, toks: Indent : ts }
    eat len count i ref ts | len < ref = { len: len, count: count, next: i, toks: Dedent : ts }
    eat len count i _   ts = { len: len, count: count, next: i, toks: ts }

  eatWhile :: Position -> (String -> Boolean) -> { next :: Position, str :: String }
  eatWhile start p = eat start 0
    where
    eat i _   | i >= length input = { next: i, str: drop start input }
    eat i len | p (charAt i input) = eat (i + 1) (len + 1)
    eat i len = { next: i, str: take len (drop start input) }

  readStringLiteral :: Position -> Either String { next :: Position, str :: String, count :: Number }
  readStringLiteral start = eat false 0 start
    where
    eat :: Boolean -> Number -> Position -> Either String { next :: Position, str :: String, count :: Number }
    eat _     _     i | i >= length input = Left $ "Unterminated string literal"
    eat false count i | charAt i input == "\"" =
      let escaped = take count (drop start input)
      in unEscape escaped (\s -> Right { next: i + 1, str: s, count: count }) (Left $ "Invalid string literal: " ++ show escaped)
    eat _     count i | charAt i input == "\\" = eat true (count + 1) (i + 1)
    eat _     count i = eat false (count + 1) (i + 1)

  lookaheadChar :: Position -> (String -> Boolean) -> Boolean
  lookaheadChar i pred = pred (charAt i input)

  isSymbolChar :: String -> Boolean
  isSymbolChar c = indexOf c opCharsString >= 0

  isLower :: String -> Boolean
  isLower c = c >= "a" && c <= "z"

  isUpper :: String -> Boolean
  isUpper c = c >= "A" && c <= "Z"

  isAlpha :: String -> Boolean
  isAlpha c = isLower c || isUpper c

  isNumeric :: String -> Boolean
  isNumeric c = c >= "0" && c <= "9"

  isAlphaNum :: String -> Boolean
  isAlphaNum c = isAlpha c || isNumeric c

  isIdentStart :: String -> Boolean
  isIdentStart c = isLower c || (c == "_")

  isIdentChar :: String -> Boolean
  isIdentChar c = isAlphaNum c || (c == "_")

  isNumericLiteralChar :: String -> Boolean
  isNumericLiteralChar c = isNumeric c || (c == ".") || (c == "b") || (c == "x") || (c == "-")

module Language.PureScript.Parser.Lexer where

import Data.Either
import Data.String

import Language.PureScript.Keywords (opCharsString)

data Token
  = LParen
  | RParen
  | LBrace
  | RBrace
  | LAngle
  | RAngle
  | LSquare
  | RSquare

  | LName String
  | UName String
  | Symbol String

  | Indent
  | Dedent

  | LArrow
  | RArrow
  | LFatArrow
  | RFatArrow

  | Colon
  | DoubleColon
  | Equals
  | Pipe
  | Tick

  | StringLiteral String
  | NumericLiteral Number

instance showToken :: Show Token where
  show LParen                = "LParen"
  show RParen                = "RParen"
  show LBrace                = "LBrace"
  show RBrace                = "RBrace"
  show LAngle                = "LAngle"
  show RAngle                = "RAngle"
  show LSquare               = "LSquare"
  show RSquare               = "RSquare"
  show (LName s)             = "LName (" ++ show s ++ ")"
  show (UName s)             = "UName (" ++ show s ++ ")"
  show (Symbol s)            = "Symbol (" ++ show s ++ ")"
  show Indent                = "Indent"
  show Dedent                = "Dedent"
  show LArrow                = "LArrow"
  show RArrow                = "RArrow"
  show LFatArrow             = "LFatArrow"
  show RFatArrow             = "RFatArrow"
  show Colon                 = "Colon"
  show Equals                = "Equals"
  show Pipe                  = "Pipe"
  show Tick                  = "Tick"
  show (StringLiteral s)     = "StringLiteral (" ++ show s ++ ")"

type Indentation = Number

type Position = Number

foreign import unEscape
  "function unEscape(s) {\
  \  return function (sc) {\
  \    return function (fc) {\
  \      try {\
  \        return sc(JSON.parse('\"' + s + '\"'));\
  \      } catch (ex) {\
  \        return fc;\
  \      }\
  \    };\
  \  };\
  \}" :: forall r. String -> (String -> r) -> r -> r

lex :: String -> Either String [Token]
lex input =
  let wh = eatWhitespace 0 0 []
  in Data.Array.reverse <$> go wh.len wh.next []
  where
  go :: Indentation -> Position -> [Token] -> Either String [Token]
  go _ i ts | i >= length input = Right ts
  go ref i ts | charAt i input == " " = go ref (i + 1) ts
  go ref i ts | charAt i input == "\r" = go ref (i + 1) ts
  go ref i ts | charAt i input == "\n" =
    let wh = eatWhitespace (i + 1) ref ts
    in go wh.len wh.next wh.toks

  go ref i ts | charAt i input == "(" = go ref (i + 1) (LParen : ts)
  go ref i ts | charAt i input == ")" = go ref (i + 1) (RParen : ts)
  go ref i ts | charAt i input == "{" = go ref (i + 1) (LBrace : ts)
  go ref i ts | charAt i input == "}" = go ref (i + 1) (RBrace : ts)
  go ref i ts | charAt i input == "[" = go ref (i + 1) (LSquare : ts)
  go ref i ts | charAt i input == "]" = go ref (i + 1) (RSquare : ts)
  go ref i ts | charAt i input == "<" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go ref (i + 1) (LAngle : ts)
  go ref i ts | charAt i input == ">" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go ref (i + 1) (RAngle : ts)
  go ref i ts | charAt i input == ":" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go ref (i + 1) (Colon : ts)
  go ref i ts | charAt i input == "=" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go ref (i + 1) (Equals : ts)
  go ref i ts | charAt i input == "|" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go ref (i + 1) (Pipe : ts)
  go ref i ts | charAt i input == "`" = go ref (i + 1) (Tick : ts)

  go ref i ts | charAt i input == "<" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go ref (i + 2) (LArrow : ts)
  go ref i ts | charAt i input == "-" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go ref (i + 2) (RArrow : ts)
  go ref i ts | charAt i input == "<" && charAt (i + 1) input == "=" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go ref (i + 2) (LFatArrow : ts)
  go ref i ts | charAt i input == "=" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go ref (i + 2) (RFatArrow : ts)

  go ref i ts | isIdentStart (charAt i input) =
    let tok = eatWhile i isIdentChar
    in go ref tok.next (LName tok.str : ts)
  go ref i ts | isUpper (charAt i input) =
    let tok = eatWhile i isIdentChar
    in go ref tok.next (UName tok.str : ts)
  go ref i ts | isSymbolChar (charAt i input) =
    let tok = eatWhile i isSymbolChar
    in go ref tok.next (Symbol tok.str : ts)

  go ref i ts | charAt i input == "\"" =
    -- TODO: make this tail recursive
    case readStringLiteral (i + 1) of
      Left err -> Left err
      Right tok -> go ref tok.next (StringLiteral tok.str : ts)

  go _ i _ = Left $ "Parse error at location " ++ show i ++ ": " ++ show (take 20 (drop i input))

  eatWhitespace :: Position -> Indentation -> [Token] -> { len :: Number, count :: Number, next :: Position, toks :: [Token] }
  eatWhitespace = eat 0 0
    where
    eat len count i ref ts | charAt i input == " " = eat (len + 1) (count + 1) (i + 1) ref ts
    eat len count i ref ts | charAt i input == "\r" = eat len (count + 1) (i + 1) ref ts
    eat len count i ref ts | len > ref = { len: len, count: count, next: i, toks: Indent : ts }
    eat len count i ref ts | len < ref = { len: len, count: count, next: i, toks: Dedent : ts }
    eat len count i _   ts = { len: len, count: count, next: i, toks: ts }

  eatWhile :: Position -> (String -> Boolean) -> { next :: Position, str :: String }
  eatWhile start p = eat start 0
    where
    eat i _   | i >= length input = { next: i, str: drop start input }
    eat i len | p (charAt i input) = eat (i + 1) (len + 1)
    eat i len = { next: i, str: take len (drop start input) }

  readStringLiteral :: Position -> Either String { next :: Position, str :: String }
  readStringLiteral start = eat false 0 start
    where
    eat :: Boolean -> Number -> Position -> Either String { next :: Position, str :: String }
    eat _      _    i | i >= length input = Left $ "Unterminated string literal" ++ show i
    eat false count i | charAt i input == "\"" =
      let escaped = take count (drop start input)
      in unEscape escaped (\s -> Right { next: i + 1, str: s }) (Left $ "Invalid string literal: " ++ show escaped)
    eat _     count i | charAt i input == "\\" = eat true (count + 1) (i + 1)
    eat _     count i = eat false (count + 1) (i + 1)

  lookaheadChar :: Position -> (String -> Boolean) -> Boolean
  lookaheadChar i pred = pred (charAt i input)

  isSymbolChar :: String -> Boolean
  isSymbolChar c = indexOf c opCharsString >= 0

  isLower :: String -> Boolean
  isLower c = c >= "a" && c <= "z"

  isUpper :: String -> Boolean
  isUpper c = c >= "A" && c <= "Z"

  isAlpha :: String -> Boolean
  isAlpha c = isLower c || isUpper c

  isNumeric :: String -> Boolean
  isNumeric c = c >= "0" && c <= "9"

  isAlphaNum :: String -> Boolean
  isAlphaNum c = isAlpha c || isNumeric c

  isIdentStart :: String -> Boolean
  isIdentStart c = isLower c || (c == "_")

  isIdentChar :: String -> Boolean
  isIdentChar c = isAlphaNum c || (c == "_")


Fix port for markdown (#1353)

Fix port for markdown (#1353)

{-
Copyright 2016 SlamData, Inc.
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Markdown.Eval
  ( evalMarkdown
  , evalMarkdownForm
  ) where

import SlamData.Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Throw (class MonadThrow)
import Control.Monad.Writer.Class (class MonadTell)

import Data.Array as A
import Data.Identity (Identity)
import Data.Int as Int
import Data.JSDate as JSD
import Data.Json.Extended as EJSON
import Data.List as L
import Data.String as S
import Data.StrMap as SM

import SlamData.Effects (SlamDataEffects)
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Query as Quasar
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Markdown.Component.State.Core as MDS
import SlamData.Workspace.Card.Markdown.Model as MD
import SlamData.Workspace.Card.Port as Port

import Text.Markdown.SlamDown as SD
import Text.Markdown.SlamDown.Traverse as SDT
import Text.Markdown.SlamDown.Eval as SDE
import Text.Markdown.SlamDown.Parser as SDP
import Text.Markdown.SlamDown.Halogen.Component.State as SDH

import Text.Parsing.Parser as P
import Text.Parsing.Parser.Combinators as PC
import Text.Parsing.Parser.String as PS

import Utils.Path (DirPath)

evalMarkdownForm
  ∷ ∀ m
  . ( MonadEff SlamDataEffects m
    , Monad m
    )
  ⇒ MD.Model
  → SD.SlamDownP Port.VarMapValue
  → Port.DataMap
  → m Port.Out
evalMarkdownForm model doc varMap = do
  let inputState = SDH.formStateFromDocument doc
  thisVarMap ← liftEff $ MDS.formStateToVarMap inputState model.state
  pure (Port.Variables × map Right thisVarMap `SM.union` varMap)

evalMarkdown
  ∷ ∀ m
  . ( MonadEff SlamDataEffects m
    , MonadAsk CEM.CardEnv m
    , MonadThrow CEM.CardError m
    , MonadTell CEM.CardLog m
    , QuasarDSL m
    )
  ⇒ String
  → Port.DataMap
  → m Port.Out
evalMarkdown str varMap = do
  CEM.CardEnv { path } ← ask
  case SDP.parseMd str of
    Left e → CEM.throw e
    Right sd → do
      let sm = Port.renderVarMapValue <$> Port.flattenResources varMap
      doc ← evalEmbeddedQueries sm path sd
      pure (Port.SlamDown doc × varMap)

findFields
  ∷ ∀ a
  . SD.SlamDownP a
  → Array String
findFields = SDT.everything (const mempty) extractField
  where
  extractField ∷ SD.Inline a → Array String
  extractField (SD.FormField label _ _) = pure label
  extractField _ = mempty

evalEmbeddedQueries
  ∷ ∀ m
  . ( MonadEff SlamDataEffects m
    , MonadThrow CEM.CardError m
    , MonadTell CEM.CardLog m
    , QuasarDSL m
    )
  ⇒ SM.StrMap String
  → DirPath
  → SD.SlamDownP Port.VarMapValue
  → m (SD.SlamDownP Port.VarMapValue)
evalEmbeddedQueries sm dir =
  SDE.eval
    { code: evalCode
    , textBox: evalTextBox
    , value: evalValue
    , list: evalList
    }

  where

  evalCode
    ∷ Maybe SDE.LanguageId
    → String
    → m Port.VarMapValue
  evalCode mid code
    | languageIsSql mid =
        Port.Literal ∘ extractCodeValue <$> runQuery code
    | otherwise =
        pure $ Port.QueryExpr code

  extractCodeValue ∷ Array EJSON.EJson → EJSON.EJson
  extractCodeValue [ej] = extractSingletonObject ej
  extractCodeValue arr = EJSON.array arr

  languageIsSql
    ∷ Maybe SDE.LanguageId
    → Boolean
  languageIsSql =
    maybe
      true
      ((_ ≡ "sql") ∘ S.toLower)

  extractSingletonObject
    ∷ EJSON.EJson
    → EJSON.EJson
  extractSingletonObject lit =
    case EJSON.unroll lit of
      EJSON.Map [key × val] → val
      _ → lit

  evalValue
    ∷ String
    → m Port.VarMapValue
  evalValue code = do
    maybe (Port.Literal EJSON.null) (Port.Literal ∘ extractSingletonObject)
      ∘ A.head
      <$> runQuery code

  evalTextBox
    ∷ SD.TextBox (Const String)
    → m (SD.TextBox Identity)
  evalTextBox tb = do
    let sql = unwrap $ SD.traverseTextBox (map \_ → Const unit) tb
    mresult ← A.head <$> runQuery sql
    result ←
      maybe (CEM.throw "No results") (pure ∘ extractSingletonObject) mresult
    case tb × (EJSON.unroll result) of
      (SD.PlainText _) × (EJSON.String str) →
        pure ∘ SD.PlainText $ pure str
      (SD.Numeric _) × (EJSON.Decimal a) →
        pure ∘ SD.Numeric $ pure a
      (SD.Time prec _) × (EJSON.Time str) →
        SD.Time prec ∘ pure <$> parse parseSqlTime str
      (SD.Date _) × (EJSON.Date str) →
        SD.Date ∘ pure <$> parse parseSqlDate str
      (SD.DateTime prec _) × (EJSON.Timestamp str) → do
        liftEff (parseSqlTimeStamp str) >>=
          case _ of
            Left msg → CEM.throw msg
            Right dt → pure $ SD.DateTime prec (pure dt)
      _ → CEM.throw $ "Type error: " ⊕ show result ⊕ " does not match " ⊕ show tb
    where
      parse ∷ ∀ s a. P.Parser s a → s → m a
      parse p str =
        case P.runParser str p of
          Left err → CEM.throw $ "Parse error: " ⊕ show err
          Right a → pure a

  evalList
    ∷ String
    → m (L.List Port.VarMapValue)
  evalList code = do
    items ← map extractSingletonObject <$> runQuery code
    let limit = 500
    pure ∘ L.fromFoldable
      $ if A.length items > limit
          then
          map Port.Literal
            (A.take limit items)
            ⊕ [ SD.stringValue $ "<" ⊕ show limit ⊕ "item limit reached>" ]
          else
          Port.Literal <$> items

  runQuery
    ∷ String
    → m (Array EJSON.EJson)
  runQuery code = do
    {inputs} ← CEM.liftQ $ Quasar.compile (Left dir) code sm
    CEM.addSources inputs
    CEM.liftQ $ Quasar.queryEJsonVM dir code sm

parseDigit ∷ P.Parser String Int
parseDigit =
  PC.choice
    [ 0 <$ PS.string "0"
    , 1 <$ PS.string "1"
    , 2 <$ PS.string "2"
    , 3 <$ PS.string "3"
    , 4 <$ PS.string "4"
    , 5 <$ PS.string "5"
    , 6 <$ PS.string "6"
    , 7 <$ PS.string "7"
    , 8 <$ PS.string "8"
    , 9 <$ PS.string "9"
    ]

many1
  ∷ ∀ s a
  . P.Parser s a
  → P.Parser s (L.List a)
many1 p =
  L.Cons
    <$> p
    <*> L.many p

parseNat ∷ P.Parser String Int
parseNat =
  many1 parseDigit
    <#> foldl (\a i → a * 10 + i) 0

hyphen ∷ P.Parser String Unit
hyphen = void $ PS.string "-"

colon ∷ P.Parser String Unit
colon = void $ PS.string ":"

parseSqlDate ∷ P.Parser String SD.DateValue
parseSqlDate = do
  year ← parseNat
  hyphen
  month ← parseNat
  hyphen
  day ← parseNat
  pure { year, month, day }

parseSqlTime ∷ P.Parser String SD.TimeValue
parseSqlTime = do
  hours ← parseNat
  colon
  minutes ← parseNat
  colon
  seconds ← Just <$> parseNat
  pure { hours, minutes, seconds }

-- | Parses a date-time string into the user's current locale.
parseSqlTimeStamp
  ∷ ∀ eff
  . String
  → Eff (locale :: JSD.LOCALE | eff) (Either String SD.DateTimeValue)
parseSqlTimeStamp str = do
  d <- JSD.parse str
  case JSD.isValid d of
    false → pure $ Left $ "Invalid date: " ⊕ show str
    true → do
      year ← Int.round <$> JSD.getFullYear d
      month ← (_ + 1) ∘ Int.round <$> JSD.getMonth d
      day ← Int.round <$> JSD.getDate d
      hours ← Int.round <$> JSD.getHours d
      minutes ← Int.round <$> JSD.getMinutes d
      seconds ← Just ∘ Int.round <$> JSD.getSeconds d
      pure $ Right
        { date: { year , month , day }
        , time: { hours , minutes, seconds }
        }

{-
Copyright 2016 SlamData, Inc.
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Markdown.Eval
  ( evalMarkdown
  , evalMarkdownForm
  ) where

import SlamData.Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Throw (class MonadThrow)
import Control.Monad.Writer.Class (class MonadTell)

import Data.Array as A
import Data.Identity (Identity)
import Data.Int as Int
import Data.JSDate as JSD
import Data.Json.Extended as EJSON
import Data.List as L
import Data.String as S
import Data.StrMap as SM

import SlamData.Effects (SlamDataEffects)
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Query as Quasar
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Markdown.Component.State.Core as MDS
import SlamData.Workspace.Card.Markdown.Model as MD
import SlamData.Workspace.Card.Port as Port

import Text.Markdown.SlamDown as SD
import Text.Markdown.SlamDown.Traverse as SDT
import Text.Markdown.SlamDown.Eval as SDE
import Text.Markdown.SlamDown.Parser as SDP
import Text.Markdown.SlamDown.Halogen.Component.State as SDH

import Text.Parsing.Parser as P
import Text.Parsing.Parser.Combinators as PC
import Text.Parsing.Parser.String as PS

import Utils.Path (DirPath)

evalMarkdownForm
  ∷ ∀ m
  . ( MonadEff SlamDataEffects m
    , Monad m
    )
  ⇒ MD.Model
  → SD.SlamDownP Port.VarMapValue
  → Port.DataMap
  → m Port.Out
evalMarkdownForm model doc varMap = do
  let inputState = SDH.formStateFromDocument doc
  thisVarMap ← liftEff $ MDS.formStateToVarMap inputState model.state
  pure (Port.Initial × map Right thisVarMap `SM.union` varMap)

evalMarkdown
  ∷ ∀ m
  . ( MonadEff SlamDataEffects m
    , MonadAsk CEM.CardEnv m
    , MonadThrow CEM.CardError m
    , MonadTell CEM.CardLog m
    , QuasarDSL m
    )
  ⇒ String
  → Port.DataMap
  → m Port.Out
evalMarkdown str varMap = do
  CEM.CardEnv { path } ← ask
  case SDP.parseMd str of
    Left e → CEM.throw e
    Right sd → do
      let sm = Port.renderVarMapValue <$> Port.flattenResources varMap
      doc ← evalEmbeddedQueries sm path sd
      pure (Port.SlamDown doc × varMap)

findFields
  ∷ ∀ a
  . SD.SlamDownP a
  → Array String
findFields = SDT.everything (const mempty) extractField
  where
  extractField ∷ SD.Inline a → Array String
  extractField (SD.FormField label _ _) = pure label
  extractField _ = mempty

evalEmbeddedQueries
  ∷ ∀ m
  . ( MonadEff SlamDataEffects m
    , MonadThrow CEM.CardError m
    , MonadTell CEM.CardLog m
    , QuasarDSL m
    )
  ⇒ SM.StrMap String
  → DirPath
  → SD.SlamDownP Port.VarMapValue
  → m (SD.SlamDownP Port.VarMapValue)
evalEmbeddedQueries sm dir =
  SDE.eval
    { code: evalCode
    , textBox: evalTextBox
    , value: evalValue
    , list: evalList
    }

  where

  evalCode
    ∷ Maybe SDE.LanguageId
    → String
    → m Port.VarMapValue
  evalCode mid code
    | languageIsSql mid =
        Port.Literal ∘ extractCodeValue <$> runQuery code
    | otherwise =
        pure $ Port.QueryExpr code

  extractCodeValue ∷ Array EJSON.EJson → EJSON.EJson
  extractCodeValue [ej] = extractSingletonObject ej
  extractCodeValue arr = EJSON.array arr

  languageIsSql
    ∷ Maybe SDE.LanguageId
    → Boolean
  languageIsSql =
    maybe
      true
      ((_ ≡ "sql") ∘ S.toLower)

  extractSingletonObject
    ∷ EJSON.EJson
    → EJSON.EJson
  extractSingletonObject lit =
    case EJSON.unroll lit of
      EJSON.Map [key × val] → val
      _ → lit

  evalValue
    ∷ String
    → m Port.VarMapValue
  evalValue code = do
    maybe (Port.Literal EJSON.null) (Port.Literal ∘ extractSingletonObject)
      ∘ A.head
      <$> runQuery code

  evalTextBox
    ∷ SD.TextBox (Const String)
    → m (SD.TextBox Identity)
  evalTextBox tb = do
    let sql = unwrap $ SD.traverseTextBox (map \_ → Const unit) tb
    mresult ← A.head <$> runQuery sql
    result ←
      maybe (CEM.throw "No results") (pure ∘ extractSingletonObject) mresult
    case tb × (EJSON.unroll result) of
      (SD.PlainText _) × (EJSON.String str) →
        pure ∘ SD.PlainText $ pure str
      (SD.Numeric _) × (EJSON.Decimal a) →
        pure ∘ SD.Numeric $ pure a
      (SD.Time prec _) × (EJSON.Time str) →
        SD.Time prec ∘ pure <$> parse parseSqlTime str
      (SD.Date _) × (EJSON.Date str) →
        SD.Date ∘ pure <$> parse parseSqlDate str
      (SD.DateTime prec _) × (EJSON.Timestamp str) → do
        liftEff (parseSqlTimeStamp str) >>=
          case _ of
            Left msg → CEM.throw msg
            Right dt → pure $ SD.DateTime prec (pure dt)
      _ → CEM.throw $ "Type error: " ⊕ show result ⊕ " does not match " ⊕ show tb
    where
      parse ∷ ∀ s a. P.Parser s a → s → m a
      parse p str =
        case P.runParser str p of
          Left err → CEM.throw $ "Parse error: " ⊕ show err
          Right a → pure a

  evalList
    ∷ String
    → m (L.List Port.VarMapValue)
  evalList code = do
    items ← map extractSingletonObject <$> runQuery code
    let limit = 500
    pure ∘ L.fromFoldable
      $ if A.length items > limit
          then
          map Port.Literal
            (A.take limit items)
            ⊕ [ SD.stringValue $ "<" ⊕ show limit ⊕ "item limit reached>" ]
          else
          Port.Literal <$> items

  runQuery
    ∷ String
    → m (Array EJSON.EJson)
  runQuery code = do
    {inputs} ← CEM.liftQ $ Quasar.compile (Left dir) code sm
    CEM.addSources inputs
    CEM.liftQ $ Quasar.queryEJsonVM dir code sm

parseDigit ∷ P.Parser String Int
parseDigit =
  PC.choice
    [ 0 <$ PS.string "0"
    , 1 <$ PS.string "1"
    , 2 <$ PS.string "2"
    , 3 <$ PS.string "3"
    , 4 <$ PS.string "4"
    , 5 <$ PS.string "5"
    , 6 <$ PS.string "6"
    , 7 <$ PS.string "7"
    , 8 <$ PS.string "8"
    , 9 <$ PS.string "9"
    ]

many1
  ∷ ∀ s a
  . P.Parser s a
  → P.Parser s (L.List a)
many1 p =
  L.Cons
    <$> p
    <*> L.many p

parseNat ∷ P.Parser String Int
parseNat =
  many1 parseDigit
    <#> foldl (\a i → a * 10 + i) 0

hyphen ∷ P.Parser String Unit
hyphen = void $ PS.string "-"

colon ∷ P.Parser String Unit
colon = void $ PS.string ":"

parseSqlDate ∷ P.Parser String SD.DateValue
parseSqlDate = do
  year ← parseNat
  hyphen
  month ← parseNat
  hyphen
  day ← parseNat
  pure { year, month, day }

parseSqlTime ∷ P.Parser String SD.TimeValue
parseSqlTime = do
  hours ← parseNat
  colon
  minutes ← parseNat
  colon
  seconds ← Just <$> parseNat
  pure { hours, minutes, seconds }

-- | Parses a date-time string into the user's current locale.
parseSqlTimeStamp
  ∷ ∀ eff
  . String
  → Eff (locale :: JSD.LOCALE | eff) (Either String SD.DateTimeValue)
parseSqlTimeStamp str = do
  d <- JSD.parse str
  case JSD.isValid d of
    false → pure $ Left $ "Invalid date: " ⊕ show str
    true → do
      year ← Int.round <$> JSD.getFullYear d
      month ← (_ + 1) ∘ Int.round <$> JSD.getMonth d
      day ← Int.round <$> JSD.getDate d
      hours ← Int.round <$> JSD.getHours d
      minutes ← Int.round <$> JSD.getMinutes d
      seconds ← Just ∘ Int.round <$> JSD.getSeconds d
      pure $ Right
        { date: { year , month , day }
        , time: { hours , minutes, seconds }
        }