Hopefully fixed telegram links too?

Hopefully fixed telegram links too?

module Gonimo.UI.Invite where

import Gonimo.UI.Html
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.Html as Html
import Gonimo.WebAPI.Types as WebAPI
import Pux.Html.Attributes as A
import Pux.Html.Attributes.Aria as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Apply ((*>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.IO (IO)
import Control.Monad.Reader.Class (ask)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (get, modify)
import Data.Either (Either(Right, Left))
import Data.Generic (gShow)
import Data.Maybe (isJust, isNothing, Maybe(..))
import Data.Tuple (uncurry, Tuple(Tuple))
import Global (encodeURIComponent, encodeURI)
import Gonimo.Client.Types (Settings, GonimoError, Gonimo, class ReportErrorAction)
import Gonimo.Pux (noEffects, onlyModify, Update, runGonimo, class MonadComponent)
import Gonimo.Server.DbEntities (Invitation(Invitation), Family(Family))
import Gonimo.Server.Types (InvitationDelivery(EmailInvitation), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Key(Key), Secret(Secret))
import Gonimo.WebAPI (postInvitationsOutbox, postInvitationsByFamilyId, postFamilies, SPParams_(SPParams_), postAccounts, postFunnyName)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (a, button, br, i, input, p, h1, h2, h3, text, span, Html, img, div, small, li, ul, nav)
import Pux.Html.Attributes (offset)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (gDefaultEncodeURLPiece, defaultSettings, SPSettings_(SPSettings_))
import Signal (constant, Signal)
import Prelude hiding (div)

type Props ps = { settings  :: Settings
                , rFamilyId :: Key Family
                , rFamily   :: Family
                , baseURL :: String
                | ps
                }

type State =
  { email          :: String
  , invitationSent :: Boolean
  , invitationId   :: Key Invitation
  , invitation   :: Invitation
  }

-- | We take our props in init to ensure the caller takes care of providing proper props.
--   Ensuring this on the first call to update is a tad to late.
init :: forall ps. Tuple (Key Invitation) Invitation -> Props ps -> State
init (Tuple invKey inv) _ = { email : ""
                            , invitationSent : false
                            , invitationId : invKey
                            , invitation : inv
                            }

data Action = SetEmail String
            | SendInvitation
            | InvitationSent
            | ReportError GonimoError
            | MakeNewInvitation
            | SetInvitationData (Key Invitation) Invitation
            | GoToOverview
            | GoToBabyStation
            | Nop

instance reportErrorActionAction :: ReportErrorAction Action where
  reportError = ReportError

update :: forall ps. Update (Props ps) State Action
update action = case action of
  (SetEmail email )         -> onlyModify $ _ { email = email, invitationSent = false }
  InvitationSent            -> handleInvitationSent
  SendInvitation            -> handleSendInvitation
  MakeNewInvitation         -> handleMakeNewInvitation
  SetInvitationData id' inv -> onlyModify $ \state -> state { invitationId = id', invitation = inv }
  GoToOverview              -> noEffects
  GoToBabyStation           -> noEffects
  ReportError err           -> noEffects
  Nop                       -> noEffects

makeInviteLink :: String -> Invitation -> String
makeInviteLink baseURL (Invitation inv) = baseURL <> "?" <> "acceptInvitation="
                                          <> gDefaultEncodeURLPiece inv.invitationSecret

handleInvitationSent :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleInvitationSent = do
  modify $ _ { invitationSent = true }
  pure [ pure MakeNewInvitation ] -- Prevent user from re-using the already sent invitation

handleMakeNewInvitation :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleMakeNewInvitation = do
  props <- ask
  runGonimo $ uncurry SetInvitationData <$> postInvitationsByFamilyId props.rFamilyId

handleSendInvitation :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleSendInvitation = do
  state <- get
  runGonimo $ do
    postInvitationsOutbox $ WebAPI.SendInvitation state.invitationId (EmailInvitation state.email)
    pure InvitationSent

--------------------------------------------------------------------------------

view :: forall ps. Props ps -> State -> Html Action
view props state =
    let invitationLink = makeInviteLink (props.baseURL) state.invitation
        escapedLink = encodeURIComponent invitationLink
     in div []
                   [ div [A.className "page-header"]
                     [ div [ A.className "container"
                           , A.style [Tuple "width" "100%"]]
                       [ h3 [] [ text "Device Management"
                               , br [] []
                               , small []
                                 [ text $ "Here you can add new devices to your"
                                       <> " families, you only have to visit the"
                                       <> " following one-time link on another device." ]
                               ]
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "copy & paste"]
                     , div [A.className "jumbotron"]
                       [ p [] [ text $ "You can either copy & paste it in to your"
                                    <> " favourite messenger (e.g. WhatsApp) to"
                                    <> " send it."
                              ]
                       , div [ A.className "input-group" ]
                           [ span [ A.className "input-group-addon glyphicon glyphicon-copy", A.id_ "sdflkjsll291" ]
                             []
                           , input [ A.type_ "text", A.className "form-control", A.readOnly true
                                   , A.value invitationLink
                                   ] []
                           ]
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "Share it"]
                     , div [A.className "jumbotron"]
                       [ p [] [ text $ "Or you can share it directly with WhatsApp, Telegram .."
                              ]
                       , p []
                         [
                           H.a [ A.href $ "whatsapp://send?text=" <> escapedLink
                               ] [ H.text "Whatsapp" ]
                         , H.text " "
                         , H.a [ A.href $ "tg://msg?text=" <> escapedLink
                               ] [ H.text "Telegram" ]
                         ]
                       ]
                     ]
                   , div [A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "email"]
                     , div [A.className "jumbotron"]
                       [ p []  [ text "Or you can let us do the work send it via email …"
                               ]
                       , div [ E.onKeyUp handleEnter ]
                         [ div [A.className "input-group"]
                           [ span [A.className "input-group-addon glyphicon glyphicon-envelope"] []
                           , input [ A.type_ "text"
                                   , A.className "form-control"
                                   , A.placeholder "mail@example.com"
                                   , E.onInput $ \ev -> SetEmail ev.target.value
                                   , A.value state.email
                                   ] []
                           ]
                         ]
                       , button [ A.className "btn btn-block btn-info"
                                 , A.style [Tuple "margin-left" "0px"]
                                 , A.type_ "button"
                                 , E.onClick $ const $ SendInvitation
                                 ]
                         [ text " Send Invitation! "
                         , span [A.className "glyphicon glyphicon-send"] []
                         ]
                       , if state.invitationSent
                         then div [ A.className "alert alert-success"]
                              [ h3 [] [text $ "Invitation sent successfully to '"
                                           <> state.email <> "'!"
                                      , br [] []
                                      , small [] [text $ "But don't forget to add"
                                            <> " 'noreply@gonimo.com' to your address book,"
                                            <> " otherwise this invitation might end up in"
                                            <> " your spam-folder!"]
                                      ]
                              , button [ A.className "btn btn-block btn-default"
                                       , A.style [Tuple "margin-left" "0px"] ]
                                [ text $ "Oops - Did you send the invitation to the wrong recipient?"
                                , br [] []
                                , text "No problem just click me and then and then 'decline' to invalidate the link."
                                , br [] []
                                , br [] []
                                , text "TODO: how to preserve the previous one time link?"
                                ]
                              ]
                         else span [] []
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                       [ text "Invitation successfully transmitted? Then go back to overview or make this device a baby station right away .... " ]
                   , nav []
                     [ ul [ A.className "pager" ]
                       [ li [ A.className "previous"
                            , E.onClick $ const $ GoToOverview
                            ] [a [] [ span [A.ariaHidden "true"] [text "← "]
                                    , text "Back to Overview"
                                    ]
                              ]
                       , li [ A.className "next"
                            , E.onClick $ const $ GoToBabyStation
                            ] [ a [] [ text "Make this device a baby station"
                                     , span [A.ariaHidden "true"] [text " →"]
                                     ]
                              ]
                       ]

                     ]
                   , div [A.className "jumbotron"]
                      [ div [A.className "container"]
                        [ p [] [ text "Want to add another device?" ]
                        , button [ A.className "btn btn-block btn-info"
                                 , A.style [Tuple "margin-left" "0px"]
                                 , A.type_ "button"
                                 , E.onClick $ const $ MakeNewInvitation
                                 ]
                          [ span [ A.className "glyphicon glyphicon-repeat"] []
                          , text " Generate new one-time link "
                          ]
                        ]
                      ]
                    ]
  where
    handleEnter :: E.KeyboardEvent -> Action
    handleEnter ev = if ev.keyCode == 13 then SendInvitation else Nop

viewSent :: State -> Html Action
viewSent state = viewLogo $ text "Invitation sucessfully sent!"

module Gonimo.UI.Invite where

import Gonimo.UI.Html
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.Html as Html
import Gonimo.WebAPI.Types as WebAPI
import Pux.Html.Attributes as A
import Pux.Html.Attributes.Aria as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Apply ((*>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.IO (IO)
import Control.Monad.Reader.Class (ask)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (get, modify)
import Data.Either (Either(Right, Left))
import Data.Generic (gShow)
import Data.Maybe (isJust, isNothing, Maybe(..))
import Data.Tuple (uncurry, Tuple(Tuple))
import Global (encodeURIComponent, encodeURI)
import Gonimo.Client.Types (Settings, GonimoError, Gonimo, class ReportErrorAction)
import Gonimo.Pux (noEffects, onlyModify, Update, runGonimo, class MonadComponent)
import Gonimo.Server.DbEntities (Invitation(Invitation), Family(Family))
import Gonimo.Server.Types (InvitationDelivery(EmailInvitation), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Key(Key), Secret(Secret))
import Gonimo.WebAPI (postInvitationsOutbox, postInvitationsByFamilyId, postFamilies, SPParams_(SPParams_), postAccounts, postFunnyName)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (a, button, br, i, input, p, h1, h2, h3, text, span, Html, img, div, small, li, ul, nav)
import Pux.Html.Attributes (offset)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (gDefaultEncodeURLPiece, defaultSettings, SPSettings_(SPSettings_))
import Signal (constant, Signal)
import Prelude hiding (div)

type Props ps = { settings  :: Settings
                , rFamilyId :: Key Family
                , rFamily   :: Family
                , baseURL :: String
                | ps
                }

type State =
  { email          :: String
  , invitationSent :: Boolean
  , invitationId   :: Key Invitation
  , invitation   :: Invitation
  }

-- | We take our props in init to ensure the caller takes care of providing proper props.
--   Ensuring this on the first call to update is a tad to late.
init :: forall ps. Tuple (Key Invitation) Invitation -> Props ps -> State
init (Tuple invKey inv) _ = { email : ""
                            , invitationSent : false
                            , invitationId : invKey
                            , invitation : inv
                            }

data Action = SetEmail String
            | SendInvitation
            | InvitationSent
            | ReportError GonimoError
            | MakeNewInvitation
            | SetInvitationData (Key Invitation) Invitation
            | GoToOverview
            | GoToBabyStation
            | Nop

instance reportErrorActionAction :: ReportErrorAction Action where
  reportError = ReportError

update :: forall ps. Update (Props ps) State Action
update action = case action of
  (SetEmail email )         -> onlyModify $ _ { email = email, invitationSent = false }
  InvitationSent            -> handleInvitationSent
  SendInvitation            -> handleSendInvitation
  MakeNewInvitation         -> handleMakeNewInvitation
  SetInvitationData id' inv -> onlyModify $ \state -> state { invitationId = id', invitation = inv }
  GoToOverview              -> noEffects
  GoToBabyStation           -> noEffects
  ReportError err           -> noEffects
  Nop                       -> noEffects

makeInviteLink :: String -> Invitation -> String
makeInviteLink baseURL (Invitation inv) = baseURL <> "?" <> "acceptInvitation="
                                          <> gDefaultEncodeURLPiece inv.invitationSecret

handleInvitationSent :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleInvitationSent = do
  modify $ _ { invitationSent = true }
  pure [ pure MakeNewInvitation ] -- Prevent user from re-using the already sent invitation

handleMakeNewInvitation :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleMakeNewInvitation = do
  props <- ask
  runGonimo $ uncurry SetInvitationData <$> postInvitationsByFamilyId props.rFamilyId

handleSendInvitation :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleSendInvitation = do
  state <- get
  runGonimo $ do
    postInvitationsOutbox $ WebAPI.SendInvitation state.invitationId (EmailInvitation state.email)
    pure InvitationSent

--------------------------------------------------------------------------------

view :: forall ps. Props ps -> State -> Html Action
view props state =
    let invitationLink = makeInviteLink (props.baseURL) state.invitation
        escapedLink = encodeURIComponent invitationLink
     in div []
                   [ div [A.className "page-header"]
                     [ div [ A.className "container"
                           , A.style [Tuple "width" "100%"]]
                       [ h3 [] [ text "Device Management"
                               , br [] []
                               , small []
                                 [ text $ "Here you can add new devices to your"
                                       <> " families, you only have to visit the"
                                       <> " following one-time link on another device." ]
                               ]
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "copy & paste"]
                     , div [A.className "jumbotron"]
                       [ p [] [ text $ "You can either copy & paste it in to your"
                                    <> " favourite messenger (e.g. WhatsApp) to"
                                    <> " send it."
                              ]
                       , div [ A.className "input-group" ]
                           [ span [ A.className "input-group-addon glyphicon glyphicon-copy", A.id_ "sdflkjsll291" ]
                             []
                           , input [ A.type_ "text", A.className "form-control", A.readOnly true
                                   , A.value invitationLink
                                   ] []
                           ]
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "Share it"]
                     , div [A.className "jumbotron"]
                       [ p [] [ text $ "Or you can share it directly with WhatsApp, Telegram .."
                              ]
                       , p []
                         [
                           H.a [ A.href $ "whatsapp://send?text=" <> escapedLink
                               ] [ H.text "Whatsapp" ]
                         , H.text " "
                         , H.a [ A.href $ "tg://send?text=" <> escapedLink
                               ] [ H.text "Telegram" ]
                         ]
                       ]
                     ]
                   , div [A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "email"]
                     , div [A.className "jumbotron"]
                       [ p []  [ text "Or you can let us do the work send it via email …"
                               ]
                       , div [ E.onKeyUp handleEnter ]
                         [ div [A.className "input-group"]
                           [ span [A.className "input-group-addon glyphicon glyphicon-envelope"] []
                           , input [ A.type_ "text"
                                   , A.className "form-control"
                                   , A.placeholder "mail@example.com"
                                   , E.onInput $ \ev -> SetEmail ev.target.value
                                   , A.value state.email
                                   ] []
                           ]
                         ]
                       , button [ A.className "btn btn-block btn-info"
                                 , A.style [Tuple "margin-left" "0px"]
                                 , A.type_ "button"
                                 , E.onClick $ const $ SendInvitation
                                 ]
                         [ text " Send Invitation! "
                         , span [A.className "glyphicon glyphicon-send"] []
                         ]
                       , if state.invitationSent
                         then div [ A.className "alert alert-success"]
                              [ h3 [] [text $ "Invitation sent successfully to '"
                                           <> state.email <> "'!"
                                      , br [] []
                                      , small [] [text $ "But don't forget to add"
                                            <> " 'noreply@gonimo.com' to your address book,"
                                            <> " otherwise this invitation might end up in"
                                            <> " your spam-folder!"]
                                      ]
                              , button [ A.className "btn btn-block btn-default"
                                       , A.style [Tuple "margin-left" "0px"] ]
                                [ text $ "Oops - Did you send the invitation to the wrong recipient?"
                                , br [] []
                                , text "No problem just click me and then and then 'decline' to invalidate the link."
                                , br [] []
                                , br [] []
                                , text "TODO: how to preserve the previous one time link?"
                                ]
                              ]
                         else span [] []
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                       [ text "Invitation successfully transmitted? Then go back to overview or make this device a baby station right away .... " ]
                   , nav []
                     [ ul [ A.className "pager" ]
                       [ li [ A.className "previous"
                            , E.onClick $ const $ GoToOverview
                            ] [a [] [ span [A.ariaHidden "true"] [text "← "]
                                    , text "Back to Overview"
                                    ]
                              ]
                       , li [ A.className "next"
                            , E.onClick $ const $ GoToBabyStation
                            ] [ a [] [ text "Make this device a baby station"
                                     , span [A.ariaHidden "true"] [text " →"]
                                     ]
                              ]
                       ]

                     ]
                   , div [A.className "jumbotron"]
                      [ div [A.className "container"]
                        [ p [] [ text "Want to add another device?" ]
                        , button [ A.className "btn btn-block btn-info"
                                 , A.style [Tuple "margin-left" "0px"]
                                 , A.type_ "button"
                                 , E.onClick $ const $ MakeNewInvitation
                                 ]
                          [ span [ A.className "glyphicon glyphicon-repeat"] []
                          , text " Generate new one-time link "
                          ]
                        ]
                      ]
                    ]
  where
    handleEnter :: E.KeyboardEvent -> Action
    handleEnter ev = if ev.keyCode == 13 then SendInvitation else Nop

viewSent :: State -> Html Action
viewSent state = viewLogo $ text "Invitation sucessfully sent!"


checkpoint

checkpoint

module Content.Markdown (proto) where

-- import Text.Markdown.SlamDown
-- import Text.Markdown.SlamDown.Parser

import Prelude (Unit)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)

proto :: ∀ fx. Eff ( console :: CONSOLE | fx ) Unit
proto = do
  log "hi"

error: pathspec 'src/content/Markdown.purs' did not match any file(s) known to git


Adding support for HTML element generation

module Element (genCardCheckbox, genCardEntryColumn, genPlayerRow) where

import Control.Monad.Eff(Eff(..))
import Control.Monad.JQuery(append, create, find, JQuery(..), remove, removeClass)

import DOM(DOM(..))
import JQueryUI(attrStr, click, load, replaceWith)
import StringUtils(slugify, toLowerCase)

(|>) a f = f a

genCardCheckbox :: forall eff. String -> Boolean -> Eff (dom :: DOM | eff) JQuery
genCardCheckbox cardname isEnabled = create html
  where
    name    = slugify cardname
    checked = if isEnabled then " checked" else ""
    html    =
      """
      <input type="checkbox" id='check-""" ++ name ++ """' name="version" class='check-button version-button dynamic-check-button'""" ++ checked ++ """/>
      """ ++ cardname ++ """
      """

genCardEntryColumn :: forall eff. String -> String -> String -> String -> Eff (dom :: DOM | eff) JQuery
genCardEntryColumn name id url faction = do
    column    <- create "	"
    cardEntry <- genCardEntry name id url faction
    append cardEntry column

genPlayerRow :: forall eff. String -> String -> String -> (JQuery -> Eff (dom :: DOM| eff) JQuery) -> Eff (dom :: DOM | eff) JQuery
genPlayerRow name id imgID onClickF = do
    imgJQ          <- create imgHTML
    clickableImgJQ <- click onClickF imgJQ
    elemJQ         <- create elemHTML
    findAndReplace ".placeholder" clickableImgJQ elemJQ
  where
    imgHTML      = ""
    elemHTML =
      """

                  """ ++ name ++ """

      """

genCardEntry :: forall eff. String -> String -> String -> String -> Eff (dom :: DOM | eff) JQuery
genCardEntry name id url faction = do
    jq     <- create html
    imgJQ  <- genCardImage id url faction
    textJQ <- genCardText name
    r1     <- findAndReplace imgHolderClass imgJQ jq
    findAndReplace textHolderClass textJQ r1
  where
    imgHolderClass  = ".img-placeholder"
    textHolderClass = ".text-placeholder"
    html            =
      """

      """

genCardImage :: forall eff. String -> String -> String -> Eff (dom :: DOM | eff) JQuery
genCardImage id url faction = do
    jq      <- create ""
    animJQ  <- genLoadingAnim id bgClass
    imgJQ   <- genCardCoreImage id url animJQ bgClass
    withImg <- append imgJQ jq
    append animJQ withImg
  where
    bgClass = faction |> (toLowerCase >>> (\x -> x ++ "-backgrounded"))

genCardText :: forall eff. String -> Eff (dom :: DOM | eff) JQuery
genCardText text = create html
  where
    html =
      """

            """ ++ text ++ """

      """

genCardCoreImage :: forall eff. String -> String -> JQuery -> String -> Eff (dom :: DOM | eff) JQuery
genCardCoreImage id url anim bgClass = do
    jq <- create html
    load loadFunc jq
  where
    html      = ""
    domCopyOf elem = do
      soulmateID <- attrStr "id" elem
      create $ "#" ++ soulmateID
    loadFunc this = do
      a <- domCopyOf anim
      remove a
      t <- domCopyOf this
      removeClass "hidden" t

genLoadingAnim :: forall eff. String -> String -> Eff (dom :: DOM | eff) JQuery
genLoadingAnim idBasis bgClass = create html
  where
    id   = idBasis ++ "-loading"
    html =
      """

      """

findAndReplace :: forall eff. String -> JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery
findAndReplace findTerm replaceTerm root = do
  found <- find findTerm root
  replaceWith replaceTerm found

error: pathspec 'src/client/js/Element.purs' did not match any file(s) known to git


Copy Prelude over

Copy Prelude over

module Prelude
  ( flip
  , const
  , asTypeOf
  , Semigroupoid, (<<<), (>>>)
  , Category, id
  , ($), (#)
  , (:), cons
  , Show, show
  , Functor, (<$>)
  , Apply, (<*>)
  , Applicative, pure, liftA1
  , Alternative, empty, (<|>)
  , Bind, (>>=)
  , Monad, return, liftM1, ap
  , Num, (+), (-), (*), (/), (%)
  , negate
  , Eq, (==), (/=), refEq, refIneq
  , Ord, Ordering(..), compare, (<), (>), (<=), (>=)
  , Bits, (&), (|), (^), shl, shr, zshr, complement
  , BoolLike, (&&), (||)
  , not
  , Semigroup, (<>), (++)
  , Unit(..), unit
  ) where

  flip :: forall a b c. (a -> b -> c) -> b -> a -> c
  flip f b a = f a b

  const :: forall a b. a -> b -> a
  const a _ = a

  asTypeOf :: forall a. a -> a -> a
  asTypeOf x _ = x

  infixr 9 >>>
  infixr 9 <<<

  class Semigroupoid a where
    (<<<) :: forall b c d. a c d -> a b c -> a b d

  instance semigroupoidArr :: Semigroupoid (->) where
    (<<<) f g x = f (g x)

  (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
  (>>>) f g = g <<< f

  class (Semigroupoid a) <= Category a where
    id :: forall t. a t t

  instance categoryArr :: Category (->) where
    id x = x

  infixr 0 $
  infixl 0 #

  ($) :: forall a b. (a -> b) -> a -> b
  ($) f x = f x

  (#) :: forall a b. a -> (a -> b) -> b
  (#) x f = f x

  infixr 6 :

  (:) :: forall a. a -> [a] -> [a]
  (:) = cons

  foreign import cons
    "function cons(e) {\
    \  return function (l) {\
    \    return [e].concat(l);\
    \  };\
    \}" :: forall a. a -> [a] -> [a]

  class Show a where
    show :: a -> String

  foreign import showStringImpl
    "function showStringImpl(s) {\
    \  return JSON.stringify(s);\
    \}" :: String -> String

  instance showUnit :: Show Unit where
    show (Unit {}) = "Unit {}"

  instance showString :: Show String where
    show = showStringImpl

  instance showBoolean :: Show Boolean where
    show true = "true"
    show false = "false"

  foreign import showNumberImpl "function showNumberImpl(n) {\
                                \  return n.toString();\
                                \}" :: Number -> String

  instance showNumber :: Show Number where
    show = showNumberImpl

  foreign import showArrayImpl
    "function showArrayImpl (f) {\
    \  return function (xs) {\
    \    var ss = [];\
    \    for (var i = 0, l = xs.length; i < l; i++) {\
    \      ss[i] = f(xs[i]);\
    \    }\
    \    return '[' + ss.join(',') + ']';\
    \  };\
    \}" :: forall a. (a -> String) -> [a] -> String

  instance showArray :: (Show a) => Show [a] where
    show = showArrayImpl show

  infixl 4 <$>

  class Functor f where
    (<$>) :: forall a b. (a -> b) -> f a -> f b

  infixl 4 <*>

  class (Functor f) <= Apply f where
    (<*>) :: forall a b. f (a -> b) -> f a -> f b

  class (Apply f) <= Applicative f where
    pure :: forall a. a -> f a

  liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
  liftA1 f a = pure f <*> a

  infixl 3 <|>

  class Alternative f where
    empty :: forall a. f a
    (<|>) :: forall a. f a -> f a -> f a

  infixl 1 >>=

  class (Apply m) <= Bind m where
    (>>=) :: forall a b. m a -> (a -> m b) -> m b

  class (Applicative m, Bind m) <= Monad m

  return :: forall m a. (Monad m) => a -> m a
  return = pure

  liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
  liftM1 f a = do
    a' <- a
    return (f a')

  ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
  ap f a = do
    f' <- f
    a' <- a
    return (f' a')

  instance functorArr :: Functor ((->) r) where
    (<$>) = (<<<)

  instance applyArr :: Apply ((->) r) where
    (<*>) f g x = f x (g x)

  instance applicativeArr :: Applicative ((->) r) where
    pure = const

  instance bindArr :: Bind ((->) r) where
    (>>=) m f x = f (m x) x

  instance monadArr :: Monad ((->) r)

  infixl 7 *
  infixl 7 /
  infixl 7 %

  infixl 6 -
  infixl 6 +

  class Num a where
    (+) :: a -> a -> a
    (-) :: a -> a -> a
    (*) :: a -> a -> a
    (/) :: a -> a -> a
    (%) :: a -> a -> a
    negate :: a -> a

  foreign import numAdd "function numAdd(n1) {\
                        \  return function(n2) {\
                        \    return n1 + n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numSub "function numSub(n1) {\
                        \  return function(n2) {\
                        \    return n1 - n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMul "function numMul(n1) {\
                        \  return function(n2) {\
                        \    return n1 * n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numDiv "function numDiv(n1) {\
                        \  return function(n2) {\
                        \    return n1 / n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMod "function numMod(n1) {\
                        \  return function(n2) {\
                        \    return n1 % n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numNegate "function numNegate(n) {\
                           \  return -n;\
                           \}" :: Number -> Number

  instance numNumber :: Num Number where
    (+) = numAdd
    (-) = numSub
    (*) = numMul
    (/) = numDiv
    (%) = numMod
    negate = numNegate

  data Unit = Unit {}

  unit :: Unit
  unit = Unit {}

  infix 4 ==
  infix 4 /=

  class Eq a where
    (==) :: a -> a -> Boolean
    (/=) :: a -> a -> Boolean

  foreign import refEq
    "function refEq(r1) {\
    \  return function(r2) {\
    \    return r1 === r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  foreign import refIneq
    "function refIneq(r1) {\
    \  return function(r2) {\
    \    return r1 !== r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  instance eqUnit :: Eq Unit where
    (==) (Unit {}) (Unit {}) = true
    (/=) (Unit {}) (Unit {}) = false

  instance eqString :: Eq String where
    (==) = refEq
    (/=) = refIneq

  instance eqNumber :: Eq Number where
    (==) = refEq
    (/=) = refIneq

  instance eqBoolean :: Eq Boolean where
    (==) = refEq
    (/=) = refIneq

  instance eqArray :: (Eq a) => Eq [a] where
    (==) [] [] = true
    (==) (x:xs) (y:ys) = x == y && xs == ys
    (==) _ _ = false
    (/=) xs ys = not (xs == ys)

  data Ordering = LT | GT | EQ

  instance eqOrdering :: Eq Ordering where
    (==) LT LT = true
    (==) GT GT = true
    (==) EQ EQ = true
    (==) _  _  = false
    (/=) x y = not (x == y)

  instance showOrdering :: Show Ordering where
    show LT = "LT"
    show GT = "GT"
    show EQ = "EQ"

  class (Eq a) <= Ord a where
    compare :: a -> a -> Ordering

  infixl 4 <

  (<) :: forall a. (Ord a) => a -> a -> Boolean
  (<) a1 a2 = case a1 `compare` a2 of
    LT -> true
    _ -> false

  infixl 4 >

  (>) :: forall a. (Ord a) => a -> a -> Boolean
  (>) a1 a2 = case a1 `compare` a2 of
    GT -> true
    _ -> false

  infixl 4 <=

  (<=) :: forall a. (Ord a) => a -> a -> Boolean
  (<=) a1 a2 = case a1 `compare` a2 of
    GT -> false
    _ -> true

  infixl 4 >=

  (>=) :: forall a. (Ord a) => a -> a -> Boolean
  (>=) a1 a2 = case a1 `compare` a2 of
    LT -> false
    _ -> true

  foreign import unsafeCompare
    "function unsafeCompare(n1) {\
    \  return function(n2) {\
    \    return n1 < n2 ? LT : n1 > n2 ? GT : EQ;\
    \  };\
    \}" :: forall a. a -> a -> Ordering

  instance ordUnit :: Ord Unit where
    compare (Unit {}) (Unit {}) = EQ

  instance ordBoolean :: Ord Boolean where
    compare false false = EQ
    compare false true  = LT
    compare true  true  = EQ
    compare true  false = GT

  instance ordNumber :: Ord Number where
    compare = unsafeCompare

  instance ordString :: Ord String where
    compare = unsafeCompare

  instance ordArray :: (Ord a) => Ord [a] where
    compare [] [] = EQ
    compare [] _ = LT
    compare _ [] = GT
    compare (x:xs) (y:ys) = case compare x y of
      EQ -> compare xs ys
      other -> other

  infixl 10 &
  infixl 10 |
  infixl 10 ^

  class Bits b where
    (&) :: b -> b -> b
    (|) :: b -> b -> b
    (^) :: b -> b -> b
    shl :: b -> Number -> b
    shr :: b -> Number -> b
    zshr :: b -> Number -> b
    complement :: b -> b

  foreign import numShl "function numShl(n1) {\
                        \  return function(n2) {\
                        \    return n1 << n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numShr "function numShr(n1) {\
                        \  return function(n2) {\
                        \    return n1 >> n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numZshr "function numZshr(n1) {\
                          \  return function(n2) {\
                          \    return n1 >>> n2;\
                          \  };\
                          \}" :: Number -> Number -> Number

  foreign import numAnd "function numAnd(n1) {\
                        \  return function(n2) {\
                        \    return n1 & n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numOr "function numOr(n1) {\
                       \  return function(n2) {\
                       \    return n1 | n2;\
                       \  };\
                       \}" :: Number -> Number -> Number

  foreign import numXor "function numXor(n1) {\
                        \  return function(n2) {\
                        \    return n1 ^ n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numComplement "function numComplement(n) {\
                               \  return ~n;\
                               \}" :: Number -> Number

  instance bitsNumber :: Bits Number where
    (&) = numAnd
    (|) = numOr
    (^) = numXor
    shl = numShl
    shr = numShr
    zshr = numZshr
    complement = numComplement

  infixr 2 ||
  infixr 3 &&

  class BoolLike b where
    (&&) :: b -> b -> b
    (||) :: b -> b -> b
    not :: b -> b

  foreign import boolAnd "function boolAnd(b1) {\
                         \  return function(b2) {\
                         \    return b1 && b2;\
                         \  };\
                         \}"  :: Boolean -> Boolean -> Boolean

  foreign import boolOr "function boolOr(b1) {\
                        \  return function(b2) {\
                        \    return b1 || b2;\
                        \  };\
                        \}" :: Boolean -> Boolean -> Boolean

  foreign import boolNot "function boolNot(b) {\
                         \  return !b;\
                         \}" :: Boolean -> Boolean

  instance boolLikeBoolean :: BoolLike Boolean where
    (&&) = boolAnd
    (||) = boolOr
    not = boolNot

  infixr 5 <>

  class Semigroup a where
    (<>) :: a -> a -> a

  foreign import concatString
    "function concatString(s1) {\
    \  return function(s2) {\
    \    return s1 + s2;\
    \  };\
    \}" :: String -> String -> String

  instance semigroupUnit :: Semigroup Unit where
    (<>) (Unit {}) (Unit {}) = Unit {}

  instance semigroupString :: Semigroup String where
    (<>) = concatString

  instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where
    (<>) f g = \x -> f x <> g x

  infixr 5 ++

  (++) :: forall s. (Semigroup s) => s -> s -> s
  (++) = (<>)

module Data.Function where

  on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
  on f g x y = g x `f` g y

  foreign import data Fn0 :: * -> *
  foreign import data Fn1 :: * -> * -> *
  foreign import data Fn2 :: * -> * -> * -> *
  foreign import data Fn3 :: * -> * -> * -> * -> *
  foreign import data Fn4 :: * -> * -> * -> * -> * -> *
  foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *

  foreign import mkFn0
    "function mkFn0(f) {\
    \  return function() {\
    \    return f({});\
    \  };\
    \}" :: forall a. (Unit -> a) -> Fn0 a

  foreign import mkFn1
    "function mkFn1(f) {\
    \  return function(a) {\
    \    return f(a);\
    \  };\
    \}" :: forall a b. (a -> b) -> Fn1 a b

  foreign import mkFn2
    "function mkFn2(f) {\
    \  return function(a, b) {\
    \    return f(a)(b);\
    \  };\
    \}" :: forall a b c. (a -> b -> c) -> Fn2 a b c

  foreign import mkFn3
    "function mkFn3(f) {\
    \  return function(a, b, c) {\
    \    return f(a)(b)(c);\
    \  };\
    \}" :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d

  foreign import mkFn4
    "function mkFn4(f) {\
    \  return function(a, b, c, d) {\
    \    return f(a)(b)(c)(d);\
    \  };\
    \}" :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e

  foreign import mkFn5
    "function mkFn5(f) {\
    \  return function(a, b, c, d, e) {\
    \    return f(a)(b)(c)(d)(e);\
    \  };\
    \}" :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f

  foreign import runFn0
    "function runFn0(f) {\
    \  return f();\
    \}" :: forall a. Fn0 a -> a

  foreign import runFn1
    "function runFn1(f) {\
    \  return function(a) {\
    \    return f(a);\
    \  };\
    \}" :: forall a b. Fn1 a b -> a -> b

  foreign import runFn2
    "function runFn2(f) {\
    \  return function(a) {\
    \    return function(b) {\
    \      return f(a, b);\
    \    };\
    \  };\
    \}" :: forall a b c. Fn2 a b c -> a -> b -> c

  foreign import runFn3
    "function runFn3(f) {\
    \  return function(a) {\
    \    return function(b) {\
    \      return function(c) {\
    \        return f(a, b, c);\
    \      };\
    \    };\
    \  };\
    \}" :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d

  foreign import runFn4
    "function runFn4(f) {\
    \  return function(a) {\
    \    return function(b) {\
    \      return function(c) {\
    \        return function(d) {\
    \          return f(a, b, c, d);\
    \        };\
    \      };\
    \    };\
    \  };\
    \}" :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e

  foreign import runFn5
    "function runFn5(f) {\
    \  return function(a) {\
    \    return function(b) {\
    \      return function(c) {\
    \        return function(d) {\
    \          return function(e) {\
    \            return f(a, b, c, d, e);\
    \          };\
    \        };\
    \      };\
    \    };\
    \  };\
    \}" :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f

module Data.Eq where

  data Ref a = Ref a

  liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
  liftRef f (Ref x) (Ref y) = f x y

  instance eqRef :: Eq (Ref a) where
    (==) = liftRef refEq
    (/=) = liftRef refIneq

module Prelude.Unsafe where

  foreign import unsafeIndex
    "function unsafeIndex(xs) {\
    \  return function(n) {\
    \    return xs[n];\
    \  };\
    \}" :: forall a. [a] -> Number -> a

module Control.Monad.Eff where

  foreign import data Eff :: # ! -> * -> *

  foreign import returnE "function returnE(a) {\
                         \  return function() {\
                         \    return a;\
                         \  };\
                         \}" :: forall e a. a -> Eff e a

  foreign import bindE "function bindE(a) {\
                       \  return function(f) {\
                       \    return function() {\
                       \      return f(a())();\
                       \    };\
                       \  };\
                       \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

  type Pure a = forall e. Eff e a

  foreign import runPure "function runPure(f) {\
                         \  return f();\
                         \}" :: forall a. Pure a -> a

  instance functorEff :: Functor (Eff e) where
    (<$>) = liftA1

  instance applyEff :: Apply (Eff e) where
    (<*>) = ap

  instance applicativeEff :: Applicative (Eff e) where
    pure = returnE

  instance bindEff :: Bind (Eff e) where
    (>>=) = bindE

  instance monadEff :: Monad (Eff e)

  foreign import untilE "function untilE(f) {\
                        \  return function() {\
                        \    while (!f()) { }\
                        \    return {};\
                        \  };\
                        \}" :: forall e. Eff e Boolean -> Eff e {}

  foreign import whileE "function whileE(f) {\
                        \  return function(a) {\
                        \    return function() {\
                        \      while (f()) {\
                        \        a();\
                        \      }\
                        \      return {};\
                        \    };\
                        \  };\
                        \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e {}

  foreign import forE "function forE(lo) {\
                      \  return function(hi) {\
                      \    return function(f) {\
                      \      return function() {\
                      \        for (var i = lo; i < hi; i++) {\
                      \          f(i)();\
                      \        }\
                      \      };\
                      \    };\
                      \  };\
                      \}" :: forall e. Number -> Number -> (Number -> Eff e {}) -> Eff e {}

  foreign import foreachE "function foreachE(as) {\
                          \  return function(f) {\
                          \    for (var i = 0; i < as.length; i++) {\
                          \      f(as[i])();\
                          \    }\
                          \  };\
                          \}" :: forall e a. [a] -> (a -> Eff e {}) -> Eff e {}

module Control.Monad.Eff.Unsafe where

  import Control.Monad.Eff

  foreign import unsafeInterleaveEff
    "function unsafeInterleaveEff(f) {\
    \  return f;\
    \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a

module Debug.Trace where

  import Control.Monad.Eff

  foreign import data Trace :: !

  foreign import trace "function trace(s) {\
                       \  return function() {\
                       \    console.log(s);\
                       \    return {};\
                       \  };\
                       \}" :: forall r. String -> Eff (trace :: Trace | r) {}

  print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) {}
  print o = trace (show o)

module Control.Monad.ST where

  import Control.Monad.Eff

  foreign import data ST :: * -> !

  foreign import data STRef :: * -> * -> *

  foreign import data STArray :: * -> * -> *

  foreign import newSTRef "function newSTRef(val) {\
                          \  return function () {\
                          \    return { value: val };\
                          \  };\
                          \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

  foreign import readSTRef "function readSTRef(ref) {\
                           \  return function() {\
                           \    return ref.value;\
                           \  };\
                           \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

  foreign import modifySTRef "function modifySTRef(ref) {\
                             \  return function(f) {\
                             \    return function() {\
                             \      return ref.value = f(ref.value);\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

  foreign import writeSTRef "function writeSTRef(ref) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      return ref.value = a;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

  foreign import newSTArray "function newSTArray(len) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      var arr = [];\
                            \      for (var i = 0; i < len; i++) {\
                            \        arr[i] = a;\
                            \      };\
                            \      return arr;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)

  foreign import peekSTArray "function peekSTArray(arr) {\
                             \  return function(i) {\
                             \    return function() {\
                             \      return arr[i];\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Eff (st :: ST h | r) a

  foreign import pokeSTArray "function pokeSTArray(arr) {\
                             \  return function(i) {\
                             \    return function(a) {\
                             \      return function() {\
                             \        return arr[i] = a;\
                             \      };\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a

  foreign import runST "function runST(f) {\
                       \  return f;\
                       \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

  foreign import runSTArray "function runSTArray(f) {\
                            \  return f;\
                            \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]

error: pathspec 'prelude/Prelude.purs' did not match any file(s) known to git


Tests for where clauses

Tests for where clauses

module Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.ST

test1 x = y
  where
  y :: Number
  y = x + 1

test2 x y = x' + y'
  where
  x' = x + 1
  y' = y + 1

test3 = f 1 2 3
  where f x y z = x + y + z

test4 = f (+) [1, 2]
  where f x [y, z] = x y z

test5 = g 10
  where
  f x | x > 0 = g (x / 2) + 1
  f x = 0
  g x = f (x - 1) + 1

test6 = if f true then f 1 else f 2
  where f :: forall a. a -> a
        f x = x

test7 :: Number -> Number
test7 x = go x
  where
  go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y
  go y = go $ (y + x / y) / 2

main = do
  Debug.Trace.print (test1 1)
  Debug.Trace.print (test2 1 2)
  Debug.Trace.print test3
  Debug.Trace.print test4
  Debug.Trace.print test5
  Debug.Trace.print test6
  Debug.Trace.print (test7 100)

error: pathspec 'examples/passing/Where.purs' did not match any file(s) known to git


Added a 'Main' module that drives the emulator

module Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Data.Array
import Data.Either
import Control.Monad.Aff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Exception
import Network.HTTP.Affjax
import Network.HTTP.Affjax.Response
import Network.HTTP.RequestHeader
import Data.MediaType
import Data.DataView

import Loader
import Core
import Gpu
import Types
import Utils
import Debug
import MemSection as M

--TEST FROMINTARRAY AND CHANGING ITEM OF ARRAY THAT IS A MEMBER OF SOME OBJECT

{--main = do--}
  {--let arr = [0,0,0]--}
  {--arr <- getNew 3 0--}
  {--let x = { a : arr }--}
  {--val1<- M.rd8 0 x.a--}
  {--log $ show val1--}
  {--val2<- M.rd8 1 arr--}
  {--val3<- M.rd8 2 arr--}
  {--M.wr8 5 0 arr--}
  {--M.wr8 6 1 arr--}
  {--M.wr8 7 2 arr--}
  {--log $ show val1 ++ show val2 ++ show val3--}

--NOTE type a type signature once you reach a stable stage
main = launchAff $ do
  afLog "loading rom..."
  rom <- loadRom
  afLog "loaded"
  initialState <- liftEff $ reset rom
  afLog "reset finished"

  liftEff $ drive 234000 initialState

  afLog "stopped."
 where
  frameDur = 17556

drive :: forall e. Int -> Z80State
      -> Eff (canvas :: Canvas, timer :: Timer | e) Z80State
drive interval state = do
  {--isPause <- readFromEnvSomething--}
  state' <- run interval state
  if true
    then return state
    else drive interval state'

afLog :: forall e. String -> Aff (console :: CONSOLE | e) Unit
afLog x = liftEff $ log x

loadRom :: forall e. Aff (console :: CONSOLE, ajax :: AJAX | e)
           (Array I8)
loadRom = do
  res <- affjax $ defaultRequest
    { url = "/rom/tetris.gb"
    , headers = [ContentType $ MediaType "ArrayBuffer"]
    }
  let rom = fromArrayBuffer res.response
  {--liftEff $ log $ "GET /api response: "  ++ show rom--}
  return rom

error: pathspec 'src/Main.purs' did not match any file(s) known to git


Don't show yourself in overview.

Don't show yourself in overview.

module  Gonimo.UI.Overview where

import Data.Array as Arr
import Data.Array as Array
import Data.Tuple as Tuple
import Gonimo.UI.Socket as SocketC
import Gonimo.UI.Socket.Channel.Types as ChannelC
import Gonimo.UI.Socket.Types as SocketC
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import Control.Monad.Eff (Eff)
import Data.Array (concat, fromFoldable)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Tuple (uncurry, snd, fst, Tuple(..))
import Gonimo.Client.Types (Settings, BabyStationInfo)
import Gonimo.Pux (noEffects, onlyModify, Update)
import Gonimo.Server.Db.Entities (Family(Family), Device)
import Gonimo.Server.Db.Entities.Helpers (runFamily)
import Gonimo.Server.Types (DeviceType(Baby, NoBaby))
import Gonimo.Types (Key)
import Gonimo.WebAPI.Types (DeviceInfo(..))
import Prelude (class BooleanAlgebra)
import Pux.Html (span, text, button, div, Html)
import Pux.Html.Attributes (letterSpacing)
import Prelude hiding (div)

type Props ps = { settings      :: Settings
                , family        :: Maybe Family
                , deviceId      :: Key Device
                , onlineStatus  :: DeviceType
                , onlineDevices :: Array (Tuple (Key Device) DeviceType)
                , deviceInfos   :: Array (Tuple (Key Device) DeviceInfo)
                , socketS       :: SocketC.State
                , sendActionSocket :: SocketC.Action -> Eff () Unit -- Needed for socket operations
                | ps }

type State = { newBabyName :: String }

init :: State
init = { newBabyName : "baby" }

data Action = SocketA SocketC.Action
            | SetBabyName String -- Internal: keep track of user edit
            | GoToInviteView
            | Nop

connectToBaby :: Key Device -> Action
connectToBaby = SocketA <<< SocketC.ConnectToBaby

stopBabyStation :: Action
stopBabyStation = SocketA SocketC.StopBabyStation

update :: forall ps. Update (Props ps) State Action
update (SetBabyName val) = onlyModify $ _ { newBabyName = val }
update (SocketA _)       = noEffects
update GoToInviteView    = noEffects
update Nop               = noEffects

view :: forall ps. Props ps -> State -> Html Action
view props state = div []
                   [ viewConnectedBabies props state
                   , viewAvailableBabies props state
                   , case props.onlineStatus of
                       NoBaby -> div [] []
                       Baby name -> viewOnline name
                   , div [ A.className "btn-group" ]
                     [ button [ A.className "btn btn-lg btn-block btn-info"
                              , E.onClick $ const GoToInviteView ]
                       [ text "Add Device" ]
                     ]
                   ]

type OnlineBaby =
  { babyName :: String
  , deviceName :: String
  , deviceId :: Key Device
  }

viewConnectedBabies :: forall ps. Props ps -> State -> Html Action
viewConnectedBabies props state =
  let
    parentChannels = SocketC.getParentChannels props.socketS
  in
   if Array.null parentChannels
   then span [] []
   else div [ A.className "overviewThumbnails"]
        $ viewBabyThumbnail props <$> parentChannels

viewBabyThumbnail :: forall ps. Props ps -> Tuple SocketC.ChannelId ChannelC.State -> Html Action
viewBabyThumbnail props chan@(Tuple chanId _) =
  div [ A.className "overviewThumbnail closableBox" ]
  [ H.a [ A.className "boxclose"
        , E.onClick $ const $ SocketA (SocketC.CloseChannel chanId)
        ] []
  , SocketA <$> SocketC.viewParentChannelThumb props props.socketS chan
  ]

viewAvailableBabies :: forall ps. Props ps -> State -> Html Action
viewAvailableBabies props state =
    H.div [ A.className "jumbotron" ]
    [ H.div [ A.className "container" ]
      $ [ H.h2 [] [ text "Connect to baby: " ] ]
      <> if Arr.null onlineBabies
         then
           [ H.p []
             [ H.text "Sorry no baby stations online." ]
           ]
         else
            map viewOnlineBaby onlineBabies
    ]
  where
    makeOnlineBaby :: Key Device -> String -> String -> OnlineBaby
    makeOnlineBaby deviceId deviceName babyName = { deviceId : deviceId
                                                  , deviceName : deviceName
                                                  , babyName : babyName
                                                  }
    onlineBabies :: Array OnlineBaby
    onlineBabies =
      let
        isBaby :: DeviceType -> Boolean
        isBaby t = case t of
          NoBaby -> false
          Baby _ -> true

        getBabyName :: DeviceType -> Maybe String
        getBabyName NoBaby = Nothing
        getBabyName (Baby n) = Just n

        ids = map fst
              <<< Arr.filter (isBaby <<< snd)
              <<< Arr.filter ((_ /= props.deviceId) <<< fst)
              $ props.onlineDevices
        babyNames = Arr.concatMap (fromFoldable <<< getBabyName <<< snd) props.onlineDevices
        deviceInfos = Arr.concatMap (fromFoldable <<< flip Tuple.lookup props.deviceInfos) ids
        deviceNames = map (\(DeviceInfo info) -> info.deviceInfoName) deviceInfos

      in
       Arr.zipWith (uncurry makeOnlineBaby) (Arr.zip ids deviceNames) babyNames

viewOnlineBaby :: OnlineBaby -> Html Action
viewOnlineBaby baby =
  button [ A.className "btn btn-block btn-info"
         , A.style [Tuple "margin-left" "0px"]
         , A.type_ "button"
         , E.onClick $ const $ connectToBaby baby.deviceId
         ]
  [ text $ baby.babyName <> " "
  , span [A.className "glyphicon glyphicon-transfer"] []
  , H.p []
    [ H.small [] [ text $ "on device: " <> baby.deviceName ]
    ]
  ]

viewOnline :: String -> Html Action
viewOnline name =
    H.div [ A.className "jumbotron" ]
    [ H.div [ A.className "container" ]
      [ H.h2 [] [ text $ "Baby monitor running for baby " <> name <> " ..." ]
      , button [ A.className "btn btn-block btn-danger"
               , A.style [Tuple "margin-left" "0px"]
               , A.type_ "button"
               , E.onClick $ const $ stopBabyStation
               ]
        [ text "Stop Baby Monitor "
        , span [A.className "glyphicon glyphicon-off"] []
        ]
      ]
    ]

-- wrappingBox :: (String -> Html Action) -> String -> Html Action
-- wrappingBox inner name = H.div [ E.onKeyUp handleEnter
--                                , A.style
--                                  [ Tuple "padding" "1em"
--                                  , Tuple "border-bottom" "1px solid #ccc"
--                                  ]
--                                ]
--                          [ inner name ]
  -- where
    -- handleEnter :: E.KeyboardEvent -> Action
    -- handleEnter ev = if ev.keyCode == 13 then startBabyStation name (MediaStreamConstraints { audio : true, video : true }) else Nop

-- getSubscriptions :: forall ps. Props ps -> State -> Subscriptions Action
-- getSubscriptions props _ =
--   let
--     familyId = fst <$> head state.families -- Currently we just pick the first family
--     subArray :: Array (Subscriptions Action)
--     subArray = map (flip runReader (mkSettings state.authData)) <<< concat $
--       [ [ Sub.getAccountsByAccountIdFamilies (maybe Nop SetFamilies)
--                                           (runAuthData state.authData).accountId
--         ]
--       , fromFoldable $
--         Sub.getOnlineStatusByFamilyId (maybe Nop SetOnlineDevices) <$> familyId
--       , fromFoldable $
--         Sub.getFamiliesByFamilyIdDeviceInfos (maybe Nop SetDeviceInfos) <$> familyId
--       ]
--   in
--      foldl append mempty subArray

module  Gonimo.UI.Overview where

import Data.Array as Arr
import Data.Array as Array
import Data.Tuple as Tuple
import Gonimo.UI.Socket as SocketC
import Gonimo.UI.Socket.Channel.Types as ChannelC
import Gonimo.UI.Socket.Types as SocketC
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import Control.Monad.Eff (Eff)
import Data.Array (concat, fromFoldable)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Tuple (uncurry, snd, fst, Tuple(..))
import Gonimo.Client.Types (Settings, BabyStationInfo)
import Gonimo.Pux (noEffects, onlyModify, Update)
import Gonimo.Server.Db.Entities (Family(Family), Device)
import Gonimo.Server.Db.Entities.Helpers (runFamily)
import Gonimo.Server.Types (DeviceType(Baby, NoBaby))
import Gonimo.Types (Key)
import Gonimo.WebAPI.Types (DeviceInfo(..))
import Prelude (class BooleanAlgebra)
import Pux.Html (span, text, button, div, Html)
import Pux.Html.Attributes (letterSpacing)
import Prelude hiding (div)

type Props ps = { settings      :: Settings
                , family        :: Maybe Family
                , onlineStatus  :: DeviceType
                , onlineDevices :: Array (Tuple (Key Device) DeviceType)
                , deviceInfos   :: Array (Tuple (Key Device) DeviceInfo)
                , socketS       :: SocketC.State
                , sendActionSocket :: SocketC.Action -> Eff () Unit -- Needed for socket operations
                | ps }

type State = { newBabyName :: String }

init :: State
init = { newBabyName : "baby" }

data Action = SocketA SocketC.Action
            | SetBabyName String -- Internal: keep track of user edit
            | GoToInviteView
            | Nop

connectToBaby :: Key Device -> Action
connectToBaby = SocketA <<< SocketC.ConnectToBaby

stopBabyStation :: Action
stopBabyStation = SocketA SocketC.StopBabyStation

update :: forall ps. Update (Props ps) State Action
update (SetBabyName val) = onlyModify $ _ { newBabyName = val }
update (SocketA _)       = noEffects
update GoToInviteView    = noEffects
update Nop               = noEffects

view :: forall ps. Props ps -> State -> Html Action
view props state = div []
                   [ viewConnectedBabies props state
                   , div [ A.className "btn-group" ]
                     [ button [ A.className "btn btn-lg btn-block"
                              , E.onClick $ const GoToInviteView ]
                       [ text "Add Device" ]
                     ]
                   , viewAvailableBabies props state
                   ,
                     case props.onlineStatus of
                       NoBaby -> div [] []
                       Baby name -> viewOnline name
                   ]

type OnlineBaby =
  { babyName :: String
  , deviceName :: String
  , deviceId :: Key Device
  }

viewConnectedBabies :: forall ps. Props ps -> State -> Html Action
viewConnectedBabies props state =
  let
    parentChannels = SocketC.getParentChannels props.socketS
  in
   if Array.null parentChannels
   then span [] []
   else div [ A.className "overviewThumbnails"]
        $ viewBabyThumbnail props <$> parentChannels

viewBabyThumbnail :: forall ps. Props ps -> Tuple SocketC.ChannelId ChannelC.State -> Html Action
viewBabyThumbnail props chan@(Tuple chanId _) =
  div [ A.className "overviewThumbnail closableBox" ]
  [ H.a [ A.className "boxclose"
        , E.onClick $ const $ SocketA (SocketC.CloseChannel chanId)
        ] []
  , SocketA <$> SocketC.viewParentChannelThumb props props.socketS chan
  ]

viewAvailableBabies :: forall ps. Props ps -> State -> Html Action
viewAvailableBabies props state =
    H.div [ A.className "jumbotron" ]
    [ H.div [ A.className "container" ]
      $ [ H.h2 [] [ text "Connect to baby: " ] ]
      <> if Arr.null onlineBabies
         then
           [ H.p []
             [ H.text "Sorry no baby stations online." ]
           ]
         else
            map viewOnlineBaby onlineBabies
    ]
  where
    makeOnlineBaby :: Key Device -> String -> String -> OnlineBaby
    makeOnlineBaby deviceId deviceName babyName = { deviceId : deviceId
                                                  , deviceName : deviceName
                                                  , babyName : babyName
                                                  }
    onlineBabies :: Array OnlineBaby
    onlineBabies =
      let
        isBaby :: DeviceType -> Boolean
        isBaby t = case t of
          NoBaby -> false
          Baby _ -> true

        getBabyName :: DeviceType -> Maybe String
        getBabyName NoBaby = Nothing
        getBabyName (Baby n) = Just n

        ids = map fst <<< Arr.filter (isBaby <<< snd) $ props.onlineDevices
        babyNames = Arr.concatMap (fromFoldable <<< getBabyName <<< snd) props.onlineDevices
        deviceInfos = Arr.concatMap (fromFoldable <<< flip Tuple.lookup props.deviceInfos) ids
        deviceNames = map (\(DeviceInfo info) -> info.deviceInfoName) deviceInfos

      in
       Arr.zipWith (uncurry makeOnlineBaby) (Arr.zip ids deviceNames) babyNames

viewOnlineBaby :: OnlineBaby -> Html Action
viewOnlineBaby baby =
  button [ A.className "btn btn-block btn-info"
         , A.style [Tuple "margin-left" "0px"]
         , A.type_ "button"
         , E.onClick $ const $ connectToBaby baby.deviceId
         ]
  [ text $ baby.babyName <> " "
  , span [A.className "glyphicon glyphicon-transfer"] []
  , H.p []
    [ H.small [] [ text $ "on device: " <> baby.deviceName ]
    ]
  ]

viewOnline :: String -> Html Action
viewOnline name =
    H.div [ A.className "jumbotron" ]
    [ H.div [ A.className "container" ]
      [ H.h2 [] [ text $ "Baby monitor running for baby " <> name <> " ..." ]
      , button [ A.className "btn btn-block btn-danger"
               , A.style [Tuple "margin-left" "0px"]
               , A.type_ "button"
               , E.onClick $ const $ stopBabyStation
               ]
        [ text "Stop Baby Monitor "
        , span [A.className "glyphicon glyphicon-off"] []
        ]
      ]
    ]

-- wrappingBox :: (String -> Html Action) -> String -> Html Action
-- wrappingBox inner name = H.div [ E.onKeyUp handleEnter
--                                , A.style
--                                  [ Tuple "padding" "1em"
--                                  , Tuple "border-bottom" "1px solid #ccc"
--                                  ]
--                                ]
--                          [ inner name ]
  -- where
    -- handleEnter :: E.KeyboardEvent -> Action
    -- handleEnter ev = if ev.keyCode == 13 then startBabyStation name (MediaStreamConstraints { audio : true, video : true }) else Nop

-- getSubscriptions :: forall ps. Props ps -> State -> Subscriptions Action
-- getSubscriptions props _ =
--   let
--     familyId = fst <$> head state.families -- Currently we just pick the first family
--     subArray :: Array (Subscriptions Action)
--     subArray = map (flip runReader (mkSettings state.authData)) <<< concat $
--       [ [ Sub.getAccountsByAccountIdFamilies (maybe Nop SetFamilies)
--                                           (runAuthData state.authData).accountId
--         ]
--       , fromFoldable $
--         Sub.getOnlineStatusByFamilyId (maybe Nop SetOnlineDevices) <$> familyId
--       , fromFoldable $
--         Sub.getFamiliesByFamilyIdDeviceInfos (maybe Nop SetDeviceInfos) <$> familyId
--       ]
--   in
--      foldl append mempty subArray


New error types

New error types

-- File auto generated by purescript-bridge! --
module Gonimo.Server.Error where

import Gonimo.Server.DbEntities (Family)
import Gonimo.Types (Key)

import Data.Generic (class Generic)

data ServerError =
    InvalidAuthToken
  | InvitationAlreadyClaimed
  | AlreadyFamilyMember
  | NoSuchFamily (Key Family)
  | NoSuchInvitation
  | SocketBusy
  | ChannelBusy
  | NoSuchSocket
  | NoSuchChannel
  | Forbidden
  | NotFound
  | TransactionTimeout
  | InternalServerError

derive instance genericServerError :: Generic ServerError

-- File auto generated by purescript-bridge! --
module Gonimo.Server.Error where

import Gonimo.Server.DbEntities (Family)
import Gonimo.Types (Key)

import Data.Generic (class Generic)

data ServerError =
    InvalidAuthToken
  | InvitationAlreadyClaimed
  | AlreadyFamilyMember
  | NoSuchFamily (Key Family)
  | NoSuchInvitation
  | NoSuchSocket
  | Forbidden
  | NotFound
  | TransactionTimeout

derive instance genericServerError :: Generic ServerError


Add Util module

Add Util module

module Graphics.D3.Util
  ( min
  , max
  ) where

foreign import min
  "var min = d3.min"
  :: [Number] -> Number

foreign import max
  "var max = d3.max"
  :: [Number] -> Number

error: pathspec 'src/Util.purs' did not match any file(s) known to git


Inline vars

Inline vars

module Test.Spec.ParserGenSpec (parserGenSpec) where

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

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

import Language.Docopt.Errors
import Language.Docopt.Argument
import Language.Docopt.Value
import Language.Docopt.Usage
import Language.Docopt.ParserGen (genParser, runParser)
import Language.Docopt.Argument as D
import Language.Docopt.Trans    as T
import Test.Support.Docopt      as D

data Test = Test (Array Argument) (Array Case)
data Case = Case (Array String) (Either String (Map Argument Value))

test :: Array Argument -> Array Case -> Test
test = Test

pass :: Array String -> (Array (Tuple Argument Value)) -> Case
pass i o = Case i (Right $ Map.fromList $ toList o)

fail :: Array String -> String -> Case
fail i e = Case i (Left e)

(:>) = Tuple
infixr 0 :>

parserGenSpec = \_ -> describe "The generator" do

  -- Some options that will be used for these tests
  let testCases = [

      test
        [ D.poR "qux" ]
        [ pass
            [ "a", "b", "c" ]
            [ D.poR "qux" :> D.array [ D.str "a"
                                     , D.str "b"
                                     , D.str "c"
                                     ]
            ]
        , fail [ "--foo", "baz" ]
            "Expected positional argument: \"qux...\""
        , fail
            [ "a", "--foo", "-f=10" ]
            "Trailing input: --foo, -f=10"
        ]

    , test
        [ D.poR "qux", D.eoa ]
        [ pass
            [ "a", "b", "c", "--" ]
            [ D.poR "qux" :> D.array [ D.str "a"
                                     , D.str "b"
                                     , D.str "c"
                                     ]
            , D.eoa :> D.array []
            ]
        , pass
            [ "a", "b", "c", "--", "--", "--" ]
            [ D.poR "qux" :> D.array [ D.str "a"
                                     , D.str "b"
                                     , D.str "c"
                                     ]
            , D.eoa :> D.array [ D.str "--" , D.str "--" ]
            ]
        ]

    , test
        [ D.grr false [] ]
        [ pass [] [] ]

    , test
        [ D.gro false [] ]
        [ pass [] [] ]

    , test
        [ D.opt 'h' "host" (D.oa "host[:port]"
                           (D.str "http://localhost:3000"))
        ]
        [ pass
            [ "-hhttp://localhost:5000" ]
            [ D.opt 'h'
                    "host"
                    (D.oa "host[:port]" (D.str "http://localhost:3000"))
              :> D.str "http://localhost:5000"
            ]
        ]

    , test
        [ D.grr false [[
            D.opt 'i' "input" (D.oa_ "FILE")
          ]]
        ]
        [ fail [] "Missing required options: (-i, --input=FILE)"
        , pass
            [ "-i", "bar" ]
            [ D.opt 'i' "input" (D.oa_ "FILE") :> (D.str "bar") ]
        ]

    , test
        [ D.grr false [[
            D.opt 'i' "input" (D.oa_ "FILE")
          ]]
        ]
        [ fail [] "Missing required options: (-i, --input=FILE)"
        , pass
            [ "-i", "bar" ]
            [ D.opt 'i' "input" (D.oa_ "FILE") :> (D.str "bar") ]
        ]

    , test
        [ D.grr false [[
            D.opt 'i' "input" (D.oa_ "FILE")
          ]]
        , D.opt 'o' "output" (D.oa_ "FILE")
        ]
        [ fail [] "Missing required options: -o, --output=FILE, (-i, --input=FILE)"
        , fail [ "-i", "bar" ] "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-o", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE") :> D.str "bar"
            , D.opt 'o' "output" (D.oa_ "FILE") :> D.str "bar" ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-i", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE") :> D.str "bar"
            , D.opt 'o' "output" (D.oa_ "FILE") :> D.str "bar" ]
        ]

    , test
        [ D.grr false [[
            D.grr false [[
              D.opt 'i' "input" (D.oa_ "FILE")
            ]]
          , D.opt 'r' "redirect" (D.oa_ "FILE")
          ]]
        , D.opt 'o' "output" (D.oa_ "FILE")
        ]
        [ fail []
            "Missing required options: -o, --output=FILE, ((-i, --input=FILE) -r, --redirect=FILE)"
        , fail [ "-i", "bar", "-r", "bar" ]
            "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-r", "bar", "-o", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE")   :> D.str "bar"
            , D.opt 'r' "redirect" (D.oa_ "FILE") :> D.str "bar"
            , D.opt 'o' "output" (D.oa_ "FILE")   :> D.str "bar" ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-r", "bar", "-i", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE")   :> D.str "bar"
            , D.opt 'r' "redirect" (D.oa_ "FILE") :> D.str "bar"
            , D.opt 'o' "output" (D.oa_ "FILE")   :> D.str "bar" ]
        ]

    , test
        [ D.grr false [[
            D.opt 'i' "input" (D.oa_ "FILE")
          , D.po  "env"
          ]]
        , D.opt 'o' "output" (D.oa_ "FILE")
        ]
        [ fail [] "Missing required options: -i, --input=FILE"
          -- XXX: Would be cool to show the reason the group did not parse!
        , fail [ "-i", "bar" ] "Expected positional argument: \"env\""
        , pass [ "-i", "bar", "x", "-o", "bar" ]
            [ D.opt 'i' "input"  (D.oa_ "FILE") :> D.str "bar"
            , D.po  "env"                       :> D.str "x"
            , D.opt 'o' "output" (D.oa_ "FILE") :> D.str "bar" ]
          -- group should NOT be interchangable if it contains non-options:
        , fail [ "-o", "bar", "x", "-i", "bar" ]
            "Missing required options: -i, --input=FILE"
        ]

    , test
        [ D.co "foo"
        , D.opt_  'o' "out"
        , D.optR_ 'q' "qux"
        , D.opt 'b' "baz" (D.oa "BAZ" $ D.str "ax")
        , D.opt_  'i' "input"
        , D.optR  'f' "foo" (D.oa_ "FOZ")
        , D.co     "baz"
        ]
        [ pass
            [ "foo" , "--out", "--input", "--qux", "--foo=ox", "baz" ]
            [ D.co    "foo"                   :> D.bool true
            , D.opt_  'o' "out"               :> D.bool true
            , D.opt_  'i' "input"             :> D.bool true
            , D.optR_ 'q' "qux"               :> D.array [ D.bool true ]
            , D.optR  'f' "foo" (D.oa_ "FOZ") :> D.array [ D.str "ox" ]
            , D.co     "baz"                  :> D.bool true
            -- should have added default value that was not provided above:
            , D.opt 'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            ]

        , pass
            [ "foo" , "--out", "-qqq", "--foo=ox", "--baz=ax", "--input", "baz" ]
            [ D.co    "foo"     :> D.bool true
            , D.opt_  'o' "out" :> D.bool true
            , D.optR_ 'q' "qux" :> D.array [ D.bool true
                                           , D.bool true
                                           , D.bool true
                                           ]
            , D.optR  'f' "foo" (D.oa_ "FOZ") :> D.array [ D.str "ox"
                                                         ]
            , D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            , D.opt_  'i' "input" :> D.bool true
            , D.co    "baz"       :> D.bool true
            ]

        , pass
            [ "foo", "-q", "-o", "--qux", "-i", "--baz=ax", "-f=ox", "baz" ]
            [ D.co    "foo"       :> D.bool true
            , D.optR_ 'q' "qux"   :> D.array [ D.bool true , D.bool true ]
            , D.opt_  'o' "out"   :> D.bool true
            , D.opt_  'i' "input" :> D.bool true
            , D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            , D.optR  'f' "foo" (D.oa_ "FOZ") :> D.array [ D.str "ox" ]
            , D.co    "baz"       :> D.bool true
            ]

        , pass
            [ "foo", "--baz=ax", "-o", "-f=ox", "-i", "baz" ]
            [ D.co    "foo"       :> D.bool true
            , D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            , D.opt_  'o' "out"   :> D.bool true
            , D.optR  'f' "foo" (D.oa_ "FOZ") :> D.array [ D.str "ox" ]
            , D.opt_  'i' "input" :> D.bool true
            , D.co     "baz"      :> D.bool true
            ]

        , pass
            [ "foo", "-o", "-i", "-bax", "baz" ]
            [ D.co    "foo"       :> D.bool true
            , D.opt_  'o' "out"   :> D.bool true
            , D.opt_  'i' "input" :> D.bool true
            , D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            , D.co    "baz"       :> D.bool true
            -- should have added default value that was not provided above:
            , D.opt   'b' "baz" (D.oa "BAZ" $ D.str "ax") :> D.str "ax"
            ]

        , fail
            [ "foo" ]
            -- TODO: Create a more sophisticated way to test this
            $ "Missing required options: "
                ++ "-o, --out, "
                ++ "-i, --input"
        , fail
            [ "foo", "-o", "-i", "-bax" ]
            -- TODO: Create a more sophisticated way to test this
            "Expected command: \"baz\""
        ]

    , test
        [ D.gro false [[ D.co "foo" ]] ]
        [ fail [ "goo" ] "Trailing input: \"goo\"" ]
    , test
        [ D.grr false [[ D.co "foo" ]] ]
        [ fail [ "goo" ] "Expected command: \"foo\"" ]
  ]

  for_ testCases \(Test branch kases) -> do
    describe (prettyPrintBranch $ D.br branch) do
      for_ kases \(Case input expected) ->
            let msg = either
                  (\e -> "Should fail with \"" ++ e ++ "\"")
                  prettyPrintOut
                  expected
            in it (intercalate " " input ++ " -> " ++ msg) do
                  vliftEff do
                    validate branch input expected

    where

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

      prettyPrintMap :: forall a. Map a Value -> (a -> String) -> String
      prettyPrintMap m p = intercalate "\n\t" $
        Map.toList m <#> \(Tuple arg val) ->
          p arg ++ " => " ++ prettyPrintValue val

      validate :: forall eff.  Array Argument
                            -> Array String
                            -> Either String (Map Argument Value)
                            -> Eff (err :: EXCEPTION | eff) Unit
      validate args argv expected = do
        let result = uncurry T.reduce
              <$> runParser
                    argv
                    (genParser $ singleton $ Usage $ singleton $ D.br args)

        case result of
          Left (e@(P.ParseError { message: msg })) ->
            either
              (\e' ->
                if (msg /= e')
                  then throwException $ error $
                    "Unexpected error:\n" ++ msg
                  else return unit)
              (const $ throwException $ error $ show e)
              expected
          Right r -> do
            either
              (throwException <<< error <<< show)
              (\r' ->
                if (r /= r')
                  then throwException $ error $
                    "Unexpected output:\n"
                      ++ prettyPrintOut r
                  else return unit)
              expected

error: pathspec 'test/Test/Spec/ParserGenSpec.purs' did not match any file(s) known to git


New ServerError: NoSuchSocket

New ServerError: NoSuchSocket

-- File auto generated by purescript-bridge! --
module Gonimo.Server.Error where

import Gonimo.Server.DbEntities (Family)
import Gonimo.Types (Key)

import Data.Generic (class Generic)

data ServerError =
    InvalidAuthToken
  | InvitationAlreadyClaimed
  | AlreadyFamilyMember
  | NoSuchFamily (Key Family)
  | NoSuchInvitation
  | NoSuchSocket
  | Forbidden
  | NotFound
  | TransactionTimeout

derive instance genericServerError :: Generic ServerError

-- File auto generated by purescript-bridge! --
module Gonimo.Server.Error where

import Gonimo.Server.DbEntities (Family)
import Gonimo.Types (Key)

import Data.Generic (class Generic)

data ServerError =
    InvalidAuthToken
  | InvitationAlreadyClaimed
  | AlreadyFamilyMember
  | NoSuchFamily (Key Family)
  | NoSuchInvitation
  | Forbidden
  | NotFound
  | TransactionTimeout

derive instance genericServerError :: Generic ServerError


#551 Default to blank

#551 Default to blank

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/equella/Equella.git/'


add group module

add group module

error: pathspec 'src/Data/Phaser/Group.purs' did not match any file(s) known to git


add physics module

add physics module

module Data.Phaser.Physics (PhysicsType(..), startSystem) where

import Control.Monad.Eff
import Control.Monad.Eff.Phaser
import Data.Foreign.EasyFFI

data PhysicsType = Arcade | Chipmunk | Ninja | P2JS | Box2D

startSystem' :: forall eff. Game -> Number -> Eff (phaser :: Phaser | eff) Unit
startSystem' = unsafeForeignFunction ["game", "type", ""] "game.physics.startSystem(type);"

startSystem :: forall eff. Game -> PhysicsType -> Eff (phaser :: Phaser | eff) Unit
startSystem game Arcade   = startSystem' game 0
startSystem game P2JS     = startSystem' game 1
startSystem game Ninja    = startSystem' game 2
startSystem game Box2D    = startSystem' game 3
startSystem game Chipmunk = startSystem' game 5

error: pathspec 'src/Data/Phaser/Physics.purs' did not match any file(s) known to git


Clean up imports

Clean up imports

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/clample/lambdabtc.git/'


add Data.GetSpotResponse

add Data.GetSpotResponse

module Data.GetSpotResponse (GetSpotResponse(..)) where

import Data.Detail (Detail)
import Data.Foreign (F, Foreign, readString)
import Data.Foreign.Class (class IsForeign, readProp)
import Data.Foreign.Index (prop)
import Data.Foreign.Null (readNull, unNull)
import Data.Maybe (fromMaybe)
import Data.Show (class Show, show)
import Prelude (($), (<>), bind, pure)

data GetSpotResponse = GetSpotResponse
  { id :: Int
  , description :: String -- or null
  , details :: Array Detail
  -- , images :: Array Image
  , lat :: String -- NumberString
  , lng :: String -- NumberString
  , name :: String
  , radius :: String -- NumberString
  , stampByLocation :: Boolean
  , stampByQrCode :: Boolean
  , tagline :: String -- or null
  , zoom :: Int
  }

instance getSpotResponseShow :: Show GetSpotResponse where
  show (GetSpotResponse { id
                        , description
                        , details
                        -- , images :: Array Image
                        , lat
                        , lng
                        , name
                        , radius
                        , stampByLocation
                        , stampByQrCode
                        , tagline
                        , zoom
                        }) =
    "(GetSpotResponse {"
    <> " id: " <> show id <> ","
    <> " description: " <> show description <> ","
    <> " details: " <> show details <> ","
    <> " lat: " <> show lat <> ","
    <> " lng: " <> show lng <> ","
    <> " name: " <> show name <> ","
    <> " radius: " <> show radius <> ","
    <> " stampByLocation: " <> show stampByLocation <> ","
    <> " stampByQrCode: " <> show stampByQrCode <> ","
    <> " tagline: " <> show tagline <> ","
    <> " })"

readNullProp :: String -> String -> Foreign -> F String
readNullProp p defaultValue o = do
  pv <- prop p o
  ns <- readNull readString pv
  pure $ fromMaybe defaultValue $ unNull ns

instance getSpotResponseIsForeign :: IsForeign GetSpotResponse where
  read value = do
    id <- readProp "id" value
    description <- readNullProp "description" "" value
    details <- readProp "details" value
    lat <- readProp "lat" value
    lng <- readProp "lng" value
    name <- readProp "name" value
    radius <- readProp "radius" value
    stampByLocation <- readProp "stampByLocation" value
    stampByQrCode <- readProp "stampByQrCode" value
    tagline <- readNullProp "tagline" "" value
    zoom <- readProp "zoom" value
    pure $ GetSpotResponse { id
                           , description
                           , details
                           -- , images :: Array Image
                           , lat
                           , lng
                           , name
                           , radius
                           , stampByLocation
                           , stampByQrCode
                           , tagline
                           , zoom
                           }

error: pathspec 'src/Data/GetSpotResponse.purs' did not match any file(s) known to git


NoSuchFamily error now contains familyid

-- File auto generated by purescript-bridge! --
module Gonimo.Server.Error where

import Gonimo.Server.DbEntities (Family)
import Gonimo.Types (Key)

import Data.Generic (class Generic)

data ServerError =
    InvalidAuthToken
  | InvitationAlreadyClaimed
  | AlreadyFamilyMember
  | NoSuchFamily (Key Family)
  | Forbidden
  | NotFound
  | TransactionTimeout

derive instance genericServerError :: Generic ServerError

-- File auto generated by purescript-bridge! --
module Gonimo.Server.Error where

import Data.Generic (class Generic)

data ServerError =
    InvalidAuthToken
  | InvitationAlreadyClaimed
  | AlreadyFamilyMember
  | NoSuchFamily
  | Forbidden
  | NotFound
  | TransactionTimeout

derive instance genericServerError :: Generic ServerError


Kind of hacky way to save and retrieve the game state from localStorage

module Storage where

import Control.Monad.Eff
import DOM
import Data.Maybe

import Types

-- | Retrieve the current game state from local storage (FFI, needs 'Just' and 'Nothing' as input)
foreign import helpLoadGameState """
    function helpLoadGameState(just) {
        return function(nothing) {
            return function() {
                var data = localStorage.getItem('gameState');
                if (!data) {
                    return nothing;
                }
                return just(JSON.parse(data));
            };
        };
    } """ :: forall a eff. (a -> Maybe a) -> (Maybe a) -> Eff (dom :: DOM | eff) (Maybe GameState)

-- | Retrieve game state from local storage
loadGameState :: forall eff. Eff (dom :: DOM | eff) (Maybe GameState)
loadGameState = helpLoadGameState Just Nothing

-- | Store a game state in local storage
foreign import saveGameState """
    function saveGameState(gs) {
        return function() {
            localStorage.setItem('gameState', JSON.stringify(gs));
            return {};
        };
    } """ :: forall eff. GameState -> Eff (dom :: DOM | eff) Unit

error: pathspec 'src/Storage.purs' did not match any file(s) known to git


textlike renderer

textlike renderer

module SlamData.Workspace.Card.FormInput.TextLikeRenderer.Component where

import SlamData.Prelude

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.Themes.Bootstrap3 as B
import Halogen.CustomProps as Cp

import SlamData.Monad (Slam)
import SlamData.Workspace.Card.Port (SetupTextLikeFormInputPort)
import SlamData.Workspace.Card.CardType.FormInputType (FormInputType(..))

type State =
  { label ∷ Maybe String
  , value ∷ String
  , inputType ∷ HP.InputType
  }

initialState ∷ State
initialState =
  { label: Nothing
  , value: ""
  , inputType: HP.InputText
  }

data Query a
  = Setup SetupTextLikeFormInputPort a
  | ValueChanged String a

type DSL = H.ComponentDSL State Query Slam
type HTML = H.ComponentHTML Query

comp ∷ H.Component State Query Slam
comp = H.component { render, eval }

render ∷ State → HTML
render state =
  HH.form
    [ Cp.nonSubmit ]
    $ foldMap (\n → [ HH.label [ HP.classes [ B.controlLabel ] ] [ HH.text n ] ]) state.label
    ⊕ [ HH.input
          [ HP.classes [ B.formControl ]
          , HP.value state.value
          , HP.inputType state.inputType
          , HE.onValueInput $ HE.input ValueChanged
          ]
      ]

eval ∷ Query ~> DSL
eval (ValueChanged s next) = do
  H.modify _{ value = s }
  pure next
eval (Setup p next) = do
  H.modify _
    { label = if p.name ≡ "" then Nothing else Just p.name
    , inputType = case p.formInputType of
         Numeric → HP.InputNumber
         Date → HP.InputDate
         Time → HP.InputTime
         Datetime → HP.InputDatetime
         _ → HP.InputText
    }
  pure next

error: pathspec 'src/SlamData/Workspace/Card/FormInput/TextLikeRenderer/Component.purs' did not match any file(s) known to git


Make amount field only accept numbers

Make amount field only accept numbers