remove warning

remove warning

module Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import D3.Base (D3)
import D3.Transition (D3Transition(TransitionName), TimeSpec(MilliSec, DelayFn))
import Data.Int (toNumber)
import Data.List (List)
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty)
import Prelude (Unit, bind, discard, show, ($), (*), (/))
import TaglessD3.API (D3Data(ArrayDI, ArrayD), append, applyTransition, attrs, d3Select, dataBind, enter, makeTransition, selectAll, tAttrs, tDelay, tDuration)
import TaglessD3.AttrNew (Attr(..), AttrSetter, CssUnit(..), attrFunction, attrValue, attributes)
import TaglessD3.Base (D3ElementType(..))
import TaglessD3.D3Impl (runD3Monad, D3Script)
import TaglessD3.StringImpl (runStructure) as S

circles_script :: D3Script
circles_script = do
    d3Select "#chart"
    append SvgGroup
    selectAll "circle" -- this select, the databind, the enter and the append could surely all be one function?
    dataBind myData'
    enter
    append SvgCircle
    attrs circleAttrs
    applyTransition $ myTransition
    tDelay $ DelayFn (\d i -> i * 100.0)
    tDuration $ DelayFn (\d i -> i * 1000.0)
    tAttrs circleTransitionAttrs

rects_script :: D3Script
rects_script = do
    d3Select "#chart"
    append SvgGroup
    selectAll "rect" -- this select, the databind, the enter and the append could surely all be one function?
    dataBind myData'
    enter
    append SvgRect
    attrs rectAttrs
    applyTransition $ myTransition
    tDelay $ DelayFn (\d i -> i * 100.0)
    tDuration $ DelayFn (\d i -> i * 1000.0)
    tAttrs rectTransitionAttrs

-- idempotency of d3.transtion() this next relies on D3 to return us the same
-- transition as "name" (ie if named transition exists) allowing us to call this
-- function multiple times from different scripts that are under interpretation

-- now, if we want to add (common) attributes to this transition definition
-- we'll have to check if it already exists and not apply those attributes for
-- existing transitions
myTransition :: D3Script
myTransition = do
    makeTransition $ TransitionName "foo"
    tDelay $ MilliSec 2000.0

circleTransitionAttrs :: List Attr
circleTransitionAttrs = attributes $ [ Style "fill" $ attrValue "red" NoUnit
                                  , CY $ attrFunction (\d _ _ _ -> d * 80) Px
                                  ]

rectTransitionAttrs :: List Attr
rectTransitionAttrs = attributes $ [ Style "fill" $ attrValue "blue" NoUnit
                                  , X $ attrFunction (\d _ _ _ -> d * 80) Px
                                  ]

myData :: forall t8. D3Data Int t8
myData       = ArrayD [1,2,3,4,5]

myData' :: D3Data Int Number
myData'      = ArrayDI [1,2,3,4,5,6,7,8] (\i -> (toNumber i) / 2.0) -- array data with lambda index fn

rectAttrs :: List Attr
rectAttrs = attributes $ [ Y $ attrValue 100 Px
                         , X $ attrFunction (\d _ _ _ -> d * 30) Px
                         , Width  $ attrFunction calcRadius Px
                         , Height  $ attrFunction calcRadius Px]

circleAttrs :: List Attr
circleAttrs = attributes $ [ CX $ attrValue 200 Px
                        , CY $ attrFunction (\d _ _ _ -> d * 3) Px
                        , R  $ attrFunction calcRadius Px
                        , Style "width" $ attrValue 48 Percent
                        , Style "height" $ attrFunction lp Px ] -- shows callback but also demos lack of typecheck on selection...

calcRadius :: AttrSetter Int Int
calcRadius d i n e = d * 5

-- an example of a typed callback function
type ExData = { name :: String, age :: Int }

-- lp :: ExData -> Number -> Array D3Element -> D3Element -> Int
lp :: AttrSetter ExData Int
lp { name, age } _ _ _ =
    case name, age of -- silly little function just shows one way you might use an index function (NB in many cases D3 has better solutions for grouping)
    "awn", _ -> 20
    _, 0     -> 50
    _, _     -> 100

main :: forall e. Eff (console :: CONSOLE, d3 :: D3 | e) Unit
main = do
    _ <- runD3Monad circles_script Nothing
    _ <- runD3Monad rects_script Nothing
    log "\n\n\n====== cool beans =======\n\n\n"
    let ss = show $ S.runStructure circles_script mempty
    log ss

module Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import D3.Base (D3)
import D3.Transition (D3Transition(TransitionName), TimeSpec(..), tStyle)
import Data.Int (toNumber)
import Data.List (List)
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty)
import Prelude (Unit, bind, discard, show, ($), (*), (/))
import TaglessD3.API (D3Data(ArrayDI, ArrayD), append, applyTransition, attrs, d3Select, dataBind, enter, makeTransition, selectAll, tAttrs, tDelay, tDuration)
import TaglessD3.AttrNew (Attr(..), AttrSetter, CssUnit(..), attrFunction, attrValue, attributes)
import TaglessD3.Base (D3ElementType(..))
import TaglessD3.D3Impl (runD3Monad, D3Script)
import TaglessD3.StringImpl (runStructure) as S

circles_script :: D3Script
circles_script = do
    d3Select "#chart"
    append SvgGroup
    selectAll "circle" -- this select, the databind, the enter and the append could surely all be one function?
    dataBind myData'
    enter
    append SvgCircle
    attrs circleAttrs
    applyTransition $ myTransition
    tDelay $ DelayFn (\d i -> i * 100.0)
    tDuration $ DelayFn (\d i -> i * 1000.0)
    tAttrs circleTransitionAttrs

rects_script :: D3Script
rects_script = do
    d3Select "#chart"
    append SvgGroup
    selectAll "rect" -- this select, the databind, the enter and the append could surely all be one function?
    dataBind myData'
    enter
    append SvgRect
    attrs rectAttrs
    applyTransition $ myTransition
    tDelay $ DelayFn (\d i -> i * 100.0)
    tDuration $ DelayFn (\d i -> i * 1000.0)
    tAttrs rectTransitionAttrs

-- idempotency of d3.transtion() this next relies on D3 to return us the same
-- transition as "name" (ie if named transition exists) allowing us to call this
-- function multiple times from different scripts that are under interpretation

-- now, if we want to add (common) attributes to this transition definition
-- we'll have to check if it already exists and not apply those attributes for
-- existing transitions
myTransition :: D3Script
myTransition = do
    makeTransition $ TransitionName "foo"
    tDelay $ MilliSec 2000.0

circleTransitionAttrs :: List Attr
circleTransitionAttrs = attributes $ [ Style "fill" $ attrValue "red" NoUnit
                                  , CY $ attrFunction (\d _ _ _ -> d * 80) Px
                                  ]

rectTransitionAttrs :: List Attr
rectTransitionAttrs = attributes $ [ Style "fill" $ attrValue "blue" NoUnit
                                  , X $ attrFunction (\d _ _ _ -> d * 80) Px
                                  ]

myData :: forall t8. D3Data Int t8
myData       = ArrayD [1,2,3,4,5]

myData' :: D3Data Int Number
myData'      = ArrayDI [1,2,3,4,5,6,7,8] (\i -> (toNumber i) / 2.0) -- array data with lambda index fn

rectAttrs :: List Attr
rectAttrs = attributes $ [ Y $ attrValue 100 Px
                         , X $ attrFunction (\d _ _ _ -> d * 30) Px
                         , Width  $ attrFunction calcRadius Px
                         , Height  $ attrFunction calcRadius Px]

circleAttrs :: List Attr
circleAttrs = attributes $ [ CX $ attrValue 200 Px
                        , CY $ attrFunction (\d _ _ _ -> d * 3) Px
                        , R  $ attrFunction calcRadius Px
                        , Style "width" $ attrValue 48 Percent
                        , Style "height" $ attrFunction lp Px ] -- shows callback but also demos lack of typecheck on selection...

calcRadius :: AttrSetter Int Int
calcRadius d i n e = d * 5

-- an example of a typed callback function
type ExData = { name :: String, age :: Int }

-- lp :: ExData -> Number -> Array D3Element -> D3Element -> Int
lp :: AttrSetter ExData Int
lp { name, age } _ _ _ =
    case name, age of -- silly little function just shows one way you might use an index function (NB in many cases D3 has better solutions for grouping)
    "awn", _ -> 20
    _, 0     -> 50
    _, _     -> 100

main :: forall e. Eff (console :: CONSOLE, d3 :: D3 | e) Unit
main = do
    _ <- runD3Monad circles_script Nothing
    _ <- runD3Monad rects_script Nothing
    log "\n\n\n====== cool beans =======\n\n\n"
    let ss = show $ S.runStructure circles_script mempty
    log ss


[CSM-113] fixed  REST api calls, using  to separate URL resources.

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, Error)
import Control.Monad.Error.Class (throwError)
import Daedalus.Constants (backendPrefix)
import Daedalus.Types (CAddress, Coin, _address, _coin, CWallet, CTx, CWalletMeta, CTxId, CTxMeta, _ctxIdValue, CCurrency, WalletError, showCCurrency, CProfile, CWalletInit, BackupPhrase, CUpdateInfo, SoftwareVersion, CWalletRedeem, SyncProgress)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(POST, PUT, DELETE))
import Data.Maybe (Maybe(Just))
import Data.MediaType.Common (applicationJSON)
import Data.String (joinWith)
import Data.Tuple (Tuple)
import Network.HTTP.Affjax (AffjaxResponse, affjax, defaultRequest, AJAX, URL, AffjaxRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.RequestHeader (RequestHeader(ContentType))
import Network.HTTP.StatusCode (StatusCode(..))

-- HELPERS

type URLPath = Array String

mkUrl :: URLPath -> URL
mkUrl = joinWith "/"

backendApi :: URLPath -> URL
backendApi path = mkUrl $ [backendPrefix, "api"] <> path

data ApiError
    = HTTPStatusError (AffjaxResponse Json)
    | JSONDecodingError String
    | ServerError WalletError

instance showApiError :: Show ApiError where
    show (HTTPStatusError res) =
        "HTTPStatusError: " <> show res.status <> " msg: " <> show res.response
    show (JSONDecodingError e) =
        "JSONDecodingError: " <> show e
    show (ServerError e) =
        "ServerError: " <> gShow e

-- REQUESTS HELPERS

decodeResult :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResult = either (Left <<< mkJSONError) (bimap mkServerError id) <<< decodeJson <<< _.response
  where
    mkJSONError = error <<< show <<< JSONDecodingError
    mkServerError = error <<< show <<< ServerError

makeRequest :: forall eff a r. (Generic a, Requestable r) => AffjaxRequest r -> URLPath -> Aff (ajax :: AJAX | eff) a
makeRequest request urlPath = do
    res <- affjax $ request { url = backendApi urlPath }
    when (isHttpError res.status) $
        throwError <<< error <<< show $ HTTPStatusError res
    either throwError pure $ decodeResult res
  where
    isHttpError (StatusCode c) = c >= 400

getR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
getR = makeRequest defaultRequest

postR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
postR = makeRequest $ defaultRequest { method = Left POST }

postRBody :: forall eff a b. (Generic a, Generic b) => URLPath -> b -> Aff (ajax :: AJAX | eff) a
postRBody urlPath content = flip makeRequest urlPath $
    defaultRequest { method = Left POST
                   , content = Just <<< show $ encodeJson content
                   , headers = [ContentType applicationJSON]
                   }

putRBody :: forall eff a b. (Generic a, Generic b) => URLPath -> b -> Aff (ajax :: AJAX | eff) a
putRBody urlPath content = flip makeRequest urlPath $
    defaultRequest { method = Left PUT
                   , content = Just <<< show $ encodeJson content
                   , headers = [ContentType applicationJSON]
                   }

deleteR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
deleteR = makeRequest $ defaultRequest { method = Left DELETE }

-- REQUESTS
--------------------------------------------------------------------------------
-- TEST ------------------------------------------------------------------------
testReset :: forall eff. Aff (ajax :: AJAX | eff) Unit
testReset = postR ["test", "reset"]
--------------------------------------------------------------------------------
-- WALLETS ---------------------------------------------------------------------
getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = getR ["wallets"]

getWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) CWallet
getWallet addr = getR ["wallets", _address addr]

updateWallet :: forall eff. CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
updateWallet addr = putRBody ["wallets", _address addr]

newWallet :: forall eff. CWalletInit -> Aff (ajax :: AJAX | eff) CWallet
newWallet = postRBody ["wallets"]

deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = deleteR ["wallets", _address addr]

importKey :: forall eff. String -> Aff (ajax :: AJAX | eff) CWallet
importKey = postRBody ["wallets", "keys"]

restoreWallet :: forall eff. CWalletInit -> Aff (ajax :: AJAX | eff) CWallet
restoreWallet = postRBody ["wallets", "restore"]
--------------------------------------------------------------------------------
-- ADDRESSSES ------------------------------------------------------------------
isValidAddress :: forall eff. CCurrency -> String -> Aff (ajax :: AJAX | eff) Boolean
isValidAddress cCurrency addr = getR ["addresses", addr, "currencies", showCCurrency cCurrency]
--------------------------------------------------------------------------------
-- PROFILES --------------------------------------------------------------------
getProfile :: forall eff. Aff (ajax :: AJAX | eff) CProfile
getProfile = getR ["profile"]

updateProfile :: forall eff. CProfile -> Aff (ajax :: AJAX | eff) CProfile
updateProfile = postRBody ["profile"]
--------------------------------------------------------------------------------
-- TRANSACTIONS ----------------------------------------------------------------
send :: forall eff. CAddress -> CAddress -> Coin -> Aff (ajax :: AJAX | eff) CTx
send addrFrom addrTo amount = postR ["txs", "payments", _address addrFrom, _address addrTo, show $ _coin amount]

sendExtended :: forall eff. CAddress -> CAddress -> Coin -> CCurrency -> String -> String -> Aff (ajax :: AJAX | eff) CTx
sendExtended addrFrom addrTo amount curr title desc = postR ["txs", "payments", _address addrFrom, _address addrTo, show $ _coin amount, showCCurrency curr, title, desc]

updateTransaction :: forall eff. CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) Unit
updateTransaction addr ctxId = postRBody ["txs", "payments", _address addr, _ctxIdValue ctxId]

getHistory :: forall eff. CAddress -> Int -> Int -> Aff (ajax :: AJAX | eff) (Tuple (Array CTx) Int)
getHistory addr skip limit = getR ["txs", "histories", _address addr, show skip, show limit]

searchHistory :: forall eff. CAddress -> String -> Int -> Int -> Aff (ajax :: AJAX | eff) (Tuple (Array CTx) Int)
searchHistory addr search skip limit = getR ["txs", "histories", _address addr, search, show skip, show limit]
--------------------------------------------------------------------------------
-- UPDATES ---------------------------------------------------------------------
nextUpdate :: forall eff. Aff (ajax :: AJAX | eff) CUpdateInfo
nextUpdate = getR ["update"]

applyUpdate :: forall eff. Aff (ajax :: AJAX | eff) Unit
applyUpdate = postR ["update"]
--------------------------------------------------------------------------------
-- REDEMPTIONS -----------------------------------------------------------------
redeemADA :: forall eff. CWalletRedeem -> Aff (ajax :: AJAX | eff) CWallet
redeemADA = postRBody ["redemptions", "ada"]
--------------------------------------------------------------------------------
-- UPDATES ---------------------------------------------------------------------
blockchainSlotDuration :: forall eff. Aff (ajax :: AJAX | eff) Int
blockchainSlotDuration = getR ["settings", "slots", "duration"]

systemVersion :: forall eff. Aff (ajax :: AJAX | eff) SoftwareVersion
systemVersion = getR ["settings", "version"]

syncProgress :: forall eff. Aff (ajax :: AJAX | eff) SyncProgress
syncProgress = getR ["settings", "sync", "progress"]
--------------------------------------------------------------------------------

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, Error)
import Control.Monad.Error.Class (throwError)
import Daedalus.Constants (backendPrefix)
import Daedalus.Types (CAddress, Coin, _address, _coin, CWallet, CTx, CWalletMeta, CTxId, CTxMeta, _ctxIdValue, CCurrency, WalletError, showCCurrency, CProfile, CWalletInit, BackupPhrase, CUpdateInfo, SoftwareVersion, CWalletRedeem, SyncProgress)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(POST, PUT, DELETE))
import Data.Maybe (Maybe(Just))
import Data.MediaType.Common (applicationJSON)
import Data.String (joinWith)
import Data.Tuple (Tuple)
import Network.HTTP.Affjax (AffjaxResponse, affjax, defaultRequest, AJAX, URL, AffjaxRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.RequestHeader (RequestHeader(ContentType))
import Network.HTTP.StatusCode (StatusCode(..))

-- HELPERS

type URLPath = Array String

mkUrl :: URLPath -> URL
mkUrl = joinWith "/"

backendApi :: URLPath -> URL
backendApi path = mkUrl $ [backendPrefix, "api"] <> path

data ApiError
    = HTTPStatusError (AffjaxResponse Json)
    | JSONDecodingError String
    | ServerError WalletError

instance showApiError :: Show ApiError where
    show (HTTPStatusError res) =
        "HTTPStatusError: " <> show res.status <> " msg: " <> show res.response
    show (JSONDecodingError e) =
        "JSONDecodingError: " <> show e
    show (ServerError e) =
        "ServerError: " <> gShow e

-- REQUESTS HELPERS

decodeResult :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResult = either (Left <<< mkJSONError) (bimap mkServerError id) <<< decodeJson <<< _.response
  where
    mkJSONError = error <<< show <<< JSONDecodingError
    mkServerError = error <<< show <<< ServerError

makeRequest :: forall eff a r. (Generic a, Requestable r) => AffjaxRequest r -> URLPath -> Aff (ajax :: AJAX | eff) a
makeRequest request urlPath = do
    res <- affjax $ request { url = backendApi urlPath }
    when (isHttpError res.status) $
        throwError <<< error <<< show $ HTTPStatusError res
    either throwError pure $ decodeResult res
  where
    isHttpError (StatusCode c) = c >= 400

getR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
getR = makeRequest defaultRequest

postR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
postR = makeRequest $ defaultRequest { method = Left POST }

postRBody :: forall eff a b. (Generic a, Generic b) => URLPath -> b -> Aff (ajax :: AJAX | eff) a
postRBody urlPath content = flip makeRequest urlPath $
    defaultRequest { method = Left POST
                   , content = Just <<< show $ encodeJson content
                   , headers = [ContentType applicationJSON]
                   }

putRBody :: forall eff a b. (Generic a, Generic b) => URLPath -> b -> Aff (ajax :: AJAX | eff) a
putRBody urlPath content = flip makeRequest urlPath $
    defaultRequest { method = Left PUT
                   , content = Just <<< show $ encodeJson content
                   , headers = [ContentType applicationJSON]
                   }

deleteR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
deleteR = makeRequest $ defaultRequest { method = Left DELETE }

-- REQUESTS
--------------------------------------------------------------------------------
-- TEST ------------------------------------------------------------------------
testReset :: forall eff. Aff (ajax :: AJAX | eff) Unit
testReset = postR ["test/reset"]
--------------------------------------------------------------------------------
-- WALLETS ---------------------------------------------------------------------
getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = getR ["wallets"]

getWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) CWallet
getWallet addr = getR ["wallets", _address addr]

updateWallet :: forall eff. CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
updateWallet addr = putRBody ["wallets", _address addr]

newWallet :: forall eff. CWalletInit -> Aff (ajax :: AJAX | eff) CWallet
newWallet = postRBody ["wallets"]

deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = deleteR ["wallets", _address addr]

importKey :: forall eff. String -> Aff (ajax :: AJAX | eff) CWallet
importKey = postRBody ["wallets/keys"]

restoreWallet :: forall eff. CWalletInit -> Aff (ajax :: AJAX | eff) CWallet
restoreWallet = postRBody ["wallets/restore"]
--------------------------------------------------------------------------------
-- ADDRESSSES ------------------------------------------------------------------
isValidAddress :: forall eff. CCurrency -> String -> Aff (ajax :: AJAX | eff) Boolean
isValidAddress cCurrency addr = getR ["addresses", addr, "currencies", showCCurrency cCurrency]
--------------------------------------------------------------------------------
-- PROFILES --------------------------------------------------------------------
getProfile :: forall eff. Aff (ajax :: AJAX | eff) CProfile
getProfile = getR ["profile"]

updateProfile :: forall eff. CProfile -> Aff (ajax :: AJAX | eff) CProfile
updateProfile = postRBody ["profile"]
--------------------------------------------------------------------------------
-- TRANSACTIONS ----------------------------------------------------------------
send :: forall eff. CAddress -> CAddress -> Coin -> Aff (ajax :: AJAX | eff) CTx
send addrFrom addrTo amount = postR ["txs/payments", _address addrFrom, _address addrTo, show $ _coin amount]

sendExtended :: forall eff. CAddress -> CAddress -> Coin -> CCurrency -> String -> String -> Aff (ajax :: AJAX | eff) CTx
sendExtended addrFrom addrTo amount curr title desc = postR ["txs/payments", _address addrFrom, _address addrTo, show $ _coin amount, showCCurrency curr, title, desc]

updateTransaction :: forall eff. CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) Unit
updateTransaction addr ctxId = postRBody ["txs/payments", _address addr, _ctxIdValue ctxId]

getHistory :: forall eff. CAddress -> Int -> Int -> Aff (ajax :: AJAX | eff) (Tuple (Array CTx) Int)
getHistory addr skip limit = getR ["txs/histories", _address addr, show skip, show limit]

searchHistory :: forall eff. CAddress -> String -> Int -> Int -> Aff (ajax :: AJAX | eff) (Tuple (Array CTx) Int)
searchHistory addr search skip limit = getR ["txs/histories", _address addr, search, show skip, show limit]
--------------------------------------------------------------------------------
-- UPDATES ---------------------------------------------------------------------
nextUpdate :: forall eff. Aff (ajax :: AJAX | eff) CUpdateInfo
nextUpdate = getR ["update"]

applyUpdate :: forall eff. Aff (ajax :: AJAX | eff) Unit
applyUpdate = postR ["update"]
--------------------------------------------------------------------------------
-- REDEMPTIONS -----------------------------------------------------------------
redeemADA :: forall eff. CWalletRedeem -> Aff (ajax :: AJAX | eff) CWallet
redeemADA = postRBody ["redemptions/ada"]
--------------------------------------------------------------------------------
-- UPDATES ---------------------------------------------------------------------
blockchainSlotDuration :: forall eff. Aff (ajax :: AJAX | eff) Int
blockchainSlotDuration = getR ["settings/slots/duration"]

systemVersion :: forall eff. Aff (ajax :: AJAX | eff) SoftwareVersion
systemVersion = getR ["settings/version"]

syncProgress :: forall eff. Aff (ajax :: AJAX | eff) SyncProgress
syncProgress = getR ["settings/sync/progress"]
--------------------------------------------------------------------------------


Reason dialog

Reason dialog

{-
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.Deck.Dialog.Reason.Component
  ( Query(..)
  , component
  ) where

import SlamData.Prelude

import Data.Array as Array
import Halogen as H
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B
import SlamData.Workspace.Card.CardType (CardType)
import SlamData.Workspace.Card.CardType as CardType
import SlamData.Workspace.Card.InsertableCardType (InsertableCardType, print)

type State =
  { attemptedCardType ∷ CardType
  , reason ∷ String
  , cardPaths ∷ Array (Array InsertableCardType)
  }

data Query a = Dismiss a

component ∷ ∀ m. State → H.Component HH.HTML Query Unit Void m
component initialState =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ State → H.ComponentHTML Query
render state =
  HH.div
  [ HP.classes [ HH.ClassName "deck-dialog-embed" ] ]
  [ HH.h4_
      [ HH.text
        $ "Couldn't insert a "
        <> CardType.cardName state.attemptedCardType
        <> " card into this deck"
      ]
  , HH.div
      [ HP.classes [ HH.ClassName "deck-dialog-body" ] ]
      [ HH.p_
          [ HH.text state.reason
          ]
      , HH.p_ renderCardPathsMessage
      , HH.div_ $ map renderCardPath state.cardPaths
      ]
  , HH.div
      [ HP.classes [ HH.ClassName "deck-dialog-footer" ] ]
      [ HH.button
          [ HP.classes [ B.btn ]
          , HE.onClick (HE.input_ $ Dismiss)
          ]
          [ HH.text "Dismiss" ]
      ]
  ]
  where
  renderCardPathsMessage =
    case Array.length state.cardPaths of
      0 → []
      i →
        [ HH.text
            $ "To be able to insert a "
            <> show (CardType.cardName state.attemptedCardType)
            <> " card here you can add " <> setsOfCardsText i <> " first:"
        ]

  onlySingleCardPaths = Array.nub (Array.length <$> state.cardPaths) == [1]

  setsOfCardsText =
    case _ of
      1 → if onlySingleCardPaths then "this card" else "these cards in order"
      _ → if onlySingleCardPaths then "any of these cards" else "any of these sets of cards in order"

  renderCardPath cardPath =
    HH.p
      [ HP.classes [ HH.ClassName "deck-dialog-cardpath" ] ]
      (map renderCard cardPath)

  renderCard card =
    HH.span
      [ HP.classes [HH.ClassName "deck-dialog-cardpath-card" ] ]
      [ HH.text $ print card ]

eval ∷ ∀ m. Query ~> H.ComponentDSL State Query Void m
eval (Dismiss next) = pure next

{-
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.Deck.Dialog.Reason.Component where

import SlamData.Prelude

import Data.Array as Array
import Halogen as H
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B
import SlamData.Workspace.Card.CardType (CardType)
import SlamData.Workspace.Card.CardType as CardType
import SlamData.Workspace.Card.InsertableCardType (InsertableCardType, print)

type State =
  { attemptedCardType ∷ CardType
  , reason ∷ String
  , cardPaths ∷ Array (Array InsertableCardType)
  }

data Query a = Dismiss a

comp ∷ ∀ g. Functor g ⇒ H.Component State Query g
comp = H.component { render, eval } where

  render ∷ State → H.ComponentHTML Query
  render state =
    HH.div
    [ HP.classes [ HH.ClassName "deck-dialog-embed" ] ]
    [ HH.h4_
        [ HH.text
          $ "Couldn't insert a "
          <> CardType.cardName state.attemptedCardType
          <> " card into this deck"
        ]
    , HH.div
        [ HP.classes [ HH.ClassName "deck-dialog-body" ] ]
        [ HH.p_
            [ HH.text state.reason
            ]
        , HH.p_ renderCardPathsMessage
        , HH.div_ $ map renderCardPath state.cardPaths
        ]
    , HH.div
        [ HP.classes [ HH.ClassName "deck-dialog-footer" ] ]
        [ HH.button
            [ HP.classes [ B.btn ]
            , HE.onClick (HE.input_ $ Dismiss)
            ]
            [ HH.text "Dismiss" ]
        ]
    ]
    where
    renderCardPathsMessage =
      case Array.length state.cardPaths of
        0 → []
        i →
          [ HH.text
              $ "To be able to insert a "
              <> show (CardType.cardName state.attemptedCardType)
              <> " card here you can add " <> setsOfCardsText i <> " first:"
          ]

    onlySingleCardPaths = Array.nub (Array.length <$> state.cardPaths) == [1]

    setsOfCardsText =
      case _ of
        1 → if onlySingleCardPaths then "this card" else "these cards in order"
        _ → if onlySingleCardPaths then "any of these cards" else "any of these sets of cards in order"

    renderCardPath cardPath =
      HH.p
        [ HP.classes [ HH.ClassName "deck-dialog-cardpath" ] ]
        (map renderCard cardPath)

    renderCard card =
      HH.span
        [ HP.classes [HH.ClassName "deck-dialog-cardpath-card" ] ]
        [ HH.text $ print card ]

  eval ∷ Query ~> H.ComponentDSL State Query g
  eval (Dismiss next) = pure next


Fix warnings

Fix warnings

{-
Copyright 2015 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 Test.Selenium.File.Common where

import Prelude

import Control.Bind ((=<<))

import Selenium.ActionSequence hiding (sequence)
import Selenium.Monad
import Selenium.Types

import Test.Selenium.ActionSequence
import Test.Selenium.Common
import Test.Selenium.Log
import Test.Selenium.Monad

click' :: Element -> Check Unit
click' = sequence <<< leftClick

home :: Check Unit
home = do
  getConfig >>= get <<< _.slamdataUrl
  fileComponentLoaded

findOpenItem :: String -> Check Element
findOpenItem name = tryRepeatedlyTo $ findExact =<< byXPath xPath
  where
  xPath = "//a[text()='" ++ name ++ "']"

loseItem :: String -> Check Unit
loseItem name = tryRepeatedlyTo $ loseElement =<< byXPath xPath
  where
  xPath = "//*[text()='" ++ name ++ "']"

findItem :: String -> Check Element
findItem name =
  tryRepeatedlyTo $ findExact =<< byXPath (selectXPath `xPathOr` deselectXPath)
  where
  selectXPath = "//*[@aria-label='Select " ++ name ++ "']"
  deselectXPath = "//*[@aria-label='Deselect " ++ name ++ "']"
  xPathOr x y = x ++ "|" ++ y

selectFile :: String -> Check Unit
selectFile filename = click' =<< findSingle =<< byCss (selectFileCss filename)
  where
  selectFileCss filename = "*[aria-label='Select " ++ filename ++ "']"

itemGetDeleteIcon :: Element -> Check Element
itemGetDeleteIcon item = do
  config <- getConfig
  tryRepeatedlyTo $ byAriaLabel config.move.markDelete >>= childExact item

moveDelete :: String -> Check Unit -> String -> String -> Check Unit
moveDelete msg setUp src tgt = do
  sectionMsg $ "check move/delete " <> msg
  setUp
  config <- getConfig
  selectFile src
  click' =<< (itemGetMoveIcon =<< findItem src )
  waitModalShown
  tryRepeatedlyTo
    $ getElementByCss config.move.nameField "no rename field"
    >>= editNameField

  tryRepeatedlyTo
    $ getElementByCss config.move.submit "no submit button"
    >>= sequence <<< leftClick

  findItem tgt
  successMsg $ "ok, successfully renamed (" <> msg <> ")"

  selectFile tgt
  click' =<< (itemGetDeleteIcon =<< findItem tgt)
  tryRepeatedlyTo $ loseItem tgt
  successMsg $ "ok, successfully deleted (" <> msg <> ")"
  where
  itemGetMoveIcon :: Element -> Check Element
  itemGetMoveIcon item = do
    config <- getConfig
    tryRepeatedlyTo $ byAriaLabel config.move.markMove >>= childExact item

  editNameField :: Element -> Check Unit
  editNameField nameField = do
    config <- getConfig
    modifierKey <- getModifierKey
    sequence do
      leftClick nameField
      sendBackspaces 100
      keys tgt

{-
Copyright 2015 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 Test.Selenium.File.Common where

import Prelude

import Control.Bind ((=<<))

import Data.String.Regex as R

import Selenium.ActionSequence hiding (sequence)
import Selenium.Combinators (checker, awaitUrlChanged, tryToFind)
import Selenium.Monad
import Selenium.Types

import Test.Config
import Test.Selenium.ActionSequence
import Test.Selenium.Common
import Test.Selenium.Log
import Test.Selenium.Monad

click' :: Element -> Check Unit
click' = sequence <<< leftClick

home :: Check Unit
home = do
  getConfig >>= get <<< _.slamdataUrl
  fileComponentLoaded

findOpenItem :: String -> Check Element
findOpenItem name = tryRepeatedlyTo $ findExact =<< byXPath xPath
  where
  xPath = "//a[text()='" ++ name ++ "']"

loseItem :: String -> Check Unit
loseItem name = tryRepeatedlyTo $ loseElement =<< byXPath xPath
  where
  xPath = "//*[text()='" ++ name ++ "']"

findItem :: String -> Check Element
findItem name =
  tryRepeatedlyTo $ findExact =<< byXPath (selectXPath `xPathOr` deselectXPath)
  where
  selectXPath = "//*[@aria-label='Select " ++ name ++ "']"
  deselectXPath = "//*[@aria-label='Deselect " ++ name ++ "']"
  xPathOr x y = x ++ "|" ++ y

selectFile :: String -> Check Unit
selectFile filename = click' =<< findSingle =<< byCss (selectFileCss filename)
  where
  selectFileCss filename = "*[aria-label='Select " ++ filename ++ "']"

itemGetDeleteIcon :: Element -> Check Element
itemGetDeleteIcon item = do
  config <- getConfig
  tryRepeatedlyTo $ byAriaLabel config.move.markDelete >>= childExact item

moveDelete :: String -> Check Unit -> String -> String -> Check Unit
moveDelete msg setUp src tgt = do
  sectionMsg $ "check move/delete " <> msg
  setUp
  config <- getConfig
  selectFile src
  click' =<< (itemGetMoveIcon =<< findItem src )
  waitModalShown
  tryRepeatedlyTo
    $ getElementByCss config.move.nameField "no rename field"
    >>= editNameField

  tryRepeatedlyTo
    $ getElementByCss config.move.submit "no submit button"
    >>= sequence <<< leftClick

  findItem tgt
  successMsg $ "ok, successfully renamed (" <> msg <> ")"

  selectFile tgt
  click' =<< (itemGetDeleteIcon =<< findItem tgt)
  tryRepeatedlyTo $ loseItem tgt
  successMsg $ "ok, successfully deleted (" <> msg <> ")"
  where
  itemGetMoveIcon :: Element -> Check Element
  itemGetMoveIcon item = do
    config <- getConfig
    tryRepeatedlyTo $ byAriaLabel config.move.markMove >>= childExact item

  editNameField :: Element -> Check Unit
  editNameField nameField = do
    config <- getConfig
    modifierKey <- getModifierKey
    sequence do
      leftClick nameField
      sendBackspaces 100
      keys tgt


Improve error output for mutex groups

Improve error output for mutex groups

-- | Input Parser Generator for Docopt
-- |
-- | > Given a un-ambigious specification as input, generate a parser that can
-- | > be applied to user input.
-- |
-- | ===

module Language.Docopt.ParserGen.Parser (
    genUsageParser
  , Parser()
  ) where

import Prelude
import Control.Plus (class Plus, empty)
import Debug.Trace
import Data.Identity (Identity(), runIdentity)
import Control.Apply ((*>), (<*))
import Data.Function (on)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, isNothing, maybe, maybe', fromMaybe)
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList, filter, reverse, concat, catMaybes)
import Control.Alt ((<|>))
import Data.Traversable (class Traversable, traverse, for)
import Control.Lazy (defer)
import Data.Foldable (class Foldable, maximum, maximumBy, foldl, intercalate, for_, all)
import Data.String as String
import Data.String (fromCharArray, stripPrefix)
import Data.Bifunctor (class Bifunctor, rmap)
import Data.List as L
import Data.List.Unsafe as LU
import Data.Array as A
import Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Monoid (Monoid)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Monoid (mempty)
import Data.Map (Map())
import Control.Monad.Reader (Reader(), ask, runReader)
import Control.Monad.Reader.Trans (ReaderT(), runReaderT)
import Control.Monad.State (State(), runState, evalState, execState)
import Control.Monad.State as State
import Data.Map as Map
import Data.StrMap (StrMap())
import Control.Monad.Trans (lift)
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Control.Bind ((=<<))

import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt.Env      as Env
import Language.Docopt.Errors   as D
import Language.Docopt.Value    as D
import Language.Docopt.Argument as D
import Language.Docopt.Usage    as D
import Language.Docopt.Env      as D
import Language.Docopt.Option   as O
import Language.Docopt.Value    as Value

import Language.Docopt.ParserGen.Token
import Language.Docopt.ParserGen.Token as Token
import Language.Docopt.ParserGen.ValueMapping
import Language.Docopt.Parser.Base (alphaNum, space, getInput)

debug :: Boolean
debug = false

-- |
-- | Unfortunately, the State Monad is needed because we try matching all
-- | program branches and must select the best fit.
-- |
type Parser a = P.ParserT (List PositionedToken)
                          (ReaderT D.Env (State Int))
                          a

newtype ScoredResult a = ScoredResult { score :: Int, result :: a }

unScoredResult :: forall a. ScoredResult a -> { score :: Int, result :: a }
unScoredResult (ScoredResult r) = r

instance semigroupScoredResult :: (Semigroup a) => Semigroup (ScoredResult a)
  where append (ScoredResult s) (ScoredResult s')
          = ScoredResult { score:  s.score  + s'.score
                         , result: s.result ++ s'.result }

instance monoidScoredResult :: (Monoid a) => Monoid (ScoredResult a)
  where mempty = ScoredResult { score: 0, result: mempty }

instance showScoredResult :: (Show a) => Show (ScoredResult a)
  where show (ScoredResult { score, result })
          = "ScoredResult " ++ show score ++ ": " ++ show result

instance ordScoredResult :: Ord (ScoredResult a)
  where compare = compare `on` (_.score <<< unScoredResult)

instance eqScoredResult :: Eq (ScoredResult a)
  where eq = eq `on` (_.score <<< unScoredResult)

scoreFromList :: forall a. List a -> ScoredResult (List a)
scoreFromList xs = ScoredResult { score: length xs, result: xs }

rmapScoreResult :: forall a b. (a -> b) -> ScoredResult a -> ScoredResult b
rmapScoreResult f (ScoredResult (x@{ result })) = ScoredResult $ x { result = f result }

--------------------------------------------------------------------------------
-- Input Token Parser ----------------------------------------------------------
--------------------------------------------------------------------------------

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> Parser a
token test = P.ParserT $ \(P.PState { input: toks, position: ppos }) ->
  return $ case toks of
    Cons (PositionedToken { token: tok }) xs ->
      case test tok of
        Just a ->
          let nextpos =
              case xs of
                Cons (PositionedToken { sourcePos: npos }) _ -> npos
                Nil -> ppos
          in
            { consumed: true
            , input: xs
            , result: Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks ppos "a better error message!"
    _ -> P.parseFailed toks ppos "Expected token, met EOF"

data Acc a
  = Free (Parser a)
  | Pending (Parser a) (List D.Argument)

eoa :: Parser D.Value
eoa = token go P.<?> "--"
  where
    go (EOA xs) = Just (D.ArrayValue (fromList xs))
    go _        = Nothing

command :: String -> Parser D.Value
command n = token go P.<?> "command " ++ show n
  where
    go (Lit s) | s == n = Just (D.BoolValue true)
    go _                = Nothing

positional :: String -> Parser D.Value
positional n = token go P.<?> "positional argument " ++ show n
  where
    go (Lit v) = Just (Value.read v)
    go _       = Nothing

dash :: Parser D.Value
dash = token go P.<?> "stdin flag"
  where
    go (Lit v) | v == "-" = Just (D.BoolValue true)
    go _                  = Nothing

type HasConsumedArg = Boolean
data OptParse = OptParse D.Value (Maybe Token) HasConsumedArg

longOption :: O.Name -> (Maybe O.Argument) -> Parser D.Value
longOption n a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons (PositionedToken { token: tok, sourcePos: npos, source: s }) xs ->
      case go tok (_.token <<< unPositionedToken <$> head xs) of
        Left e -> P.parseFailed toks npos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    let pushed = maybe empty
                                         (\v -> singleton $ PositionedToken {
                                                  token:     v
                                                , sourcePos: pos
                                                , source:    s
                                                }
                                          )
                                          newtok
                          rest   = if hasConsumedArg then LU.tail xs else xs
                       in pushed ++ rest
          , result:   Right v
          , position: maybe pos
                            (_.sourcePos <<< unPositionedToken)
                            (head xs)
          }
    _ -> P.parseFailed toks pos "Expected token, met EOF"

  where
    isFlag = isNothing a

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | (not isFlag) && (n' == n)
      = case v of
          Just s ->
            return $ OptParse (Value.read s) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (Value.read s)  Nothing true
            _            -> OptParse (D.BoolValue true) Nothing false

    -- case 2:
    -- The name is an exact match and takes no argument
    go (LOpt n' v) _ | isFlag && (n' == n)
      = case v of
             Just _  -> Left "Option takes no argument"
             Nothing -> return $ OptParse (D.BoolValue true) Nothing false

    -- case 3:
    -- The name is a substring of the input and no explicit argument has been
    -- provdided.
    go (LOpt n' Nothing) _ | not isFlag
      = case stripPrefix n n' of
          Just s -> return $ OptParse (Value.read s) Nothing false
          _      -> Left "Invalid substring"

    go a b = Left $ "Invalid token" ++ show a ++ " (input: " ++ show b ++ ")"

shortOption :: Char -> (Maybe O.Argument) -> Parser D.Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons (PositionedToken { token: tok, source: s }) xs ->
      case go tok (_.token <<< unPositionedToken <$> head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    let pushed = maybe empty
                                         (\v -> singleton $ PositionedToken {
                                                  token:     v
                                                , sourcePos: pos
                                                , source:    s
                                                }
                                          )
                                          newtok
                          rest   = if hasConsumedArg then LU.tail xs else xs
                       in pushed ++ rest
          , result:   Right v
          , position: maybe pos
                            (_.sourcePos <<< unPositionedToken)
                            (head xs)
          }
    _ -> P.parseFailed toks pos "Expected token, met EOF"

  where
    isFlag = isNothing a

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && (not isFlag) && (A.length xs == 0)
      = case v of
          Just val -> return $ OptParse (D.StringValue val) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (Value.read s) Nothing true
            _ -> OptParse (D.BoolValue true)
                          Nothing
                          false

    -- case 2:
    -- The leading flag matches, there are stacked options, no explicit
    -- argument has been passed and the option takes an argument.
    go (SOpt f' xs v) _ | (f' == f) && (not isFlag) && (A.length xs > 0)
      = do
        let a = fromCharArray xs ++ maybe "" id v
        return $ OptParse (Value.read a)
                          Nothing
                          false

    -- case 3:
    -- The leading flag matches, there are stacked options, the option takes
    -- no argument and an explicit argument has not been provided.
    go (SOpt f' xs v) _ | (f' == f) && (isFlag) && (A.length xs > 0)
      = return $ OptParse (D.BoolValue true)
                          (Just $ SOpt (AU.head xs) (AU.tail xs) v)
                          false

    -- case 4:
    -- The leading flag matches, there are no stacked options and the option
    -- takes no argument - total consumption!
    go (SOpt f' xs v) _ | (f' == f) && (isFlag) && (A.length xs == 0)
      = case v of
              Just _  -> Left "Option takes no argument"
              Nothing -> return $ OptParse (D.BoolValue true)
                                            Nothing
                                            false

    go a b = Left $ "Invalid token" ++ show a ++ " (input: " ++ show b ++ ")"

eof :: Parser Unit
eof = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return $ case s of
    Nil -> { consumed: false, input: s, result: Right unit, position: pos }
    _   -> P.parseFailed s pos $
              "Trailing input: "
            ++ (intercalate ", "
                  $ prettyPrintToken <<< _.token <<< unPositionedToken <$> s)

-- | Generate a parser for a single program usage.
genUsageParser :: List D.Usage -- ^ The list of usage specs
               -> Boolean      -- ^ Enable "options-first"
               -> Parser (Tuple D.Branch (List ValueMapping))
genUsageParser xs optsFirst = do
  _.result <<< unScoredResult
    <$> genBranchesParser (concat $ D.runUsage <$> xs)
                          true
                          optsFirst
                          true

-- | Generate a parser that selects the best branch it parses and
-- | fails if no branch was parsed.
genBranchesParser :: List D.Branch -- ^ The branches to test
                  -> Boolean       -- ^ Expect EOF after each branch
                  -> Boolean       -- ^ Enable "options-first"
                  -> Boolean       -- ^ Can we skip input via fallbacks?
                  -> Parser (ScoredResult (Tuple D.Branch (List ValueMapping)))
genBranchesParser xs term optsFirst canSkip
  = P.ParserT \(s@(P.PState { input: i, position: pos })) -> do
    env :: D.Env <- ask
    let ps = xs <#> \x -> rmapScoreResult (Tuple x) <$> do
                            genBranchParser x optsFirst canSkip
                            <* if term then eof else return unit
        rs = evalState (runReaderT (collect s ps) env) 0
    return $ maybe'
      (\_ ->
        maybe'
          (\_ -> P.parseFailed Nil P.initialPos
                  "The impossible happened. Failure without error")
          (\e ->
            -- of all `mlefts` are zeros, it's an ambigious fail and all
            -- branches must be presented as an option.
            if e.result.depth > 0
              then e { result = Left e.result.error }
              else
                let errors = _.error <<< _.result <$> mlefts rs
                 in e { result = Left $ P.ParseError {
                        position: _.position $ unParseError (LU.head errors)
                      , message:
                          -- Concatenate the error such that it looks like one
                          -- continuos error. This is borderline brittle because
                          -- it replaces some text that comes from
                          -- purescript-parsing.
                          let m  = _.message $ unParseError (LU.head errors)
                              ms = LU.tail errors <#> \e ->
                                    let m = _.message $ unParseError e
                                     in String.replace "Expected " "" m
                           in intercalate " or " (m : ms)
                    } }
          )
          (maximumBy (compare `on` (_.depth <<< _.result)) $ mlefts rs)
      )
      (\r -> r { result = Right r.result.value })
      (maximumBy (compare `on` (_.depth <<< _.result)) $ mrights rs)

  where
    fixMessage m = m
    collect s ps = ps `flip traverse` \p -> P.unParserT p s >>= \o -> do
                    depth :: Int <- lift State.get
                    return $ either
                      (\e -> Left  { input:    o.input
                                   , consumed: o.consumed
                                   , position: o.position
                                   , result:   { error: e, depth: depth }
                                   })
                      (\r -> Right { input:    o.input
                                   , consumed: o.consumed
                                   , position: o.position
                                   , result:   { value: r, depth: depth }
                                   })
                      o.result

-- | Generate a parser for a single usage branch
genBranchParser :: D.Branch  -- ^ The branch to match
                -> Boolean   -- ^ Enable "options-first"
                -> Boolean   -- ^ Can we skip input via fallbacks?
                -> Parser (ScoredResult (List ValueMapping))
genBranchParser (D.Branch xs) optsFirst canSkip = do
  lift (State.put 0) -- reset the depth counter
  either
    (\_   -> P.fail "Failed to generate parser")
    (\acc -> case acc of
              Free p       -> p
              Pending p xs -> do
                r  <- p
                rs <- genExhaustiveParser (reverse xs) canSkip
                return $ r ++ rs
    )
    (foldM step (Free $ pure mempty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    genExhaustiveParser :: List D.Argument -- ^ The free arguments
                        -> Boolean         -- ^ Can we skip input via fallbacks?
                        -> Parser (ScoredResult (List ValueMapping))
    genExhaustiveParser Nil canSkip = return mempty
    genExhaustiveParser ps  canSkip = do
      if debug
        then do
          traceA $ "genExhaustiveParser: "
                ++ (intercalate " " (D.prettyPrintArg <$> ps))
                ++ " - canSkip: " ++  show canSkip
          else return unit
      draw ps (length ps)
      where
        -- iterate over `ps` until a match `x` is found, then, recursively
        -- apply `draw` until the parser fails, with a modified `ps`.
        draw :: List D.Argument -- ^ the arguments to parse
             -> Int             -- ^ the number of options left to parse
             -> Parser (ScoredResult (List ValueMapping))

        draw pss@(Cons p ps') n | n >= 0 = (do
          if debug
            then do
                i <- getInput
                traceA $
                  "draw: (" ++ (D.prettyPrintArg p) ++ ":"
                            ++ (intercalate ":" (D.prettyPrintArg <$> ps'))
                            ++  ") - n: " ++ show n
                            ++ "from input: "
                            ++ (intercalate " " (prettyPrintToken
                                                  <<< _.token
                                                  <<< unPositionedToken <$> i))
            else return unit

          -- Generate the parser for the argument `p`. For groups, temporarily
          -- set the required flag to "true", such that it will fail and we have
          -- a chance to retry as part of the exhaustive parsing mechanism
          r <- unScoredResult <$> (P.try $ genParser (D.setRequired p true)
                                                     (not $ n > 0))

          -- verify the arguments for the parsed set of options when an option
          -- takes anything but a bool value, i.e. it is not a flag, an explicit
          -- argument *must* be provided.
          let missing = fst <$> flip filter r.result
                    (\(Tuple a v) -> (fromMaybe false do
                                        arg <- O.runArgument <$> do
                                                  D.getArgument a
                                        return $ not arg.optional
                                     )
                                  && (not $ D.isFlag a)
                                  && (D.isBoolValue v))

          if (length missing == 0)
            then return unit
            else P.fail $ "Missing required arguments for "
                        ++ intercalate ", " (D.prettyPrintArgNaked <$> missing)

          r' <- unScoredResult <$> P.try do
                  if D.isRepeatable p
                        then draw pss (length pss)
                        else draw ps' (length ps')

          return $ ScoredResult r ++ ScoredResult r'
        ) <|> (defer \_ -> draw (ps' ++ singleton p) (n - 1))

        draw ps' n | (length ps' > 0) && (n < 0) = do
          env :: StrMap String <- lift ask

          -- Find flags missing from the input.
          -- If we are explicitly allowed to skip arguments because of lack of
          -- input, or we have *at least* one match (i.e. the remainder is less
          -- than the original), then ignore arguments for which a suitable
          -- fallback value can be provided.
          let missing = filter (\o -> not $
                                  (canSkip || (length ps' < length ps))
                               && isSkippable env o
                               ) ps'

          if (length missing > 0)
            then P.fail $
              "Missing required options: "
                ++ intercalate ", " (D.prettyPrintArgNaked <$> missing)
            else return mempty

          where
            isSkippable env (D.Group o bs _)
              = o || (all (all (isSkippable env) <<< D.runBranch) bs)
            isSkippable env o
              =  (D.isRepeatable  o)
              || (D.hasDefault    o)
              || (maybe true id do
                  arg <- O.runArgument <$> do
                            D.getArgument o
                  return arg.optional
                )
              || (D.hasEnvBacking o env)

        draw _ _ = return mempty

    step :: Acc (ScoredResult (List ValueMapping))
         -> D.Argument
         -> Either P.ParseError (Acc (ScoredResult (List ValueMapping)))

    -- Options always transition to the `Pending state`
    step (Free p) x@(D.Option _)
      = return $ Pending p (singleton x)

    -- "Free" groups always transition to the `Pending state`
    step (Free p) x@(D.Group _ _ _) | isFree x
      = return $ Pending p (singleton x)

    -- Any other argument causes immediate evaluation
    step (Free p) x = Right $ Free do
      r  <- p
      rs <- genParser x false
      return $ r ++ rs

    -- Options always keep accumulating
    step (Pending p xs) x@(D.Option _)
      = return $ Pending p (x:xs)

    -- "Free" groups always keep accumulating
    step (Pending p xs) x@(D.Group _ _ _) | isFree x
      = return $ Pending p (x:xs)

    -- Any non-options always leaves the pending state
    step (Pending p xs) y = Right $
      Free do
        r   <- p
        rs  <- genExhaustiveParser xs true
        rss <- genParser y false
        return $ r ++ rs ++ rss

    -- Terminate the parser at the given argument and collect all subsequent
    -- values int an array ("options-first")
    terminate arg = do
      input <- getInput
      let rest = Tuple arg <$> do
                  D.StringValue <<< Token.getSource <$> input
      P.ParserT \(P.PState { position: pos }) ->
        return {
          consumed: true
        , input:    Nil
        , result:   return $ ScoredResult {
                      score: 1
                    , result: rest
                    }
        , position: pos
        }

    -- Parser generator for a single `Argument`
    genParser :: D.Argument -- ^ The argument to generate a parser for
              -> Boolean    -- ^ Can we skip input via fallbacks?
              -> Parser (ScoredResult (List ValueMapping))

    -- Generate a parser for a `Command` argument
    genParser x@(D.Command n r) _ = (do
      scoreFromList <$> do
        if r then (some go) else (singleton <$> go)
      <* lift (State.modify (1+))
      ) P.<?> "command: " ++ (show $ D.prettyPrintArg x)
        where go = Tuple x <$> (command n)

    -- Generate a parser for a `EOA` argument
    genParser x@(D.EOA) _ = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        eoa <|> (return $ D.ArrayValue []) -- XXX: Fix type
      <* lift (State.modify (1+))
      ) P.<?> "end of arguments: \"--\""

    -- Generate a parser for a `Stdin` argument
    genParser x@(D.Stdin) _ = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        dash
        return (D.BoolValue true)
      <* lift (State.modify (1+))
      ) P.<?> "stdin: \"-\""

    genParser x@(D.Positional n r) _
      | r && optsFirst
      = terminate x

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) _ = (do
      scoreFromList <$> do
        if r then (some go) else (singleton <$> go)
      <* lift (State.modify (1+))
      ) P.<?> "positional argument: " ++ (show $ D.prettyPrintArg x)
        where go = Tuple x <$> (positional n)

    -- Generate a parser for a `Option` argument
    genParser x@(D.Option (O.Option o)) _ = (do
      scoreFromList <$> do
        if o.repeatable then (some go) else (singleton <$> go)
      <* lift (State.modify (1+))
      )
        where
          go = do
            -- Perform a pre-cursory test in order to capture relevant error
            -- messags which would otherwise be overriden (e.g. a meaningful
            -- error message when trying to match a LOpt against a LOpt would
            -- be overridden by a meaningless try to match a SOpt against a
            -- a LOpt).
            isLopt <- P.option false (P.lookAhead $ P.try $ token isAnyLopt)
            isSopt <- P.option false (P.lookAhead $ P.try $ token isAnySopt)
            if isLopt
               then P.try $ Tuple x <$> mkLoptParser o.name o.arg
               else if isSopt
                then P.try $ Tuple x <$> mkSoptParser o.flag o.arg
                else P.fail "long or short option"

          isAnyLopt (LOpt _ _) = return true
          isAnyLopt _          = return false

          isAnySopt (SOpt _ _ _) = return true
          isAnySopt _            = return false

          mkLoptParser (Just n) a = longOption n a
          mkLoptParser Nothing _  = P.fail "long name"

          mkSoptParser (Just f) a = shortOption f a
          mkSoptParser Nothing _  = P.fail "flag"

    genParser x@(D.Group optional bs r) _
      | optional && optsFirst && (length bs == 1) &&
        all (\(D.Branch xs) ->
          case xs of
            Cons (D.Positional n r') Nil -> r' || r
            _                            -> false
        ) bs
      = terminate (LU.head (D.runBranch (LU.head bs)))

    -- Generate a parser for an argument `Group`
    -- The total score a group is the sum of all scores inside of it.
    genParser x@(D.Group optional bs repeated) canSkip = do
      vs <- concat <$>
          let mod    = if optional then P.try >>> P.option mempty else \p -> p
              parser = if repeated then goR else singleton <$> go
          in mod parser
      return $ scoreFromList vs
      where
        goR :: Parser (List (List ValueMapping))
        goR = do
          {score, result} <- unScoredResult
            <$> genBranchesParser bs
                                  false
                                  false
                                  -- always allow skipping for non-free groups.
                                  (not (isFree x) || canSkip)

          if score == 0
              then return $ singleton (snd result)
              else do
                xs <- goR <|> pure Nil
                return $ (snd result) : xs

        go :: Parser (List ValueMapping)
        go = if length bs == 0
                  then return mempty
                  else do
                    snd <<< _.result <<<  unScoredResult
                      <$> genBranchesParser bs
                                            false
                                            false
                                            -- always allow skipping for
                                            -- non-free groups.
                                            (not (isFree x) || canSkip)

    isFree :: D.Argument -> Boolean
    isFree (D.Option _)                                           = true
    isFree (D.Group _ bs _) | all (all isFree <<< D.runBranch) bs = true
    isFree _                                                      = false

unParseError :: P.ParseError -> { position :: P.Position, message :: String }
unParseError (P.ParseError e) = e

-- | Input Parser Generator for Docopt
-- |
-- | > Given a un-ambigious specification as input, generate a parser that can
-- | > be applied to user input.
-- |
-- | ===

module Language.Docopt.ParserGen.Parser (
    genUsageParser
  , Parser()
  ) where

import Prelude
import Control.Plus (class Plus, empty)
import Debug.Trace
import Data.Identity (Identity(), runIdentity)
import Control.Apply ((*>), (<*))
import Data.Function (on)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, isNothing, maybe, maybe', fromMaybe)
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList, filter, reverse, concat, catMaybes)
import Control.Alt ((<|>))
import Data.Traversable (class Traversable, traverse, for)
import Control.Lazy (defer)
import Data.Foldable (class Foldable, maximum, maximumBy, foldl, intercalate, for_, all)
import Data.String (fromCharArray, stripPrefix)
import Data.Bifunctor (class Bifunctor, rmap)
import Data.List as L
import Data.List.Unsafe as LU
import Data.Array as A
import Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Monoid (Monoid)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Monoid (mempty)
import Data.Map (Map())
import Control.Monad.Reader (Reader(), ask, runReader)
import Control.Monad.Reader.Trans (ReaderT(), runReaderT)
import Control.Monad.State (State(), runState, evalState, execState)
import Control.Monad.State as State
import Data.Map as Map
import Data.StrMap (StrMap())
import Control.Monad.Trans (lift)
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Control.Bind ((=<<))

import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt.Env      as Env
import Language.Docopt.Errors   as D
import Language.Docopt.Value    as D
import Language.Docopt.Argument as D
import Language.Docopt.Usage    as D
import Language.Docopt.Env      as D
import Language.Docopt.Option   as O
import Language.Docopt.Value    as Value

import Language.Docopt.ParserGen.Token
import Language.Docopt.ParserGen.Token as Token
import Language.Docopt.ParserGen.ValueMapping
import Language.Docopt.Parser.Base (alphaNum, space, getInput)

debug :: Boolean
debug = false

-- |
-- | Unfortunately, the State Monad is needed because we try matching all
-- | program branches and must select the best fit.
-- |
type Parser a = P.ParserT (List PositionedToken)
                          (ReaderT D.Env (State Int))
                          a

newtype ScoredResult a = ScoredResult { score :: Int, result :: a }

unScoredResult :: forall a. ScoredResult a -> { score :: Int, result :: a }
unScoredResult (ScoredResult r) = r

instance semigroupScoredResult :: (Semigroup a) => Semigroup (ScoredResult a)
  where append (ScoredResult s) (ScoredResult s')
          = ScoredResult { score:  s.score  + s'.score
                         , result: s.result ++ s'.result }

instance monoidScoredResult :: (Monoid a) => Monoid (ScoredResult a)
  where mempty = ScoredResult { score: 0, result: mempty }

instance showScoredResult :: (Show a) => Show (ScoredResult a)
  where show (ScoredResult { score, result })
          = "ScoredResult " ++ show score ++ ": " ++ show result

instance ordScoredResult :: Ord (ScoredResult a)
  where compare = compare `on` (_.score <<< unScoredResult)

instance eqScoredResult :: Eq (ScoredResult a)
  where eq = eq `on` (_.score <<< unScoredResult)

scoreFromList :: forall a. List a -> ScoredResult (List a)
scoreFromList xs = ScoredResult { score: length xs, result: xs }

rmapScoreResult :: forall a b. (a -> b) -> ScoredResult a -> ScoredResult b
rmapScoreResult f (ScoredResult (x@{ result })) = ScoredResult $ x { result = f result }

--------------------------------------------------------------------------------
-- Input Token Parser ----------------------------------------------------------
--------------------------------------------------------------------------------

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> Parser a
token test = P.ParserT $ \(P.PState { input: toks, position: ppos }) ->
  return $ case toks of
    Cons (PositionedToken { token: tok }) xs ->
      case test tok of
        Just a ->
          let nextpos =
              case xs of
                Cons (PositionedToken { sourcePos: npos }) _ -> npos
                Nil -> ppos
          in
            { consumed: true
            , input: xs
            , result: Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks ppos "a better error message!"
    _ -> P.parseFailed toks ppos "expected token, met EOF"

data Acc a
  = Free (Parser a)
  | Pending (Parser a) (List D.Argument)

eoa :: Parser D.Value
eoa = token go P.<?> "--"
  where
    go (EOA xs) = Just (D.ArrayValue (fromList xs))
    go _        = Nothing

command :: String -> Parser D.Value
command n = token go P.<?> "command " ++ show n
  where
    go (Lit s) | s == n = Just (D.BoolValue true)
    go _                = Nothing

positional :: String -> Parser D.Value
positional n = token go P.<?> "positional argument " ++ show n
  where
    go (Lit v) = Just (Value.read v)
    go _       = Nothing

dash :: Parser D.Value
dash = token go P.<?> "stdin flag"
  where
    go (Lit v) | v == "-" = Just (D.BoolValue true)
    go _                  = Nothing

type HasConsumedArg = Boolean
data OptParse = OptParse D.Value (Maybe Token) HasConsumedArg

longOption :: O.Name -> (Maybe O.Argument) -> Parser D.Value
longOption n a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons (PositionedToken { token: tok, sourcePos: npos, source: s }) xs ->
      case go tok (_.token <<< unPositionedToken <$> head xs) of
        Left e -> P.parseFailed toks npos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    let pushed = maybe empty
                                         (\v -> singleton $ PositionedToken {
                                                  token:     v
                                                , sourcePos: pos
                                                , source:    s
                                                }
                                          )
                                          newtok
                          rest   = if hasConsumedArg then LU.tail xs else xs
                       in pushed ++ rest
          , result:   Right v
          , position: maybe pos
                            (_.sourcePos <<< unPositionedToken)
                            (head xs)
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    isFlag = isNothing a

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | (not isFlag) && (n' == n)
      = case v of
          Just s ->
            return $ OptParse (Value.read s) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (Value.read s)  Nothing true
            _            -> OptParse (D.BoolValue true) Nothing false

    -- case 2:
    -- The name is an exact match and takes no argument
    go (LOpt n' v) _ | isFlag && (n' == n)
      = case v of
             Just _  -> Left "Option takes no argument"
             Nothing -> return $ OptParse (D.BoolValue true) Nothing false

    -- case 3:
    -- The name is a substring of the input and no explicit argument has been
    -- provdided.
    go (LOpt n' Nothing) _ | not isFlag
      = case stripPrefix n n' of
          Just s -> return $ OptParse (Value.read s) Nothing false
          _      -> Left "Invalid substring"

    go a b = Left $ "Invalid token" ++ show a ++ " (input: " ++ show b ++ ")"

shortOption :: Char -> (Maybe O.Argument) -> Parser D.Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons (PositionedToken { token: tok, source: s }) xs ->
      case go tok (_.token <<< unPositionedToken <$> head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    let pushed = maybe empty
                                         (\v -> singleton $ PositionedToken {
                                                  token:     v
                                                , sourcePos: pos
                                                , source:    s
                                                }
                                          )
                                          newtok
                          rest   = if hasConsumedArg then LU.tail xs else xs
                       in pushed ++ rest
          , result:   Right v
          , position: maybe pos
                            (_.sourcePos <<< unPositionedToken)
                            (head xs)
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    isFlag = isNothing a

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && (not isFlag) && (A.length xs == 0)
      = case v of
          Just val -> return $ OptParse (D.StringValue val) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (Value.read s) Nothing true
            _ -> OptParse (D.BoolValue true)
                          Nothing
                          false

    -- case 2:
    -- The leading flag matches, there are stacked options, no explicit
    -- argument has been passed and the option takes an argument.
    go (SOpt f' xs v) _ | (f' == f) && (not isFlag) && (A.length xs > 0)
      = do
        let a = fromCharArray xs ++ maybe "" id v
        return $ OptParse (Value.read a)
                          Nothing
                          false

    -- case 3:
    -- The leading flag matches, there are stacked options, the option takes
    -- no argument and an explicit argument has not been provided.
    go (SOpt f' xs v) _ | (f' == f) && (isFlag) && (A.length xs > 0)
      = return $ OptParse (D.BoolValue true)
                          (Just $ SOpt (AU.head xs) (AU.tail xs) v)
                          false

    -- case 4:
    -- The leading flag matches, there are no stacked options and the option
    -- takes no argument - total consumption!
    go (SOpt f' xs v) _ | (f' == f) && (isFlag) && (A.length xs == 0)
      = case v of
              Just _  -> Left "Option takes no argument"
              Nothing -> return $ OptParse (D.BoolValue true)
                                            Nothing
                                            false

    go a b = Left $ "Invalid token" ++ show a ++ " (input: " ++ show b ++ ")"

eof :: Parser Unit
eof = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return $ case s of
    Nil -> { consumed: false, input: s, result: Right unit, position: pos }
    _   -> P.parseFailed s pos $
              "Trailing input: "
            ++ (intercalate ", "
                  $ prettyPrintToken <<< _.token <<< unPositionedToken <$> s)

-- | Generate a parser for a single program usage.
genUsageParser :: List D.Usage -- ^ The list of usage specs
               -> Boolean      -- ^ Enable "options-first"
               -> Parser (Tuple D.Branch (List ValueMapping))
genUsageParser xs optsFirst = do
  _.result <<< unScoredResult
    <$> genBranchesParser (concat $ D.runUsage <$> xs)
                          true
                          optsFirst
                          true

-- | Generate a parser that selects the best branch it parses and
-- | fails if no branch was parsed.
genBranchesParser :: List D.Branch -- ^ The branches to test
                  -> Boolean       -- ^ Expect EOF after each branch
                  -> Boolean       -- ^ Enable "options-first"
                  -> Boolean       -- ^ Can we skip input via fallbacks?
                  -> Parser (ScoredResult (Tuple D.Branch (List ValueMapping)))
genBranchesParser xs term optsFirst canSkip
  = P.ParserT \(s@(P.PState { input: i, position: pos })) -> do
    env :: D.Env <- ask
    let ps = xs <#> \x -> rmapScoreResult (Tuple x) <$> do
                            genBranchParser x optsFirst canSkip
                            <* if term then eof else return unit
        rs = evalState (runReaderT (collect s ps) env) 0
    return $ maybe'
      (\_ ->
        maybe'
          (\_ -> P.parseFailed Nil P.initialPos
                  "The impossible happened. Failure without error")
          (\e -> e { result = Left e.result.error })
          (maximumBy (compare `on` (_.depth <<< _.result)) $ mlefts rs)
      )
      (\r -> r { result = Right r.result.value })
      (maximumBy (compare `on` (_.depth <<< _.result)) $ mrights rs)

  where
    collect s ps = ps `flip traverse` \p -> P.unParserT p s >>= \o -> do
                    depth :: Int <- lift State.get
                    return $ either
                      (\e -> Left  { input:    o.input
                                   , consumed: o.consumed
                                   , position: o.position
                                   , result:   { error: e, depth: depth }
                                   })
                      (\r -> Right { input:    o.input
                                   , consumed: o.consumed
                                   , position: o.position
                                   , result:   { value: r, depth: depth }
                                   })
                      o.result

-- | Generate a parser for a single usage branch
genBranchParser :: D.Branch  -- ^ The branch to match
                -> Boolean   -- ^ Enable "options-first"
                -> Boolean   -- ^ Can we skip input via fallbacks?
                -> Parser (ScoredResult (List ValueMapping))
genBranchParser (D.Branch xs) optsFirst canSkip = do
  lift (State.put 0) -- reset the depth counter
  either
    (\_   -> P.fail "Failed to generate parser")
    (\acc -> case acc of
              Free p       -> p
              Pending p xs -> do
                r  <- p
                rs <- genExhaustiveParser (reverse xs) canSkip
                return $ r ++ rs
    )
    (foldM step (Free $ pure mempty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    genExhaustiveParser :: List D.Argument -- ^ The free arguments
                        -> Boolean         -- ^ Can we skip input via fallbacks?
                        -> Parser (ScoredResult (List ValueMapping))
    genExhaustiveParser Nil canSkip = return mempty
    genExhaustiveParser ps  canSkip = do
      if debug
        then do
          traceA $ "genExhaustiveParser: "
                ++ (intercalate " " (D.prettyPrintArg <$> ps))
                ++ " - canSkip: " ++  show canSkip
          else return unit
      draw ps (length ps)
      where
        -- iterate over `ps` until a match `x` is found, then, recursively
        -- apply `draw` until the parser fails, with a modified `ps`.
        draw :: List D.Argument -- ^ the arguments to parse
             -> Int             -- ^ the number of options left to parse
             -> Parser (ScoredResult (List ValueMapping))

        draw pss@(Cons p ps') n | n >= 0 = (do
          if debug
            then do
                i <- getInput
                traceA $
                  "draw: (" ++ (D.prettyPrintArg p) ++ ":"
                            ++ (intercalate ":" (D.prettyPrintArg <$> ps'))
                            ++  ") - n: " ++ show n
                            ++ "from input: "
                            ++ (intercalate " " (prettyPrintToken
                                                  <<< _.token
                                                  <<< unPositionedToken <$> i))
            else return unit

          -- Generate the parser for the argument `p`. For groups, temporarily
          -- set the required flag to "true", such that it will fail and we have
          -- a chance to retry as part of the exhaustive parsing mechanism
          r <- unScoredResult <$> (P.try $ genParser (D.setRequired p true)
                                                     (not $ n > 0))

          -- verify the arguments for the parsed set of options when an option
          -- takes anything but a bool value, i.e. it is not a flag, an explicit
          -- argument *must* be provided.
          let missing = fst <$> flip filter r.result
                    (\(Tuple a v) -> (fromMaybe false do
                                        arg <- O.runArgument <$> do
                                                  D.getArgument a
                                        return $ not arg.optional
                                     )
                                  && (not $ D.isFlag a)
                                  && (D.isBoolValue v))

          if (length missing == 0)
            then return unit
            else P.fail $ "Missing required arguments for "
                        ++ intercalate ", " (D.prettyPrintArgNaked <$> missing)

          r' <- unScoredResult <$> P.try do
                  if D.isRepeatable p
                        then draw pss (length pss)
                        else draw ps' (length ps')

          return $ ScoredResult r ++ ScoredResult r'
        ) <|> (defer \_ -> draw (ps' ++ singleton p) (n - 1))

        draw ps' n | (length ps' > 0) && (n < 0) = do
          env :: StrMap String <- lift ask

          -- Find flags missing from the input.
          -- If we are explicitly allowed to skip arguments because of lack of
          -- input, or we have *at least* one match (i.e. the remainder is less
          -- than the original), then ignore arguments for which a suitable
          -- fallback value can be provided.
          let missing = filter (\o -> not $
                                  (canSkip || (length ps' < length ps))
                               && isSkippable env o
                               ) ps'

          if (length missing > 0)
            then P.fail $
              "Missing required options: "
                ++ intercalate ", " (D.prettyPrintArgNaked <$> missing)
            else return mempty

          where
            isSkippable env (D.Group o bs _)
              = o || (all (all (isSkippable env) <<< D.runBranch) bs)
            isSkippable env o
              =  (D.isRepeatable  o)
              || (D.hasDefault    o)
              || (maybe true id do
                  arg <- O.runArgument <$> do
                            D.getArgument o
                  return arg.optional
                )
              || (D.hasEnvBacking o env)

        draw _ _ = return mempty

    step :: Acc (ScoredResult (List ValueMapping))
         -> D.Argument
         -> Either P.ParseError (Acc (ScoredResult (List ValueMapping)))

    -- Options always transition to the `Pending state`
    step (Free p) x@(D.Option _)
      = return $ Pending p (singleton x)

    -- "Free" groups always transition to the `Pending state`
    step (Free p) x@(D.Group _ _ _) | isFree x
      = return $ Pending p (singleton x)

    -- Any other argument causes immediate evaluation
    step (Free p) x = Right $ Free do
      r  <- p
      rs <- genParser x false
      return $ r ++ rs

    -- Options always keep accumulating
    step (Pending p xs) x@(D.Option _)
      = return $ Pending p (x:xs)

    -- "Free" groups always keep accumulating
    step (Pending p xs) x@(D.Group _ _ _) | isFree x
      = return $ Pending p (x:xs)

    -- Any non-options always leaves the pending state
    step (Pending p xs) y = Right $
      Free do
        r   <- p
        rs  <- genExhaustiveParser xs true
        rss <- genParser y false
        return $ r ++ rs ++ rss

    -- Terminate the parser at the given argument and collect all subsequent
    -- values int an array ("options-first")
    terminate arg = do
      input <- getInput
      let rest = Tuple arg <$> do
                  D.StringValue <<< Token.getSource <$> input
      P.ParserT \(P.PState { position: pos }) ->
        return {
          consumed: true
        , input:    Nil
        , result:   return $ ScoredResult {
                      score: 1
                    , result: rest
                    }
        , position: pos
        }

    -- Parser generator for a single `Argument`
    genParser :: D.Argument -- ^ The argument to generate a parser for
              -> Boolean    -- ^ Can we skip input via fallbacks?
              -> Parser (ScoredResult (List ValueMapping))

    -- Generate a parser for a `Command` argument
    genParser x@(D.Command n r) _ = (do
      scoreFromList <$> do
        if r then (some go) else (singleton <$> go)
      <* lift (State.modify (1+))
      ) P.<?> "command: " ++ (show $ D.prettyPrintArg x)
        where go = Tuple x <$> (command n)

    -- Generate a parser for a `EOA` argument
    genParser x@(D.EOA) _ = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        eoa <|> (return $ D.ArrayValue []) -- XXX: Fix type
      <* lift (State.modify (1+))
      ) P.<?> "end of arguments: \"--\""

    -- Generate a parser for a `Stdin` argument
    genParser x@(D.Stdin) _ = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        dash
        return (D.BoolValue true)
      <* lift (State.modify (1+))
      ) P.<?> "stdin: \"-\""

    genParser x@(D.Positional n r) _
      | r && optsFirst
      = terminate x

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) _ = (do
      scoreFromList <$> do
        if r then (some go) else (singleton <$> go)
      <* lift (State.modify (1+))
      ) P.<?> "positional argument: " ++ (show $ D.prettyPrintArg x)
        where go = Tuple x <$> (positional n)

    -- Generate a parser for a `Option` argument
    genParser x@(D.Option (O.Option o)) _ = (do
      scoreFromList <$> do
        if o.repeatable then (some go) else (singleton <$> go)
      <* lift (State.modify (1+))
      )
        where
          go = do
            -- Perform a pre-cursory test in order to capture relevant error
            -- messags which would otherwise be overriden (e.g. a meaningful
            -- error message when trying to match a LOpt against a LOpt would
            -- be overridden by a meaningless try to match a SOpt against a
            -- a LOpt).
            isLopt <- P.option false (P.lookAhead $ P.try $ token isAnyLopt)
            isSopt <- P.option false (P.lookAhead $ P.try $ token isAnySopt)
            if isLopt
               then P.try $ Tuple x <$> mkLoptParser o.name o.arg
               else if isSopt
                then P.try $ Tuple x <$> mkSoptParser o.flag o.arg
                else P.fail "long or short option"

          isAnyLopt (LOpt _ _) = return true
          isAnyLopt _          = return false

          isAnySopt (SOpt _ _ _) = return true
          isAnySopt _            = return false

          mkLoptParser (Just n) a = longOption n a
          mkLoptParser Nothing _  = P.fail "long name"

          mkSoptParser (Just f) a = shortOption f a
          mkSoptParser Nothing _  = P.fail "flag"

    genParser x@(D.Group optional bs r) _
      | optional && optsFirst && (length bs == 1) &&
        all (\(D.Branch xs) ->
          case xs of
            Cons (D.Positional n r') Nil -> r' || r
            _                            -> false
        ) bs
      = terminate (LU.head (D.runBranch (LU.head bs)))

    -- Generate a parser for an argument `Group`
    -- The total score a group is the sum of all scores inside of it.
    genParser x@(D.Group optional bs repeated) canSkip = do
      vs <- concat <$>
          let mod    = if optional then P.try >>> P.option mempty else \p -> p
              parser = if repeated then goR else singleton <$> go
          in mod parser
      return $ scoreFromList vs
      where
        goR :: Parser (List (List ValueMapping))
        goR = do
          {score, result} <- unScoredResult
            <$> genBranchesParser bs
                                  false
                                  false
                                  -- always allow skipping for non-free groups.
                                  (not (isFree x) || canSkip)

          if score == 0
              then return $ singleton (snd result)
              else do
                xs <- goR <|> pure Nil
                return $ (snd result) : xs

        go :: Parser (List ValueMapping)
        go = if length bs == 0
                  then return mempty
                  else do
                    snd <<< _.result <<<  unScoredResult
                      <$> genBranchesParser bs
                                            false
                                            false
                                            -- always allow skipping for
                                            -- non-free groups.
                                            (not (isFree x) || canSkip)

    isFree :: D.Argument -> Boolean
    isFree (D.Option _)                                           = true
    isFree (D.Group _ bs _) | all (all isFree <<< D.runBranch) bs = true
    isFree _                                                      = false


Remove old signer when loaded new file

Remove old signer when loaded new file

module App.Events.Foldp where

import Prelude

import App.Events.Effects (fetchSigners, processNewFile)
import App.Events.Types (Event(..))
import App.Hash.Proofs (fetchProof)
import App.Hash.Types (HashSigner(HashSigner, NoSigner), allProofMethods)
import App.Hash.Worker (WORKER)
import App.State (ProofState(..), State, fileResult, fileSigner, signerProofs, signerProp)
import Control.Monad.Aff.Console (CONSOLE, log)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Now (NOW)
import Control.Monad.Eff.Random (RANDOM)
import DOM (DOM)
import DOM.Event.Event (preventDefault)
import Data.Either (either)
import Data.Lens ((%~), (.~))
import Data.Map (empty, insert)
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse)
import Network.HTTP.Affjax (AJAX)
import Pux (EffModel, noEffects, onlyEffects)

type AppEffects = (
    console :: CONSOLE,
    dom :: DOM,
    now :: NOW,
    worker :: WORKER,
    ajax :: AJAX,
    random :: RANDOM
)

foldp ::
  Event ->
  State ->
  EffModel State Event AppEffects

foldp NoOp state = noEffects $ state

foldp (PreventDefault next event) state =
  { state
  , effects: [
    do
      liftEff $ preventDefault event
      pure $ Just $ next
    ]
  }

foldp NoFile state = noEffects $ state { file = Nothing }

foldp (NewFile file) state =
  { state: state {
       file = Just {
          meta: file
          , result: Nothing
          , signer: Nothing
          }
       , signer = Nothing
       }
  , effects: [ processNewFile file ]
  }

foldp (FileError err) state =
  onlyEffects state $ [ (traverse log err) *> pure Nothing ]

foldp (HashCalculated event) state =
  { state: (fileResult .~ Just event) state
  , effects: [ fetchSigners event.hash ]
  }

foldp (SignerFetched NoSigner) state =
  noEffects $ fileSigner .~ Just NoSigner $ state
foldp (SignerFetched (HashSigner address)) state =
  { state: updateSigner <<< updateFileSigner $ state
  , effects: pure <$> Just <$> (FetchProof address) <$> allProofMethods
  }
  where
    updateSigner = (signerProp .~ Just { address, proofs: empty })
    updateFileSigner = (fileSigner .~ (Just $ HashSigner address))

foldp (FetchProof address method) state =
  { state: signerProofs %~ insertProof $ state
  , effects: [fetchProofEffect]
  }
  where
    insertProof = insert method Pending
    fetchProofEffect = do
      proof <- fetchProof address method
      pure $ Just $
        either
        (ProofFetchingError address method)
        (ProofFetched address method)
        proof

foldp (ProofFetched address method proof) state =
  noEffects $ signerProofs %~ updateProof $ state
  where
    updateProof = insert method $ Finished proof

foldp (ProofFetchingError address method error) state =
  { state: signerProofs %~ setError $ state,
    effects: [ (log $ show error) *> pure Nothing ] }
  where
    setError = insert method NetworkError

module App.Events.Foldp where

import Prelude

import App.Events.Effects (fetchSigners, processNewFile)
import App.Events.Types (Event(..))
import App.Hash.Proofs (fetchProof)
import App.Hash.Types (HashSigner(HashSigner, NoSigner), allProofMethods)
import App.Hash.Worker (WORKER)
import App.State (ProofState(..), State, fileResult, fileSigner, signerProofs, signerProp)
import Control.Monad.Aff.Console (CONSOLE, log)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Now (NOW)
import Control.Monad.Eff.Random (RANDOM)
import DOM (DOM)
import DOM.Event.Event (preventDefault)
import Data.Either (either)
import Data.Lens ((%~), (.~))
import Data.Map (empty, insert)
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse)
import Network.HTTP.Affjax (AJAX)
import Pux (EffModel, noEffects, onlyEffects)

type AppEffects = (
    console :: CONSOLE,
    dom :: DOM,
    now :: NOW,
    worker :: WORKER,
    ajax :: AJAX,
    random :: RANDOM
)

foldp ::
  Event ->
  State ->
  EffModel State Event AppEffects

foldp NoOp state = noEffects $ state

foldp (PreventDefault next event) state =
  { state
  , effects: [
    do
      liftEff $ preventDefault event
      pure $ Just $ next
    ]
  }

foldp NoFile state = noEffects $ state { file = Nothing }

foldp (NewFile file) state =
  { state: state {
       file = Just {
          meta: file
          , result: Nothing
          , signer: Nothing
          }
       }
  , effects: [ processNewFile file ]
  }

foldp (FileError err) state =
  onlyEffects state $ [ (traverse log err) *> pure Nothing ]

foldp (HashCalculated event) state =
  { state: (fileResult .~ Just event) state
  , effects: [ fetchSigners event.hash ]
  }

foldp (SignerFetched NoSigner) state =
  noEffects $ fileSigner .~ Just NoSigner $ state
foldp (SignerFetched (HashSigner address)) state =
  { state: updateSigner <<< updateFileSigner $ state
  , effects: pure <$> Just <$> (FetchProof address) <$> allProofMethods
  }
  where
    updateSigner = (signerProp .~ Just { address, proofs: empty })
    updateFileSigner = (fileSigner .~ (Just $ HashSigner address))

foldp (FetchProof address method) state =
  { state: signerProofs %~ insertProof $ state
  , effects: [fetchProofEffect]
  }
  where
    insertProof = insert method Pending
    fetchProofEffect = do
      proof <- fetchProof address method
      pure $ Just $
        either
        (ProofFetchingError address method)
        (ProofFetched address method)
        proof

foldp (ProofFetched address method proof) state =
  noEffects $ signerProofs %~ updateProof $ state
  where
    updateProof = insert method $ Finished proof

foldp (ProofFetchingError address method error) state =
  { state: signerProofs %~ setError $ state,
    effects: [ (log $ show error) *> pure Nothing ] }
  where
    setError = insert method NetworkError


Use triple quotes

Use triple quotes

module VirtualDOM.VTree
  ( VTree()
  , TagName()
  , Key()
  , Namespace()
  , vnode
  , vtext
  ) where

import Data.Function
import Data.Maybe

foreign import data VTree :: *

foreign import showVTreeImpl
  "var showVTreeImpl = JSON.stringify;" :: VTree -> String

instance showVTree :: Show VTree where
  show = showVTreeImpl

type TagName = String
type Key = String
type Namespace = String

foreign import unsafeNull
  "var unsafeNull = null;" :: forall a. a

foreign import vnode' """
  var vnode$prime = (function() {
    var VNode = require('vtree/vnode');
    return function (name, props, children, key, ns) {
      return new VNode(name, props, children, key, ns);
    };
  }());
  """ :: forall props. Fn5 TagName { | props } [VTree] Key Namespace VTree

vnode :: forall props. TagName -> { | props } -> [VTree] -> Maybe Key -> Maybe Namespace -> VTree
vnode name props children key ns =
  runFn5 vnode' name props children (fromMaybe unsafeNull key) (fromMaybe unsafeNull ns)

foreign import vtext """
  var vtext = (function() {
    var VText = require('vtree/vtext');
    return function (text) {
      return new VText(text);
    };
  }());
  """ :: String -> VTree

module VirtualDOM.VTree
  ( VTree()
  , TagName()
  , Key()
  , Namespace()
  , vnode
  , vtext
  ) where

import Data.Function
import Data.Maybe

foreign import data VTree :: *

foreign import showVTreeImpl
  "var showVTreeImpl = JSON.stringify;" :: VTree -> String

instance showVTree :: Show VTree where
  show = showVTreeImpl

type TagName = String
type Key = String
type Namespace = String

foreign import unsafeNull
  "var unsafeNull = null;" :: forall a. a

foreign import vnode'
  "var vnode$prime = (function() {\
  \  var VNode = require('vtree/vnode');\
  \  return function  (name, props, children, key, ns) {\
  \    return new VNode(name, props, children, key, ns);\
  \  };\
  \}());" :: forall props. Fn5 TagName { | props } [VTree] Key Namespace VTree

vnode :: forall props. TagName -> { | props } -> [VTree] -> Maybe Key -> Maybe Namespace -> VTree
vnode name props children key ns =
  runFn5 vnode' name props children (fromMaybe unsafeNull key) (fromMaybe unsafeNull ns)

foreign import vtext
  "var vtext = (function() {\
  \  var VText = require('vtree/vtext');\
  \  return function  (text) {\
  \    return new VText(text);\
  \  };\
  \}());" :: String -> VTree