Add disclaimer, that we only work with Chrome.

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.Attributes.Bootstrap 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 (Eff)
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 (Component, ComponentType, noEffects, onlyModify, Update, runGonimo, class MonadComponent, onClickWithDefault)
import Gonimo.Server.Db.Entities (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 (letterSpacing, offset)
import Pux.Html.Elements (br)
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
  , invitationId   :: Key Invitation
  , invitation     :: Invitation
  , sentInvitation :: Maybe SentInvitation
  }

-- | 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 : ""
                            , sentInvitation : Nothing
                            , invitationId : invKey
                            , invitation : inv
                            }

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

type SentInvitation = { invitation :: Invitation
                      , sentMethod :: SentMethod
                      }

data SentMethod = SentWhatsApp | SentTelegram | SentCopyPaste | SentEmail String

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, sentInvitation = Nothing :: Maybe SentInvitation }
  InvitationSent sent       -> handleInvitationSent sent
  SendInvitation            -> handleSendInvitation
  MakeNewInvitation         -> handleMakeNewInvitation
  SetInvitationData id' inv -> onlyModify $ \state -> state { invitationId = id', invitation = inv }
  GoToOverview              -> noEffects
  GoToBabyStation           -> noEffects
  CopyToClipboard elemId    -> handleCopyToClipboard elemId
  ReportError err           -> noEffects
  Nop                       -> noEffects

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

handleInvitationSent :: forall ps. SentMethod -> ComponentType (Props ps) State Action
handleInvitationSent method = do
  state <- get :: Component (Props ps) State State
  modify $ _ { sentInvitation = Just $ { invitation : state.invitation , sentMethod : method } }
  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 (SentEmail state.email)

handleCopyToClipboard :: forall ps. String -> ComponentType (Props ps) State Action
handleCopyToClipboard elemId = pure [ do
                                         liftEff $ copyTextFromId elemId
                                         pure $ InvitationSent SentCopyPaste
                                    ]
--------------------------------------------------------------------------------

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 "panel panel-danger"]
          [ div [ A.className "panel-heading"]
            [ h3 [] [ text "Early Development Software" ]
            ]
          , div [ A.className "panel-body" ]
            [ p []
              [ text $ "This early development version currently only works on recent versions of Chrome on any non-Apple platform."
              ]
            , p []
              [ text $ "We will support more browsers in the near future, Apple once they support the Internet."
              ]
            ]
          ]
        , 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"
                            <> " family, you only have to visit the"
                            <> " following one-time link on another device." ]
                    ]
            , div []
              [ div [ A.className "input-group"]
                [ input [ A.type_ "text", A.className "form-control", A.readOnly true
                        , A.value invitationLink
                        , A.id_ "invitationLinkUrlInput"
                        ] []
                ,  H.span [ A.className "input-group-btn"]
                   [ button [ A.className "btn btn-default"
                            , A.type_ "button"
                            , A.title "Generate new link ..."
                            , E.onClick $ const $ MakeNewInvitation
                            ]
                     [ span [ A.className "glyphicon glyphicon-repeat"] []
                     ]
                   ]
                ]
                , p [] [ br [] []
                       , text $ "You can either share it directly with WhatsApp or Telegram"
                         <> " or copy & paste it to send it via some other means:"
                  ]
            , H.div [ A.className "btn-group btn-group-justified" ]
              [ H.div [ A.className "btn-group" ]
                [ H.a [ A.className "btn btn-default"
                      , A.href $ "whatsapp://send?text=" <> escapedLink
                      , A.role "button"
                      , A.type_ "button"
                      , onClickWithDefault $ const $ InvitationSent SentWhatsApp
                      ]
                  [
                    -- H.img [ A.src "../static/pix/WhatsApp.svg", A.alt "WhatsApp" ] []
                    H.i [A.className "fa fa-fw fa-whatsapp"] []
                  , H.span [A.className "hidden-xs"] [H.text " WhatsApp"]
                  ]
                ]
              , H.div [ A.className "btn-group" ]
                [ H.a [ A.className "btn btn-default"
                      , A.href $ "tg://msg?text=" <> escapedLink -- "https://telegram.me/share/url?url=" <> escapedLink
                      , A.role "button"
                      , A.type_ "button"
                      , onClickWithDefault $ const $ InvitationSent SentTelegram
                      ]
                  [ H.i [A.className "fa fa-fw fa-telegram"] []
                  , H.span [A.className "hidden-xs"] [H.text " Telegram"]
                  ]
                ]
              , H.div [ A.className "btn-group" ]
                [ H.a [ A.className "btn btn-default"
                           , A.role "button"
                           , A.type_ "button"
                           , E.onClick $ const $ CopyToClipboard "invitationLinkUrlInput"
                           ]
                  [ H.span [ A.className "glyphicon glyphicon-copy"] []
                  , H.span [ A.className "hidden-xs"] [H.text " Copy to Clipboard"]
                  ]
                ]
              ]
            , br [] []
            , p []  [ text "Or you can let us 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"] []
              ]
            ]
          ]
          , div [ A.className "container"
                , A.style [Tuple "width" "100%"]]
              [ br [] []
              , 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 "← "]
                            , span [A.className "hidden-xs"] [text "Back to "]
                            , text "Overview"
                            ]
                      ]
              , li [ A.className "next"
                    , E.onClick $ const $ GoToBabyStation
                    ] [ a [] [ span [A.className "hidden-xs"] [text "Make this device a "]
                             , text "Baby Station"
                             , span [A.ariaHidden "true"] [text " →"]
                             ]
                      ]
              ]

            ]
          , viewSent props state
          ]
        ]
  where
    handleEnter :: E.KeyboardEvent -> Action
    handleEnter ev = if ev.keyCode == 13 then SendInvitation else Nop

viewSent :: forall ps. Props ps -> State -> Html Action
viewSent props state =
  case state.sentInvitation of
    Nothing -> H.span [] []
    Just sent ->
      let
        invLink = makeInviteLink (props.baseURL) sent.invitation
      in
        H.div [ A.className "alert alert-success"]
        [ viewSentMethod sent
        , H.a [ A.href invLink ]
          [ H.text "Oops - Did you send the invitation to the wrong recipient?"
          , br [] []
          , H.text "No problem! Just click me and then press 'Decline' to invalidate the invitation."
          ]
        ]

viewSentMethod :: SentInvitation -> Html Action
viewSentMethod sent = case sent.sentMethod of
  SentCopyPaste -> H.div []
                   [ H.h3 [] [ text $ "Copied invitation link to clipboard!" ]
                   , H.text "Now just paste it somewhere in order to transfer it to another device."
                   ]
  SentWhatsApp -> H.div []
                   [ H.h3 [] [ text $ "Sent link with WhatsApp!" ]
                   , H.text "That did not work out? Just copy and paste the link yourself!"
                   ]
  SentTelegram -> H.div []
                   [ H.h3 [] [ text $ "Sent link with Telegram!" ]
                   , H.text "That did not work out? Just copy and paste the link yourself!"
                   ]
  SentEmail addr -> H.div []
                   [ H.h3 [] [ text $ "Invitation successfully sent to '"  <> addr <> "'!" ]
                   , H.text "Did not receive the e-mail? Please check your spam folder!"
                   ]

foreign import copyTextFromId :: String -> Eff () Boolean

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.Attributes.Bootstrap 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 (Eff)
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 (Component, ComponentType, noEffects, onlyModify, Update, runGonimo, class MonadComponent, onClickWithDefault)
import Gonimo.Server.Db.Entities (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 (letterSpacing, offset)
import Pux.Html.Elements (br)
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
  , invitationId   :: Key Invitation
  , invitation     :: Invitation
  , sentInvitation :: Maybe SentInvitation
  }

-- | 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 : ""
                            , sentInvitation : Nothing
                            , invitationId : invKey
                            , invitation : inv
                            }

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

type SentInvitation = { invitation :: Invitation
                      , sentMethod :: SentMethod
                      }

data SentMethod = SentWhatsApp | SentTelegram | SentCopyPaste | SentEmail String

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, sentInvitation = Nothing :: Maybe SentInvitation }
  InvitationSent sent       -> handleInvitationSent sent
  SendInvitation            -> handleSendInvitation
  MakeNewInvitation         -> handleMakeNewInvitation
  SetInvitationData id' inv -> onlyModify $ \state -> state { invitationId = id', invitation = inv }
  GoToOverview              -> noEffects
  GoToBabyStation           -> noEffects
  CopyToClipboard elemId    -> handleCopyToClipboard elemId
  ReportError err           -> noEffects
  Nop                       -> noEffects

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

handleInvitationSent :: forall ps. SentMethod -> ComponentType (Props ps) State Action
handleInvitationSent method = do
  state <- get :: Component (Props ps) State State
  modify $ _ { sentInvitation = Just $ { invitation : state.invitation , sentMethod : method } }
  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 (SentEmail state.email)

handleCopyToClipboard :: forall ps. String -> ComponentType (Props ps) State Action
handleCopyToClipboard elemId = pure [ do
                                         liftEff $ copyTextFromId elemId
                                         pure $ InvitationSent SentCopyPaste
                                    ]
--------------------------------------------------------------------------------

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"
                            <> " family, you only have to visit the"
                            <> " following one-time link on another device." ]
                    ]
            , div []
              [ div [ A.className "input-group"]
                [ input [ A.type_ "text", A.className "form-control", A.readOnly true
                        , A.value invitationLink
                        , A.id_ "invitationLinkUrlInput"
                        ] []
                ,  H.span [ A.className "input-group-btn"]
                   [ button [ A.className "btn btn-default"
                            , A.type_ "button"
                            , A.title "Generate new link ..."
                            , E.onClick $ const $ MakeNewInvitation
                            ]
                     [ span [ A.className "glyphicon glyphicon-repeat"] []
                     ]
                   ]
                ]
                , p [] [ br [] []
                       , text $ "You can either share it directly with WhatsApp or Telegram"
                         <> " or copy & paste it to send it via some other means:"
                  ]
            , H.div [ A.className "btn-group btn-group-justified" ]
              [ H.div [ A.className "btn-group" ]
                [ H.a [ A.className "btn btn-default"
                      , A.href $ "whatsapp://send?text=" <> escapedLink
                      , A.role "button"
                      , A.type_ "button"
                      , onClickWithDefault $ const $ InvitationSent SentWhatsApp
                      ]
                  [
                    -- H.img [ A.src "../static/pix/WhatsApp.svg", A.alt "WhatsApp" ] []
                    H.i [A.className "fa fa-fw fa-whatsapp"] []
                  , H.span [A.className "hidden-xs"] [H.text " WhatsApp"]
                  ]
                ]
              , H.div [ A.className "btn-group" ]
                [ H.a [ A.className "btn btn-default"
                      , A.href $ "tg://msg?text=" <> escapedLink -- "https://telegram.me/share/url?url=" <> escapedLink
                      , A.role "button"
                      , A.type_ "button"
                      , onClickWithDefault $ const $ InvitationSent SentTelegram
                      ]
                  [ H.i [A.className "fa fa-fw fa-telegram"] []
                  , H.span [A.className "hidden-xs"] [H.text " Telegram"]
                  ]
                ]
              , H.div [ A.className "btn-group" ]
                [ H.a [ A.className "btn btn-default"
                           , A.role "button"
                           , A.type_ "button"
                           , E.onClick $ const $ CopyToClipboard "invitationLinkUrlInput"
                           ]
                  [ H.span [ A.className "glyphicon glyphicon-copy"] []
                  , H.span [ A.className "hidden-xs"] [H.text " Copy to Clipboard"]
                  ]
                ]
              ]
            , br [] []
            , p []  [ text "Or you can let us 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"] []
              ]
            ]
          ]
          , div [ A.className "container"
                , A.style [Tuple "width" "100%"]]
              [ br [] []
              , 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 "← "]
                            , span [A.className "hidden-xs"] [text "Back to "]
                            , text "Overview"
                            ]
                      ]
              , li [ A.className "next"
                    , E.onClick $ const $ GoToBabyStation
                    ] [ a [] [ span [A.className "hidden-xs"] [text "Make this device a "]
                             , text "Baby Station"
                             , span [A.ariaHidden "true"] [text " →"]
                             ]
                      ]
              ]

            ]
          , viewSent props state
          ]
        ]
  where
    handleEnter :: E.KeyboardEvent -> Action
    handleEnter ev = if ev.keyCode == 13 then SendInvitation else Nop

viewSent :: forall ps. Props ps -> State -> Html Action
viewSent props state =
  case state.sentInvitation of
    Nothing -> H.span [] []
    Just sent ->
      let
        invLink = makeInviteLink (props.baseURL) sent.invitation
      in
        H.div [ A.className "alert alert-success"]
        [ viewSentMethod sent
        , H.a [ A.href invLink ]
          [ H.text "Oops - Did you send the invitation to the wrong recipient?"
          , br [] []
          , H.text "No problem! Just click me and then press 'Decline' to invalidate the invitation."
          ]
        ]

viewSentMethod :: SentInvitation -> Html Action
viewSentMethod sent = case sent.sentMethod of
  SentCopyPaste -> H.div []
                   [ H.h3 [] [ text $ "Copied invitation link to clipboard!" ]
                   , H.text "Now just paste it somewhere in order to transfer it to another device."
                   ]
  SentWhatsApp -> H.div []
                   [ H.h3 [] [ text $ "Sent link with WhatsApp!" ]
                   , H.text "That did not work out? Just copy and paste the link yourself!"
                   ]
  SentTelegram -> H.div []
                   [ H.h3 [] [ text $ "Sent link with Telegram!" ]
                   , H.text "That did not work out? Just copy and paste the link yourself!"
                   ]
  SentEmail addr -> H.div []
                   [ H.h3 [] [ text $ "Invitation successfully sent to '"  <> addr <> "'!" ]
                   , H.text "Did not receive the e-mail? Please check your spam folder!"
                   ]

foreign import copyTextFromId :: String -> Eff () Boolean


export missing functions

export missing functions

module Control.Monad.Aff
  ( Aff(),
    PureAff(..),
    attempt,
    catch,
    launchAff,
    makeAff,
    runAff
  )
  where

  import Data.Either(Either(..))
  import Data.Monoid(Monoid, mempty)
  import Control.Apply
  import Control.Monad.Eff
  import Control.Monad.Eff.Exception(Error(), Exception(), catchException)
  import Control.Monad.Eff.Unsafe(unsafeInterleaveEff)
  import Control.Monad.Eff.Class

  data Aff e a = Aff ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e Unit)

  type PureAff a = forall e. Aff e a

  -- | Converts the asynchronous effect into a synchronous one. All values and
  -- | errors are ignored.
  launchAff :: forall e a. Aff e a -> Eff e Unit
  launchAff (Aff fa) = fa (const (pure unit)) (const (pure unit))

  -- | Runs the asynchronous effect. You must supply an error callback and a
  -- | success callback.
  runAff :: forall e a. (Error -> Eff e Unit) -> (a -> Eff e Unit) -> Aff e a -> Eff e Unit
  runAff ex f (Aff v) = v ex f

  -- | Creates an asynchronous effect from a function that accepts error and
  -- | success callbacks.
  makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e Unit) -> Aff e a
  makeAff = Aff

  -- | Promotes any error to the value level of the asynchronous monad.
  attempt :: forall e a. Aff e a -> Aff e (Either Error a)
  attempt (Aff fa) = Aff (\_ h -> fa (Left >>> h) (Right >>> h))

  -- | Removes exceptions by forcing them through the error callback.
  catch :: forall e a. Aff (err :: Exception | e) a -> Aff e a
  catch (Aff fa) = Aff (\ex h -> catchException ex (fa (unsafeInterleaveEff <$> ex) (\a -> unsafeInterleaveEff (h a))))

  instance semigroupAff :: (Semigroup a) => Semigroup (Aff e a) where
    (<>) a b = (<>) <$> a <*> b

  instance monoidAff :: (Monoid a) => Monoid (Aff e a) where
    mempty = pure mempty

  instance functorAff :: Functor (Aff e) where
    (<$>) f (Aff fa) = Aff (\ex h -> fa ex (\a -> h (f a)))

  instance applyAff :: Apply (Aff e) where
    (<*>) (Aff ff) (Aff fa) = Aff (\ex h -> ff ex (\f -> fa ex (\a -> h (f a))))

  instance applicativeAff :: Applicative (Aff e) where
    pure v = Aff (\_ h -> h v)

  instance bindAff :: Bind (Aff e) where
    (>>=) (Aff fa) f = Aff (\ex h -> fa ex (\a -> runAff ex (\b -> h b) (f a)))

  instance monadAff :: Monad (Aff e)

  instance monadEffAff :: MonadEff e (Aff e) where
    liftEff fa = Aff (\_ h -> fa >>= h)

module Control.Monad.Aff
  ( Aff(),
    PureAff(..),
    launchAff,
    makeAff,
    runAff
  )
  where

  import Data.Either(Either(..))
  import Data.Monoid(Monoid, mempty)
  import Control.Apply
  import Control.Monad.Eff
  import Control.Monad.Eff.Exception(Error(), Exception(), catchException)
  import Control.Monad.Eff.Unsafe(unsafeInterleaveEff)
  import Control.Monad.Eff.Class

  data Aff e a = Aff ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e Unit)

  type PureAff a = forall e. Aff e a

  -- | Converts the asynchronous effect into a synchronous one. All values and
  -- | errors are ignored.
  launchAff :: forall e a. Aff e a -> Eff e Unit
  launchAff (Aff fa) = fa (const (pure unit)) (const (pure unit))

  -- | Runs the asynchronous effect. You must supply an error callback and a
  -- | success callback.
  runAff :: forall e a. (Error -> Eff e Unit) -> (a -> Eff e Unit) -> Aff e a -> Eff e Unit
  runAff ex f (Aff v) = v ex f

  -- | Creates an asynchronous effect from a function that accepts error and
  -- | success callbacks.
  makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e Unit) -> Aff e a
  makeAff = Aff

  -- | Promotes any error to the value level of the asynchronous monad.
  attempt :: forall e a. Aff e a -> Aff e (Either Error a)
  attempt (Aff fa) = Aff (\_ h -> fa (Left >>> h) (Right >>> h))

  -- | Removes exceptions by forcing them through the error callback.
  catch :: forall e a. Aff (err :: Exception | e) a -> Aff e a
  catch (Aff fa) = Aff (\ex h -> catchException ex (fa (unsafeInterleaveEff <$> ex) (\a -> unsafeInterleaveEff (h a))))

  instance semigroupAff :: (Semigroup a) => Semigroup (Aff e a) where
    (<>) a b = (<>) <$> a <*> b

  instance monoidAff :: (Monoid a) => Monoid (Aff e a) where
    mempty = pure mempty

  instance functorAff :: Functor (Aff e) where
    (<$>) f (Aff fa) = Aff (\ex h -> fa ex (\a -> h (f a)))

  instance applyAff :: Apply (Aff e) where
    (<*>) (Aff ff) (Aff fa) = Aff (\ex h -> ff ex (\f -> fa ex (\a -> h (f a))))

  instance applicativeAff :: Applicative (Aff e) where
    pure v = Aff (\_ h -> h v)

  instance bindAff :: Bind (Aff e) where
    (>>=) (Aff fa) f = Aff (\ex h -> fa ex (\a -> runAff ex (\b -> h b) (f a)))

  instance monadAff :: Monad (Aff e)

  instance monadEffAff :: MonadEff e (Aff e) where
    liftEff fa = Aff (\_ h -> fa >>= h)


Removed export of CSS.Media.

Removed export of CSS.Media.

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/Podlas29/purescript-css.git/'


Minor changes. Trying out new feature of PureScript 0.10.6.

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/0dB/cats-utils.git/'


Test with read-style typeclass

Test with read-style typeclass

module Main where

  import Prelude
  import Either
  import JSON
  import Monad

  foreign import toJSON "function toJSON (obj) { return obj; }" :: forall a. a -> JSON

  showUnsafe :: forall a. a -> String
  showUnsafe = showJSON <<< toJSON

  class ReadJSON a where
    readJSON :: JSON -> Either String a
    -- readJSON :: JSONParser -- bug, type synoym here doesn't work

  instance ReadJSON String where
    readJSON = str

  instance ReadJSON Number where
    readJSON = num

  instance ReadJSON Boolean where
    readJSON = bool

  instance (ReadJSON a) => ReadJSON [a] where
    readJSON j = (arr j) >>= mapM readJSON

  readJSONProp :: forall a. (ReadJSON a) => String -> JSONParser a
  readJSONProp p j = (prop p j) >>= readJSON

  data Object = Object { foo :: String, bar :: Boolean, baz :: Number, list :: [ListItem] }
  data ListItem = ListItem { x :: Number, y :: Number }

  instance ReadJSON ListItem where
    readJSON json = do
      x <- readJSONProp "x" json
      y <- readJSONProp "y" json
      return $ ListItem { x: x, y: y }

  instance ReadJSON Object where
    readJSON json = do
      foo <- readJSONProp "foo" json
      bar <- readJSONProp "bar" json
      baz <- readJSONProp "baz" json
      list <- readJSONProp "list" json
      return $ Object { foo: foo, bar: bar, baz: baz, list: list }

  main = do
    let obj = fromString "{\"foo\":\"hello\",\"bar\":true,\"baz\":1,\"list\":[{\"x\":1,\"y\":2},{\"x\":3,\"y\":4}]}"
    case obj of
      Left err -> Trace.print $ "Error parsing: " ++ err
      Right obj -> case readJSON obj of
        Left err -> Trace.print err
        Right (Object result) -> Trace.print $ showUnsafe result

error: pathspec 'test-typeclassed.purs' did not match any file(s) known to git


Support seconds precision in time fields

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/garyb/purescript-markdown-halogen.git/'


re-add Alternate newtype

re-add Alternate newtype

module Data.Monoid.Alternate where

import Prelude

import Control.Alternative (class Alt, class Plus, class Alternative, empty, (<|>))
import Control.Comonad (class Comonad, class Extend)
import Data.Eq (class Eq1)
import Data.Ord (class Ord1)

-- | Monoid and semigroup instances corresponding to `Plus` and `Alt` instances
-- | for `f`
-- |
-- | ``` purescript
-- | Alternate fx <> Alternate fy == Alternate (fx <|> fy)
-- | mempty :: Alternate _ == Alternate empty
-- | ```
newtype Alternate f a = Alternate (f a)

derive newtype instance eqAlternate :: Eq (f a) => Eq (Alternate f a)

derive newtype instance eq1Alternate :: Eq1 f => Eq1 (Alternate f)

derive newtype instance ordAlternate :: Ord (f a) => Ord (Alternate f a)

derive newtype instance ord1Alternate :: Ord1 f => Ord1 (Alternate f)

derive newtype instance boundedAlternate :: Bounded (f a) => Bounded (Alternate f a)

derive newtype instance functorAlternate :: Functor f => Functor (Alternate f)

derive newtype instance applyAlternate :: Apply f => Apply (Alternate f)

derive newtype instance applicativeAlternate :: Applicative f => Applicative (Alternate f)

derive newtype instance altAlternate :: Alt f => Alt (Alternate f)

derive newtype instance plusAlternate :: Plus f => Plus (Alternate f)

derive newtype instance alternativeAlternate :: Alternative f => Alternative (Alternate f)

derive newtype instance bindAlternate :: Bind f => Bind (Alternate f)

derive newtype instance monadAlternate :: Monad f => Monad (Alternate f)

derive newtype instance extendAlternate :: Extend f => Extend (Alternate f)

derive newtype instance comonadAlternate :: Comonad f => Comonad (Alternate f)

instance showAlternate :: Show (f a) => Show (Alternate f a) where
  show (Alternate a) = "(Alternate " <> show a <> ")"

instance semigroupAlternate :: Alt f => Semigroup (Alternate f a) where
  append (Alternate a) (Alternate b) = Alternate (a <|> b)

instance monoidAlternate :: Plus f => Monoid (Alternate f a) where
  mempty = Alternate empty

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


Add more unit tests

Add more unit tests

module Test.Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)

import Data.Either(Either(..))
import Data.Foldable (traverse_)

import Test.Unit (suite, test, failure)
import Test.Unit.Main (runTest)
import Test.Unit.Console (TESTOUTPUT)

import Text.Parsing.Parser (parseErrorMessage, parseErrorPosition)
import Text.Parsing.Parser.Pos (Position(..))

import Quantities ((./), unity, milli, nano, meter, inch, hour, minute,
                   kilo, meter, mile, gram)

import Insect.Language
import Insect.Parser (parseInsect)

shouldParseAs ∷ ∀ eff. Statement → String → Aff eff Unit
shouldParseAs expected input =
    case parseInsect input of
        Left err →
          case parseErrorPosition err of
            (Position pos) →
              failure $ "Parse error for input '" <> input <> "': "
                                    <> parseErrorMessage err
                                    <> " at position "
                                    <> show pos.column
        Right output →
            unless (output == expected) $ do
                failure $ "Unexpected result:\n" <>
                       "Input:    '" <> input <> "'\n" <>
                       "Output:   " <> show output <> "\n" <>
                       "Expected: " <> show expected <> "\n"

allParseAs ∷ ∀ eff. Statement → Array String → Aff eff Unit
allParseAs expected = traverse_ (shouldParseAs expected)

shouldFail ∷ ∀ eff. String → Aff eff Unit
shouldFail input = do
  case parseInsect input of
   Left _ → pure unit
   Right output → failure $ "input is expected to throw a parse error: '" <> input <> "'"

main ∷ Eff (console ∷ CONSOLE, testOutput ∷ TESTOUTPUT, avar ∷ AVAR) Unit
main = runTest do
  suite "Parser - Numbers" do
    test "Simple numbers" do
      allParseAs (Expression (Q 1.0 unity))
        [ "1"
        , "1.0"
        , "  1  "
        , " 1.0000   "
        , " +1.0   "
        , "+1"
        ]

      allParseAs (Expression (Q 3.5 unity))
        [ "3.5"
        , "  3.5  "
        , "3.50"
        , "+3.50"
        ]

    test "Large numbers" do
      allParseAs (Expression (Q (1234567890000000.0) unity))
        [ "1234567890000000"
        , "1234567890000000.0"
        , "+1234567890000000.0"
        ]

    test "Negative numbers" do
      shouldParseAs (Expression (Q (-123.45) unity))
        "-123.45"

    test "Exponential notation" do
      shouldParseAs (Expression (Q (-1.3e13) unity))
        "-1.3e13"

      shouldParseAs (Expression (Q 2.7e-3 unity))
        "2.7e-3"

      shouldFail "2.7 e3"

      shouldFail "2.7e 3"

  suite "Parser - Quantities" do
    test "Simple" do
      allParseAs (Expression (Q 2.3 meter))
        [ "2.3m"
        , "  2.3 m "
        , "2.3meter"
        , "2.3 meter"
        , "2.3meters"
        ]

      allParseAs (Expression (Q 10.0 mile))
        [ "10miles"
        , "10mile"
        ]

      allParseAs (Expression (Q 10.0 inch))
        [ "10inches"
        , "10inch"
        , "10in"
        ]

      shouldFail "2.3yikes"

    test "SI prefixes" do
      allParseAs (Expression (Q 2.3 (kilo meter)))
        [ "2.3km"
        , "  2.3 km "
        ]

      allParseAs (Expression (Q 2.3 (milli meter)))
        [ "2.3mm"
        , "  2.3 mm "
        ]

      allParseAs (Expression (Q 2.3 (nano gram)))
        [ "2.3ng"
        , "  2.3 ng "
        ]

      allParseAs (Expression (Q 2.3 (kilo minute)))
        [ "2.3kmin"
        , "  2.3 kmin "
        ]

      shouldFail "2.3k m"
      shouldFail "2.3m m"
      shouldFail "2.3n g"

    test "Divisions" do
      allParseAs (Expression (Q 2.3 (kilo meter ./ hour)))
        [ "2.3km/h"
        , "2.30km/h"
        ]

  suite "Parser - Operators" do
    test "Precedence" do
      allParseAs (Expression (BinOp Add (Q 5.0 meter) (BinOp Mul (Q 3.0 inch) (Q 7.0 unity)))) $
        [ "5m+3in*7"
        , "5m+(3in*7)"
        , "  5 m +   3  in * 7    "
        ]

      shouldFail "3+*4"
      shouldFail "3*/4"

    test "Multiple division" do
      allParseAs (Expression (BinOp Div (BinOp Div (Q 42.0 unity) (Q 7.0 unity)) (Q 3.0 unity))) $
        [ "42/7/3"
        , "(42/7)/3"
        ]

  suite "Parser - Conversions" do
    test "Simple" do
      allParseAs (Conversion (Q (2.3) meter) inch)
        [ "2.3m -> in"
        , "  2.3 meters->inches "
        , "  2.3 m  ->  in "
        ]

      allParseAs (Conversion (Q 120.0 minute) hour)
        [ "120min -> h"
        , "120minutes -> hours"
        ]

      shouldFail "2.3m->"
      shouldFail "2.3m->k"
      shouldFail "2.3m->yikes"

    test "Complex units" do
      allParseAs (Conversion (Q 36.0 (kilo meter ./ hour)) (mile ./ hour))
        [ "36km/h -> mph"
        ]

module Test.Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)

import Data.Either(Either(..))
import Data.Foldable (traverse_)

import Test.Unit (suite, test, failure)
import Test.Unit.Main (runTest)
import Test.Unit.Console (TESTOUTPUT)

import Text.Parsing.Parser (parseErrorMessage, parseErrorPosition)
import Text.Parsing.Parser.Pos (Position(..))

import Quantities ((./), unity, meter, inch, hour, minute, kilo, meter, mile)

import Insect.Language
import Insect.Parser (parseInsect)

shouldParseAs ∷ ∀ eff. Statement → String → Aff eff Unit
shouldParseAs expected input =
    case parseInsect input of
        Left err →
          case parseErrorPosition err of
            (Position pos) →
              failure $ "Parse error for input '" <> input <> "': "
                                    <> parseErrorMessage err
                                    <> " at position "
                                    <> show pos.column
        Right output →
            unless (output == expected) $ do
                failure $ "Unexpected result:\n" <>
                       "Input:    '" <> input <> "'\n" <>
                       "Output:   " <> show output <> "\n" <>
                       "Expected: " <> show expected <> "\n"

allParseAs ∷ ∀ eff. Statement → Array String → Aff eff Unit
allParseAs expected = traverse_ (shouldParseAs expected)

shouldFail ∷ ∀ eff. String → Aff eff Unit
shouldFail input = do
  case parseInsect input of
   Left _ → pure unit
   Right output → failure $ "input is expected to throw a parse error: '" <> input <> "'"

main ∷ Eff (console ∷ CONSOLE, testOutput ∷ TESTOUTPUT, avar ∷ AVAR) Unit
main = runTest do
  suite "Parser - Numbers" do
    test "Simple numbers" do
      allParseAs (Expression (Q 1.0 unity))
        [ "1"
        , "1.0"
        , "  1  "
        , " 1.0000   "
        , " +1.0   "
        , "+1"
        ]

      allParseAs (Expression (Q 3.5 unity))
        [ "3.5"
        , "  3.5  "
        , "3.50"
        , "+3.50"
        ]

    test "Large numbers" do
      allParseAs (Expression (Q (1234567890000000.0) unity))
        [ "1234567890000000"
        , "1234567890000000.0"
        , "+1234567890000000.0"
        ]

    test "Negative numbers" do
      shouldParseAs (Expression (Q (-123.45) unity))
        "-123.45"

    test "Exponential notation" do
      shouldParseAs (Expression (Q (-1.3e13) unity))
        "-1.3e13"

      shouldParseAs (Expression (Q 2.7e-3 unity))
        "2.7e-3"

      shouldFail "2.7 e3"

      shouldFail "2.7e 3"

  suite "Parser - Quantities" do
    test "Simple" do
      allParseAs (Expression (Q 2.3 meter))
        [ "2.3m"
        , "  2.3 m "
        , "2.3meter"
        , "2.3 meter"
        , "2.3meters"
        ]

      shouldFail "2.3yikes"

    test "SI prefixes" do
      allParseAs (Expression (Q 2.3 (kilo meter)))
        [ "2.3km"
        , "  2.3 km "
        ]

      shouldFail "2.3k m"

    test "Divisions" do
      allParseAs (Expression (Q 2.3 (kilo meter ./ hour)))
        [ "2.3km/h"
        , "2.30km/h"
        ]

  suite "Parser - Operators" do
    test "Precedence" do
      allParseAs (Expression (BinOp Add (Q 5.0 meter) (BinOp Mul (Q 3.0 inch) (Q 7.0 unity)))) $
        [ "5m+3in*7"
        , "5m+(3in*7)"
        , "  5 m +   3  in * 7    "
        ]

      shouldFail "3+*4"
      shouldFail "3*/4"

    test "Multiple division" do
      allParseAs (Expression (BinOp Div (BinOp Div (Q 42.0 unity) (Q 7.0 unity)) (Q 3.0 unity))) $
        [ "42/7/3"
        , "(42/7)/3"
        ]

  suite "Parser - Conversions" do
    test "Simple" do
      allParseAs (Conversion (Q (2.3) meter) inch)
        [ "2.3m -> in"
        , "  2.3 meters->inches "
        , "  2.3 m  ->  in "
        ]

      allParseAs (Conversion (Q 120.0 minute) hour)
        [ "120min -> h"
        , "120minutes -> hours"
        ]

      shouldFail "2.3m->"
      shouldFail "2.3m->k"
      shouldFail "2.3m->yikes"

    test "Complex units" do
      allParseAs (Conversion (Q 36.0 (kilo meter ./ hour)) (mile ./ hour))
        [ "36km/h -> mph"
        ]


some bugs fixed

some bugs fixed

module Examples where
  import Debug.Trace(trace, Trace())

  import Data.Either(either)

  import Control.Monad.Aff
  import Control.Monad.Aff.AVar
  import Control.Monad.Aff.Par
  import Control.Apply((*>))
  import Control.Alt(Alt, (<|>))
  import Control.Monad.Eff.Class(liftEff)
  import Control.Monad.Eff.Exception(error)
  import Control.Monad.Error.Class(throwError)

  type Test = forall e. Aff (trace :: Trace | e) Unit
  type TestAVar = forall e. Aff (trace :: Trace, avar :: AVAR | e) Unit

  test_sequencing :: Number -> Test
  test_sequencing 0 = liftEff $ trace "Done"
  test_sequencing n = do
    later' 100 (liftEff $ trace (show (n / 10) ++ " seconds left"))
    test_sequencing (n - 1)

  test_pure :: Test
  test_pure = do
    pure unit
    pure unit
    pure unit
    liftEff $ trace "Success: Got all the way past 4 pures"

  test_attempt :: Test
  test_attempt = do
    e <- attempt (throwError (error "Oh noes!"))
    liftEff $ either (const $ trace "Success: Exception caught") (const $ trace "Failure: Exception NOT caught!!!") e

  test_apathize :: Test
  test_apathize = do
    apathize $ throwError (error "Oh noes!")
    liftEff $ trace "Success: Exceptions don't stop the apathetic"

  test_putTakeVar :: TestAVar
  test_putTakeVar = do
    v <- makeVar
    forkAff (later $ putVar v 1.0)
    a <- takeVar v
    liftEff $ trace ("Success: Value " ++ show a)

  test_killFirstForked :: Test
  test_killFirstForked = do
    c <- forkAff (later' 100 $ pure "Failure: This should have been killed!")
    b <- c `cancel` (error "Just die")
    liftEff $ trace (if b then "Success: Killed first forked" else "Failure: Couldn't kill first forked")

  test_killVar :: TestAVar
  test_killVar = do
    v <- makeVar
    killVar v (error "DOA")
    e <- attempt $ takeVar v
    liftEff $ either (const $ trace "Success: Killed queue dead") (const $ trace "Failure: Oh noes, queue survived!") e

  test_parRace :: TestAVar
  test_parRace = do
    s <- runPar (Par (later' 100 $ pure "Success: Early bird got the worm") <|>
                 Par (later' 200 $ pure "Failure: Late bird got the worm"))
    liftEff $ trace s

  test_parRaceKill1 :: TestAVar
  test_parRaceKill1 = do
    s <- runPar (Par (later' 100 $ throwError (error ("Oh noes!"))) <|>
                 Par (later' 200 $ pure "Success: Early error was ignored in favor of late success"))
    liftEff $ trace s

  test_parRaceKill2 :: TestAVar
  test_parRaceKill2 = do
    e <- attempt $ runPar (Par (later' 100 $ throwError (error ("Oh noes!"))) <|>
                           Par (later' 200 $ throwError (error ("Oh noes!"))))
    liftEff $ either (const $ trace "Success: Killing both kills it dead") (const $ trace "Failure: It's alive!!!") e

  test_semigroupCanceler :: Test
  test_semigroupCanceler =
    let
      c = Canceler (const (pure true)) <> Canceler (const (pure true))
    in do
      v <- cancel c (error "CANCEL")
      liftEff $ trace (if v then "Success: Canceled semigroup composite canceler"
                       else "Failure: Could not cancel semigroup composite canceler")

  test_cancelLater :: TestAVar
  test_cancelLater = do
    c <- forkAff $ (do pure "Binding"
                       _ <- later' 100 $ liftEff $ trace ("Failure: Later was not canceled!")
                       pure "Binding")
    v <- cancel c (error "Cause")
    liftEff $ trace (if v then "Success: Canceled later" else "Failure: Did not cancel later")

  test_cancelPar :: TestAVar
  test_cancelPar = do
    c  <- forkAff <<< runPar $ Par (later' 100 $ liftEff $ trace "Failure: #1 should not get through") <|>
                               Par (later' 100 $ liftEff $ trace "Failure: #2 should not get through")
    v  <- c `cancel` (error "Must cancel")
    liftEff $ trace (if v then "Success: Canceling composite of two Par succeeded"
                     else "Failure: Canceling composite of two Par failed")

  main = launchAff $ do
    liftEff $ trace "Testing sequencing"
    test_sequencing 3

    liftEff $ trace "Testing pure"
    test_pure

    liftEff $ trace "Testing attempt"
    test_attempt

    liftEff $ trace "Testing later"
    later $ liftEff $ trace "Success: It happened later"

    liftEff $ trace "Testing kill of later"
    test_cancelLater

    liftEff $ trace "Testing kill of first forked"
    test_killFirstForked

    liftEff $ trace "Testing apathize"
    test_apathize

    liftEff $ trace "Testing semigroup canceler"
    test_semigroupCanceler

    liftEff $ trace "Testing AVar - putVar, takeVar"
    test_putTakeVar

    liftEff $ trace "Testing AVar killVar"
    test_killVar

    liftEff $ trace "Testing Par (<|>)"
    test_parRace

    liftEff $ trace "Testing Par (<|>) - kill one"
    test_parRaceKill1

    liftEff $ trace "Testing Par (<|>) - kill two"
    test_parRaceKill2

    -- liftEff $ trace "Testing cancel of Par (<|>)"
    -- test_cancelPar

    liftEff $ trace "Done testing"

module Examples where
  import Debug.Trace(trace, Trace())

  import Data.Either(either)

  import Control.Monad.Aff
  import Control.Monad.Aff.AVar
  import Control.Monad.Aff.Par
  import Control.Apply((*>))
  import Control.Alt(Alt, (<|>))
  import Control.Monad.Eff.Class(liftEff)
  import Control.Monad.Eff.Exception(error)
  import Control.Monad.Error.Class(throwError)

  type Test = forall e. Aff (trace :: Trace | e) Unit
  type TestAVar = forall e. Aff (trace :: Trace, avar :: AVAR | e) Unit

  test_sequencing :: Number -> Test
  test_sequencing 0 = liftEff $ trace "Done"
  test_sequencing n = do
    later' 100 (liftEff $ trace (show (n / 10) ++ " seconds left"))
    test_sequencing (n - 1)

  test_pure :: Test
  test_pure = do
    pure unit
    pure unit
    pure unit
    liftEff $ trace "Success: Got all the way past 4 pures"

  test_attempt :: Test
  test_attempt = do
    e <- attempt (throwError (error "Oh noes!"))
    liftEff $ either (const $ trace "Success: Exception caught") (const $ trace "Failure: Exception NOT caught!!!") e

  test_apathize :: Test
  test_apathize = do
    apathize $ throwError (error "Oh noes!")
    liftEff $ trace "Success: Exceptions don't stop the apathetic"

  test_putTakeVar :: TestAVar
  test_putTakeVar = do
    v <- makeVar
    forkAff (later $ putVar v 1.0)
    a <- takeVar v
    liftEff $ trace ("Success: Value " ++ show a)

  test_killFirstForked :: Test
  test_killFirstForked = do
    c <- forkAff (later' 100 $ pure "Failure: This should have been killed!")
    b <- c `cancel` (error "Just die")
    liftEff $ trace (if b then "Success: Killed first forked" else "Failure: Couldn't kill first forked")

  test_killVar :: TestAVar
  test_killVar = do
    v <- makeVar
    killVar v (error "DOA")
    e <- attempt $ takeVar v
    liftEff $ either (const $ trace "Success: Killed queue dead") (const $ trace "Failure: Oh noes, queue survived!") e

  test_parRace :: TestAVar
  test_parRace = do
    s <- runPar (Par (later' 100 $ pure "Success: Early bird got the worm") <|>
                 Par (later' 200 $ pure "Failure: Late bird got the worm"))
    liftEff $ trace s

  test_parRaceKill1 :: TestAVar
  test_parRaceKill1 = do
    s <- runPar (Par (later' 100 $ throwError (error ("Oh noes!"))) <|>
                 Par (later' 200 $ pure "Success: Early error was ignored in favor of late success"))
    liftEff $ trace s

  test_parRaceKill2 :: TestAVar
  test_parRaceKill2 = do
    e <- attempt $ runPar (Par (later' 100 $ throwError (error ("Oh noes!"))) <|>
                           Par (later' 200 $ throwError (error ("Oh noes!"))))
    liftEff $ either (const $ trace "Success: Killing both kills it dead") (const $ trace "Failure: It's alive!!!") e

  test_semigroupCanceler :: Test
  test_semigroupCanceler =
    let
      c = Canceler (const (pure true)) <> Canceler (const (pure true))
    in do
      v <- cancel c (error "CANCEL")
      liftEff $ trace (if v then "Success: Canceled semigroup composite canceler"
                       else "Failure: Could not cancel semigroup composite canceler")

  test_cancelLater :: TestAVar
  test_cancelLater = do
    c <- forkAff $ (do pure "Binding"
                       _ <- later' 100 $ liftEff $ trace ("Failure: Later was not canceled!")
                       pure "Binding")
    v <- cancel c (error "Cause")
    liftEff $ trace (if v then "Success: Canceled later" else "Failure: Did not cancel later")

  test_cancelPar :: TestAVar
  test_cancelPar = do
    c  <- forkAff <<< runPar $ Par (later' 100 $ liftEff $ trace "Failure: #1 should not get through") <|>
                               Par (later' 100 $ liftEff $ trace "Failure: #2 should not get through")
    v  <- c `cancel` (error "Must cancel")
    liftEff $ trace (if v then "Success: Canceling composite of two Par succeeded"
                     else "Failure: Canceling composite of two Par failed")

  main = launchAff $ do
    liftEff $ trace "Testing sequencing"
    test_sequencing 3

    liftEff $ trace "Testing pure"
    test_pure

    liftEff $ trace "Testing attempt"
    test_attempt

    liftEff $ trace "Testing later"
    later $ liftEff $ trace "Success: It happened later"

    liftEff $ trace "Testing kill of later"
    test_cancelLater

    liftEff $ trace "Testing kill of first forked"
    test_killFirstForked

    liftEff $ trace "Testing apathize"
    test_apathize

    liftEff $ trace "Testing semigroup canceler"
    test_semigroupCanceler

    liftEff $ trace "Testing AVar - putVar, takeVar"
    test_putTakeVar

    liftEff $ trace "Testing AVar killVar"
    test_killVar

    liftEff $ trace "Testing Par (<|>)"
    test_parRace

    liftEff $ trace "Testing Par (<|>) - kill one"
    test_parRaceKill1

    liftEff $ trace "Testing Par (<|>) - kill two"
    test_parRaceKill2

    liftEff $ trace "Testing cancel of Par (<|>)"
    test_cancelPar

    liftEff $ trace "Done testing"


refactor for reusability in Part2

refactor for reusability in Part2

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/michaelsbradleyjr/advent-of-code.git/'


Add newtypes and JSON parsing

Add newtypes and JSON parsing

module Util.Types where

import Prelude ((<$>))

import Data.Argonaut
import Color (Color, toRGBA)

newtype Color' = Color' Color
newtype Colors' = Colors' (Array Color')

instance encodeJsonColor :: EncodeJson Color' where
  encodeJson (Color' color)
     = "red"   := rgba.r
    ~> "green" := rgba.g
    ~> "blue"  := rgba.b
    ~> "alpha" := rgba.a
    ~> jsonEmptyObject
      where rgba = toRGBA color

instance encodeJsonColors :: EncodeJson Colors' where
  encodeJson (Colors' colors)
     = "compatibleVersion" := "1.4"
    ~> "pluginVersion"     := "1.4"
    ~> "colors"            := fromArray (encodeJson <$> colors)
    ~> jsonEmptyObject

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


Language.PureScript.Optimizer.TCO

Language.PureScript.Optimizer.TCO

module Language.PureScript.Optimizer.TCO (tco) where

import Data.Array (reverse, concat, map, zipWith)
import Data.Maybe
import Data.Tuple3
import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST

-- |
-- Eliminate tail calls
--
tco :: Options -> JS -> JS
tco (Options o) | o.noTco = id
tco _ = tco'

tco' :: JS -> JS
tco' = everywhereOnJS convert
  where
  tcoLabel :: String
  tcoLabel = "tco"
  tcoVar :: String -> String
  tcoVar arg = "__tco_" ++ arg
  copyVar :: String -> String
  copyVar arg = "__copy_" ++ arg
  convert :: JS -> JS
  convert js@(JSVariableIntroduction name (Just fn@(JSFunction _ _ _))) =
    case collectAllFunctionArgs [] id fn of
      Tuple3 argss body' replace | isTailCall name body' ->
        let allArgs = reverse $ concat argss
        in JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
      _ -> js
  convert js = js
  collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> (Tuple3 [[String]] JS (JS -> JS))
  collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock ((body@(JSReturn _)):_))) =
    collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
  collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =
    Tuple3 (args : allArgs) body (f <<< JSFunction ident (map copyVar args))
  collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =
    collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body
  collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
    Tuple3 (args : allArgs) body (f <<< JSReturn <<< JSFunction ident (map copyVar args))
  collectAllFunctionArgs allArgs f body = Tuple3 allArgs body f
  isTailCall :: String -> JS -> Boolean
  isTailCall ident js =
    let
      numSelfCalls = everythingOnJS (+) countSelfCalls js
      numSelfCallsInTailPosition = everythingOnJS (+) countSelfCallsInTailPosition js
      numSelfCallsUnderFunctions = everythingOnJS (+) countSelfCallsUnderFunctions js
    in
      numSelfCalls > 0
      && numSelfCalls == numSelfCallsInTailPosition
      && numSelfCallsUnderFunctions == 0
    where
    countSelfCalls :: JS -> Number
    countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
    countSelfCalls _ = 0
    countSelfCallsInTailPosition :: JS -> Number
    countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
    countSelfCallsInTailPosition _ = 0
    countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'
    countSelfCallsUnderFunctions _ = 0
  toLoop :: String -> [String] -> JS -> JS
  toLoop ident allArgs js = JSBlock $
        map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
        [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral true) (JSBlock [ everywhereOnJS loopify js ]) ]
    where
    loopify :: JS -> JS
    loopify (JSReturn ret) | isSelfCall ident ret =
      let
        allArgumentValues = concat $ collectSelfCallArgs [] ret
      in
        JSBlock $ zipWith (\val arg ->
                    JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
                  ++ map (\arg ->
                    JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs
                  ++ [ JSContinue tcoLabel ]
    loopify other = other
    collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
    collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
    collectSelfCallArgs allArgumentValues _ = allArgumentValues
  isSelfCall :: String -> JS -> Boolean
  isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = true
  isSelfCall ident (JSApp fn _) = isSelfCall ident fn
  isSelfCall _ _ = false

error: pathspec 'src/Language/PureScript/Optimizer/TCO.purs' did not match any file(s) known to git


Add standard IO streams

Add standard IO streams

-- | The standard IO streams for the current process.
module Node.Stream.StdIO where

foreign import stdin  :: forall eff. Readable () (console :: CONSOLE | eff)
foreign import stdout :: forall eff. Writable () (console :: CONSOLE | eff)
foreign import stderr :: forall eff. Writable () (console :: CONSOLE | eff)

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


4.7.3

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/mikemcgowan/purescript-book.git/'


add event type

add event type

module Blueprint.Event where

import Prelude (Unit)

import Data.Function.Eff (EffFn1, EffFn2)

type EventHandler eff a = EffFn1 eff a Unit

type EventHandler2 eff a b = EffFn2 eff a b Unit

type UnitEventHandler eff = EffFn1 eff Unit Unit

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


break up into smaller pieces

break up into smaller pieces


Add failing example

Add failing example

module Main where

data Foo = Foo

instance showFoo1 :: Show Foo where
  show _ = "Foo"

instance showFoo2 :: Show Foo where
  show _ = "Bar"

test = show Foo

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


reimpl to damage vector

reimpl to damage vector

module KanColle.DamageAnalysis.DamageVector
  ( DamageVector()
  , calcKoukuDamage
  , calcHougekiDamage
  , calcRaigekiDamage
  ) where

import Prelude
import Math
import Data.Array
import qualified Data.Array.Unsafe as AU
import Data.Foldable
import Data.Int
import Data.Maybe.Unsafe
import Data.Monoid
import Data.Monoid.Endo
import Data.Foreign

import KanColle.KCAPI.Battle

-- | `DamageVector` is an array of integers that a value `x :: Array Int`
-- |  satisfies the following properties
-- | * `length x == 13`
-- | * `head x == Just 0`
-- | * `all (>= 0) x`
newtype DamageVector = DV (Array Int)

instance damageVectorSemigroup :: Semigroup DamageVector where
  append (DV a) (DV b) = DV (zipWith (+) a b)

instance damageVectorMonoid :: Monoid DamageVector where
  mempty = DV (replicate 13 0)

-- | normalize damage, there are cases where the number not turns out
-- | to be integers (0.1 for example), so we normalize the damage by
-- | taking floor of it
-- | NOTE: as an array of damages does not necessarily contain 13 elements
-- | let's not make the return type `DamageVector`
damageNormalize :: Array Number -> Array Int
damageNormalize = map (fromJust <<< fromNumber <<< floor)

modifyDamage :: (Array Int -> Array Int)
             -> DamageVector -> DamageVector
modifyDamage f (DV s) = DV (f s)

-- | get `DamageVector` from raw `fDam` and `eDam` fields
fromFDamAndEDam :: forall a.
                { api_fdam :: Array Number
                , api_edam :: Array Number} -> DamageVector
fromFDamAndEDam v = DV ([0] <> damageNormalize v.api_fdam
                            <> damageNormalize v.api_edam)

-- | calculate damage from kouku (aerial) stages
calcKoukuDamage :: Kouku -> DamageVector
calcKoukuDamage kk = fromFDamAndEDam kk.api_stage3

-- | calculate damage from hougeki (shelling) stages
calcHougekiDamage :: Hougeki -> DamageVector
calcHougekiDamage h =
    -- the order of taking damage doesn't matter for the purpose
    -- of simulating final results, so the modifiers form a monoid of endofunctions
    -- we combine modifiers as the "simulator", feed an empty damage vector
    -- to it and get the simulated result back
    modifyDamage (runEndo modifiers) mempty
  where
    cAI :: Foreign -> Array Int
    cAI = unsafeFromForeign
    cAN :: Foreign -> Array Number
    cAN = unsafeFromForeign
    -- hougeki are represented like "events"
    -- so we need to "replay" events to calculate the damage.
    -- INVARIANT: length eventTargets == length eventDamages
    eventTargets :: Array Int
    eventTargets = concat (map cAI (AU.tail h.api_df_list))
    eventDamages :: Array Int
    eventDamages = damageNormalize (concat (map cAN (AU.tail h.api_damage)))

    modifiers = foldMap Endo (zipWith toDamageModifier eventTargets eventDamages)
    toDamageModifier :: Int -> Int -> Array Int -> Array Int
    toDamageModifier target damage =
        fromJust <<< modifyAt target (+ damage)

-- | calculate damage from raigeki (torpedo) stages
calcRaigekiDamage :: Raigeki -> DamageVector
calcRaigekiDamage = fromFDamAndEDam

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


Restore applicative style example

Restore applicative style example

module Applicative where

  import Prelude
  import Either
  import Arrays
  import Eff
  import JSON

  data Point = Point Number Number Number

  instance JSON.ReadJSON Point where
    readJSON = Point <$> readJSONProp "x"
                     <*> readJSONProp "y"
                     <*> readJSONProp "z"

  main = do

    Trace.trace $ case parseJSON "{ \"x\": 1, \"y\": 2, \"z\": 3 }" of
      Left err -> "Error parsing JSON:\n" ++ err
      Right (Point x y z) -> show [x, y, z]

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


Add tests

Add tests

module Test.Main where

import AST
import Parser

import Prelude
import Data.Either
import Data.List

import Text.Parsing.StringParser

import Control.Monad.Eff
import Control.Monad.Eff.Console

test :: forall a eff. (Show a, Eq a) => String -> Parser a -> String -> a -> Eff (console :: CONSOLE | eff ) Unit
test name p input expected = case runParser p input of
  Left  (ParseError err) -> print $ "Fail (" ++ name ++ "): " ++ err
  Right result           ->
    if result == expected
      then print $ "Success (" ++ name ++ ")"
      else print $ "Fail (" ++ name ++ "): " ++ show result ++ " /= " ++ show expected

aint :: Int -> Expr
aint i = Atom $ AInt i

aname :: String -> Expr
aname s = Atom $ Name s

main :: forall eff. Eff (console :: CONSOLE | eff) Unit
main = do
  test "0" int "0" (AInt 0)
  test "1" int "1" (AInt 1)
  test "all" int "0123456789" (AInt 123456789)
  test "high" int "999999999999999999" (AInt 2147483647)

  test "a" variable "a" (Name "a")
  test "lower" variable "a_bcdefghijklmnopqrstuvwxyz_" (Name "a_bcdefghijklmnopqrstuvwxyz_")
  test "upper" variable "a'BCDEFGHIJKLMNOPQRSTUVWXYZ'" (Name "a'BCDEFGHIJKLMNOPQRSTUVWXYZ'")
  test "special" variable "_____''''" (Name "_____''''")

  test "1" expression "1" (Atom (AInt 1))
  test "add" expression "1 + 2" (Binary Add (Atom (AInt 1)) (Atom (AInt 2)))
  test "precedence" expression "1 * 2 + 3 * 4" (Binary Add
                                    (Binary Mul (Atom (AInt 1)) (Atom (AInt 2)))
                                    (Binary Mul (Atom (AInt 3)) (Atom (AInt 4))))
  test "whitespaces" expression
    "1   \n   -    \t   ( f   )    \t\t\t\t                     \n\n\n             `div`     _ignore"
    (Binary Sub (Atom (AInt 1)) (Binary Div (Atom (Name "f")) (Atom (Name "_ignore"))))
  test "brackets" expression "(  1  +  2  )  *  3" (Binary Mul (Binary Add (aint 1) (aint 2)) (aint 3))
  test "brackets2" expression "( (  1  +  2  - 3  )  *  4 * 5 * 6)"
    (Binary Mul
      (Binary Mul
        (Binary Mul
          (Binary Sub
            (Binary Add (aint 1) (aint 2))
            (aint 3))
          (aint 4))
        (aint 5))
      (aint 6))
  test "many brackets" expression "(   (( ((  f )) *  ( (17   )) ) ))" (Binary Mul (Atom (Name "f")) (aint 17))

  test "if_then_else" expression "if x then y else z" (IfExpr (aname "x") (aname "y") (aname "z"))
  test "nested if" expression "if(if 1 then 2 else 3)then y else z" (IfExpr (IfExpr (aint 1) (aint 2) (aint 3)) (aname "y") (aname "z"))
  test "iffy1" expression "iffy" (aname "iffy")
  test "iffy2" expression "if 10 + 20 then iffy * iffy else ((7))"
    (IfExpr
      (Binary Add (aint 10) (aint 20))
      (Binary Mul (aname "iffy") (aname "iffy"))
      (aint 7))
  test "iffy3" expression "iffy + if iffy then iffy else iffy"
    (Binary Add (aname "iffy") (IfExpr (aname "iffy") (aname "iffy") (aname "iffy")))
  test "nested if 2" expression "if if x then y else z then if a then b else c else if i then j else k"
    (IfExpr
      (IfExpr (aname "x") (aname "y") (aname "z"))
      (IfExpr (aname "a") (aname "b") (aname "c"))
      (IfExpr (aname "i") (aname "j") (aname "k")))

  test "apply1" expression "f 1" (App (aname "f") (singleton (aint 1)))
  test "apply2" expression "f x y z 12 (3 + 7)"
    (App (aname "f") (toList [aname "x", aname "y", aname "z", aint 12, Binary Add (aint 3) (aint 7)]))
  test "fibonacci" expression "fib (n - 1) + fib (n - 2)"
    (Binary Add
      (App (aname "fib") (toList [Binary Sub (aname "n") (aint 1)]))
      (App (aname "fib") (toList [Binary Sub (aname "n") (aint 2)])))
  test "predicate" expression "if p 10 then 10 else 20"
    (IfExpr
      (App (aname "p") (singleton (aint 10)))
      (aint 10)
      (aint 20))
  test "stuff" expression "f a (1 * 2) * 3"
    (Binary Mul
      (App (aname "f") (toList [aname "a", Binary Mul (aint 1) (aint 2)]))
      (aint 3))

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


Add Data.Array.ST.Iterator

Add Data.Array.ST.Iterator

module Data.Array.ST.Iterator
  ( Iterator
  , iterator
  , iterate
  , next
  , peek
  , exhausted
  , pushWhile
  , pushAll
  ) where

import Prelude
import Control.Monad.Eff (Eff, whileE)
import Control.Monad.ST (ST, STRef, newSTRef, readSTRef, writeSTRef, modifySTRef)
import Data.Array.ST (STArray, pushSTArray)

import Data.Maybe (Maybe(..), isNothing)

-- | This type provides a slightly easier way of iterating over an array's
-- | elements in an STArray computation, without having to keep track of
-- | indices.
data Iterator h a = Iterator (Int -> Maybe a) (STRef h Int)

-- | Make an Iterator given an indexing function into an array (or anything
-- | else). If `xs :: Array a`, the standard way to create an iterator over
-- | `xs` is to use `iterator (xs !! _)`, where `(!!)` comes from `Data.Array`.
iterator :: forall a h r. (Int -> Maybe a) -> Eff (st :: ST h | r) (Iterator h a)
iterator f =
  Iterator f <$> newSTRef 0

-- | Perform an action once for each item left in an iterator. If the action
-- | itself also advances the same iterator, `iterate` will miss those items
-- | out.
iterate :: forall a h r. Iterator h a -> (a -> Eff (st :: ST h | r) Unit) -> Eff (st :: ST h | r) Unit
iterate iter f = do
  break <- newSTRef false
  whileE (not <$> readSTRef break) do
    mx <- next iter
    case mx of
      Just x -> f x
      Nothing -> void $ writeSTRef break true

-- | Get the next item out of an iterator, advancing it. Returns Nothing if the
-- | Iterator is exhausted.
next :: forall a h r. Iterator h a -> Eff (st :: ST h | r) (Maybe a)
next (Iterator f currentIndex) = do
  i <- readSTRef currentIndex
  modifySTRef currentIndex (_ + 1)
  pure (f i)

-- | Get the next item out of an iterator without advancing it.
peek :: forall a h r. Iterator h a -> Eff (st :: ST h | r) (Maybe a)
peek (Iterator f currentIndex) = do
  i <- readSTRef currentIndex
  pure (f i)

-- | Check whether an iterator has been exhausted.
exhausted :: forall a h r. Iterator h a -> Eff (st :: ST h | r) Boolean
exhausted = map isNothing <<< peek

-- | Extract elements from an iterator and push them on to an STArray for as
-- | long as those elements satisfy a given predicate.
pushWhile :: forall a h r. (a -> Boolean) -> Iterator h a -> STArray h a -> Eff (st :: ST h | r) Unit
pushWhile p iter array = do
  break <- newSTRef false
  whileE (not <$> readSTRef break) do
    mx <- peek iter
    case mx of
      Just x | p x -> do
        pushSTArray array x
        void $ next iter
      _ ->
        void $ writeSTRef break true

-- | Push the entire remaining contents of an iterator onto an STArray.
pushAll :: forall a h r. Iterator h a -> STArray h a -> Eff (st :: ST h | r) Unit
pushAll = pushWhile (const true)

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


Added a main memory implementation

Added a main memory implementation

module MainMem where

import Prelude
import Math
import Data.Sequence as S
import Data.Maybe
import Data.Int.Bits
import qualified Data.Array as A

import Types

--NOTE consider splitting the mems to a generic number of chunks N
--that you can easily change, and then profile the performance for different N
--Or consider using array ST, if in need of better performance

--memory address
{--0 1 2 3 4 ...--}
{--0 0 1 1 2 ...--}
--seq index

{--the quotient is the index--}
{--the remainder is the offset inside the chunk--}
--Chunk size in bytes
chkSz :: Int
chkSz = 2

cleanMainMem :: MainMem
cleanMainMem = MainMem $ S.fromFoldable $ A.replicate size 0
 where
  size = 65536 / chkSz

rd8 :: I16 -> MainMem -> I8
rd8 addr (MainMem mem) = lsByteOf $
  (if isShiftNeeded then shiftByte else id) i16
 where
  isShiftNeeded = addr `mod` 2 == 0
  i16 = fromMaybe 0 $ S.index (addr / chkSz) mem
  shiftByte x = x `zshr` 8
  lsByteOf x = x .&. 255

--NOTE replace all 'fromMaybe's with an error mechanism that will make it easy
--to trace Nothing cases
rd16 :: I16 -> MainMem -> I16
rd16 addr (MainMem mem) = fromMaybe 0 $ S.index (addr / chkSz) mem

wr8 :: I8 -> I16 -> MainMem -> MainMem
wr8 i8 addr (MainMem mem) = MainMem $ S.adjust adjByte (addr / chkSz) mem
 where
  adjByte = (_ .|. i8') <<<
    (_ .&. if isShiftNeeded then 255 else 65535 - 255)
  i8' = (if isShiftNeeded then shiftByte else id) i8
  isShiftNeeded = addr `mod` 2 == 0
  shiftByte x = x `shl` 8

wr16 :: I16 -> I16 -> MainMem -> MainMem
wr16 i16 addr (MainMem mem) = MainMem $ S.replace i16 (addr / chkSz) mem

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


Resolve forgotten compiler warning

Resolve forgotten compiler warning

module Test.Data.StrMap where

import Prelude

import Data.List (List(..), groupBy, sortBy, singleton, toList, zipWith)
import Data.Foldable (foldl)
import Data.Function (on)
import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe (unsafeThrow)
import Data.Tuple (Tuple(..), fst)
import Control.Monad.Eff.Console (log)
import Test.QuickCheck ((<?>), quickCheck, quickCheck')
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import qualified Data.String as S
import qualified Data.StrMap as M

newtype TestStrMap v = TestStrMap (M.StrMap v)

instance arbTestStrMap :: (Arbitrary v) => Arbitrary (TestStrMap v) where
  arbitrary = TestStrMap <<< M.fromList <$> arbitrary

data Instruction k v = Insert k v | Delete k

instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where
  show (Insert k v) = "Insert (" ++ show k ++ ") (" ++ show v ++ ")"
  show (Delete k) = "Delete (" ++ show k ++ ")"

instance arbInstruction :: (Arbitrary v) => Arbitrary (Instruction String v) where
  arbitrary = do
    b <- arbitrary
    k <- arbitrary
    case b of
      true -> do
        v <- arbitrary
        return (Insert k v)
      false -> do
        return (Delete k)

runInstructions :: forall v. List (Instruction String v) -> M.StrMap v -> M.StrMap v
runInstructions instrs t0 = foldl step t0 instrs
  where
  step tree (Insert k v) = M.insert k v tree
  step tree (Delete k) = M.delete k tree

number :: Int -> Int
number n = n

strMapTests = do
  log "Test inserting into empty tree"
  quickCheck $ \k v -> M.lookup k (M.insert k v M.empty) == Just (number v)
    <?> ("k: " ++ show k ++ ", v: " ++ show v)

  log "Test delete after inserting"
  quickCheck $ \k v -> M.isEmpty (M.delete k (M.insert k (number v) M.empty))
    <?> ("k: " ++ show k ++ ", v: " ++ show v)

  log "Insert two, lookup first"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k1 (M.insert k2 (number v2) (M.insert k1 (number v1) M.empty)) == Just v1
    <?> ("k1: " ++ show k1 ++ ", v1: " ++ show v1 ++ ", k2: " ++ show k2 ++ ", v2: " ++ show v2)

  log "Insert two, lookup second"
  quickCheck $ \k1 v1 k2 v2 -> M.lookup k2 (M.insert k2 (number v2) (M.insert k1 (number v1) M.empty)) == Just v2
    <?> ("k1: " ++ show k1 ++ ", v1: " ++ show v1 ++ ", k2: " ++ show k2 ++ ", v2: " ++ show v2)

  log "Insert two, delete one"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k2 (M.delete k1 (M.insert k2 (number v2) (M.insert k1 (number v1) M.empty))) == Just v2
    <?> ("k1: " ++ show k1 ++ ", v1: " ++ show v1 ++ ", k2: " ++ show k2 ++ ", v2: " ++ show v2)

  log "Lookup from empty"
  quickCheck $ \k -> M.lookup k (M.empty :: M.StrMap Int) == Nothing

  log "Lookup from singleton"
  quickCheck $ \k v -> M.lookup k (M.singleton k (v :: Int)) == Just v

  log "Random lookup"
  quickCheck' 1000 $ \instrs k v ->
    let
      tree :: M.StrMap Int
      tree = M.insert k v (runInstructions instrs M.empty)
    in M.lookup k tree == Just v <?> ("instrs:\n  " ++ show instrs ++ "\nk:\n  " ++ show k ++ "\nv:\n  " ++ show v)

  log "Singleton to list"
  quickCheck $ \k v -> M.toList (M.singleton k v :: M.StrMap Int) == singleton (Tuple k v)

  log "toList . fromList = id"
  quickCheck $ \arr -> let f x = M.toList (M.fromList x)
                       in f (f arr) == f (arr :: List (Tuple String Int)) <?> show arr

  log "fromList . toList = id"
  quickCheck $ \(TestStrMap m) ->
    let f m = M.fromList (M.toList m) in
    M.toList (f m) == M.toList (m :: M.StrMap Int) <?> show m

  log "fromListWith const = fromList"
  quickCheck $ \arr -> M.fromListWith const arr ==
                       M.fromList (arr :: List (Tuple String Int)) <?> show arr

  log "fromListWith (<>) = fromList . collapse with (<>) . group on fst"
  quickCheck $ \arr ->
    let combine (Tuple s a) (Tuple t b) = (Tuple s $ b <> a)
        foldl1 g (Cons x xs) = foldl g x xs
        foldl1 _ Nil         = unsafeThrow "Impossible case in 'foldl1'"
        f = M.fromList <<< (<$>) (foldl1 combine) <<<
            groupBy ((==) `on` fst) <<< sortBy (compare `on` fst) in
    M.fromListWith (<>) arr == f (arr :: List (Tuple String String)) <?> show arr

  log "Lookup from union"
  quickCheck $ \(TestStrMap m1) (TestStrMap m2) k ->
    M.lookup k (M.union m1 m2) == (case M.lookup k m1 of
      Nothing -> M.lookup k m2
      Just v -> Just (number v)) <?> ("m1: " ++ show m1 ++ ", m2: " ++ show m2 ++ ", k: " ++ show k ++ ", v1: " ++ show (M.lookup k m1) ++ ", v2: " ++ show (M.lookup k m2) ++ ", union: " ++ show (M.union m1 m2))

  log "Union is idempotent"
  quickCheck $ \(TestStrMap m1) (TestStrMap m2) ->
    (m1 `M.union` m2) == ((m1 `M.union` m2) `M.union` (m2 :: M.StrMap Int)) <?> (show (M.size (m1 `M.union` m2)) ++ " != " ++ show (M.size ((m1 `M.union` m2) `M.union` m2)))

  log "toList = zip keys values"
  quickCheck $ \(TestStrMap m) -> M.toList m == zipWith Tuple (toList $ M.keys m) (M.values m :: List Int)

module Test.Data.StrMap where

import Prelude

import Data.List (List(..), groupBy, sortBy, singleton, toList, zipWith)
import Data.Foldable (foldl)
import Data.Function (on)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..), fst)
import Control.Monad.Eff.Console (log)
import Test.QuickCheck ((<?>), quickCheck, quickCheck')
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import qualified Data.String as S
import qualified Data.StrMap as M

newtype TestStrMap v = TestStrMap (M.StrMap v)

instance arbTestStrMap :: (Arbitrary v) => Arbitrary (TestStrMap v) where
  arbitrary = TestStrMap <<< M.fromList <$> arbitrary

data Instruction k v = Insert k v | Delete k

instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where
  show (Insert k v) = "Insert (" ++ show k ++ ") (" ++ show v ++ ")"
  show (Delete k) = "Delete (" ++ show k ++ ")"

instance arbInstruction :: (Arbitrary v) => Arbitrary (Instruction String v) where
  arbitrary = do
    b <- arbitrary
    k <- arbitrary
    case b of
      true -> do
        v <- arbitrary
        return (Insert k v)
      false -> do
        return (Delete k)

runInstructions :: forall v. List (Instruction String v) -> M.StrMap v -> M.StrMap v
runInstructions instrs t0 = foldl step t0 instrs
  where
  step tree (Insert k v) = M.insert k v tree
  step tree (Delete k) = M.delete k tree

number :: Int -> Int
number n = n

strMapTests = do
  log "Test inserting into empty tree"
  quickCheck $ \k v -> M.lookup k (M.insert k v M.empty) == Just (number v)
    <?> ("k: " ++ show k ++ ", v: " ++ show v)

  log "Test delete after inserting"
  quickCheck $ \k v -> M.isEmpty (M.delete k (M.insert k (number v) M.empty))
    <?> ("k: " ++ show k ++ ", v: " ++ show v)

  log "Insert two, lookup first"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k1 (M.insert k2 (number v2) (M.insert k1 (number v1) M.empty)) == Just v1
    <?> ("k1: " ++ show k1 ++ ", v1: " ++ show v1 ++ ", k2: " ++ show k2 ++ ", v2: " ++ show v2)

  log "Insert two, lookup second"
  quickCheck $ \k1 v1 k2 v2 -> M.lookup k2 (M.insert k2 (number v2) (M.insert k1 (number v1) M.empty)) == Just v2
    <?> ("k1: " ++ show k1 ++ ", v1: " ++ show v1 ++ ", k2: " ++ show k2 ++ ", v2: " ++ show v2)

  log "Insert two, delete one"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k2 (M.delete k1 (M.insert k2 (number v2) (M.insert k1 (number v1) M.empty))) == Just v2
    <?> ("k1: " ++ show k1 ++ ", v1: " ++ show v1 ++ ", k2: " ++ show k2 ++ ", v2: " ++ show v2)

  log "Lookup from empty"
  quickCheck $ \k -> M.lookup k (M.empty :: M.StrMap Int) == Nothing

  log "Lookup from singleton"
  quickCheck $ \k v -> M.lookup k (M.singleton k (v :: Int)) == Just v

  log "Random lookup"
  quickCheck' 1000 $ \instrs k v ->
    let
      tree :: M.StrMap Int
      tree = M.insert k v (runInstructions instrs M.empty)
    in M.lookup k tree == Just v <?> ("instrs:\n  " ++ show instrs ++ "\nk:\n  " ++ show k ++ "\nv:\n  " ++ show v)

  log "Singleton to list"
  quickCheck $ \k v -> M.toList (M.singleton k v :: M.StrMap Int) == singleton (Tuple k v)

  log "toList . fromList = id"
  quickCheck $ \arr -> let f x = M.toList (M.fromList x)
                       in f (f arr) == f (arr :: List (Tuple String Int)) <?> show arr

  log "fromList . toList = id"
  quickCheck $ \(TestStrMap m) ->
    let f m = M.fromList (M.toList m) in
    M.toList (f m) == M.toList (m :: M.StrMap Int) <?> show m

  log "fromListWith const = fromList"
  quickCheck $ \arr -> M.fromListWith const arr ==
                       M.fromList (arr :: List (Tuple String Int)) <?> show arr

  log "fromListWith (<>) = fromList . collapse with (<>) . group on fst"
  quickCheck $ \arr ->
    let combine (Tuple s a) (Tuple t b) = (Tuple s $ b <> a)
        foldl1 g (Cons x xs) = foldl g x xs
        f = M.fromList <<< (<$>) (foldl1 combine) <<<
            groupBy ((==) `on` fst) <<< sortBy (compare `on` fst) in
    M.fromListWith (<>) arr == f (arr :: List (Tuple String String)) <?> show arr

  log "Lookup from union"
  quickCheck $ \(TestStrMap m1) (TestStrMap m2) k ->
    M.lookup k (M.union m1 m2) == (case M.lookup k m1 of
      Nothing -> M.lookup k m2
      Just v -> Just (number v)) <?> ("m1: " ++ show m1 ++ ", m2: " ++ show m2 ++ ", k: " ++ show k ++ ", v1: " ++ show (M.lookup k m1) ++ ", v2: " ++ show (M.lookup k m2) ++ ", union: " ++ show (M.union m1 m2))

  log "Union is idempotent"
  quickCheck $ \(TestStrMap m1) (TestStrMap m2) ->
    (m1 `M.union` m2) == ((m1 `M.union` m2) `M.union` (m2 :: M.StrMap Int)) <?> (show (M.size (m1 `M.union` m2)) ++ " != " ++ show (M.size ((m1 `M.union` m2) `M.union` m2)))

  log "toList = zip keys values"
  quickCheck $ \(TestStrMap m) -> M.toList m == zipWith Tuple (toList $ M.keys m) (M.values m :: List Int)


Dropped import for Console effect.

Dropped import for Console effect.

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/gcross/habit-of-fate.git/'


Added the limit of how many generations to do at maximum

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/Reewr/purescript-genetic-sat.git/'


Language.PureScript.Optimizer.Blocks

Language.PureScript.Optimizer.Blocks

module Language.PureScript.Optimizer.Blocks (collapseNestedBlocks) where

import Data.Array (concatMap)
import Language.PureScript.CodeGen.JS.AST

-- |
-- Collapse blocks which appear nested directly below another block
--
collapseNestedBlocks :: JS -> JS
collapseNestedBlocks = everywhereOnJS collapse
  where
  collapse :: JS -> JS
  collapse (JSBlock sts) = JSBlock (concatMap go sts)
  collapse js = js
  go :: JS -> [JS]
  go (JSBlock sts) = sts
  go s = [s]

error: pathspec 'src/Language/PureScript/Optimizer/Blocks.purs' did not match any file(s) known to git


Fixed Int53 wallet address URL representation.

module Daedalus.Types
       ( module CT
       , module C
       , module E
       , module BP
       , module DT
       , _address
       , _ccoin
       , _passPhrase
       , mkCCoin
       , mkCAddress
       , mkCWalletMeta
       , mkCWalletInit
       , mkCTxMeta
       , mkCTxId
       , mkCCurrency
       , mkCProfile
       , _ctxIdValue
       , showCCurrency
       , mkBackupPhrase
       , mkCWalletRedeem
       , mkCPaperVendWalletRedeem
       , mkCInitialized
       , mkCPassPhrase
       , emptyCPassPhrase
       , getProfileLocale
       , walletAddressToUrl
       , mkCWalletSetInit
       ) where

import Prelude

import Pos.Wallet.Web.ClientTypes (CAddress (..), CHash (..), CPassPhrase (..), CCoin (..), WS (..), CWalletAddress (..), CWalletSetMeta (..))

import Pos.Wallet.Web.ClientTypes as CT
import Pos.Core.Types as C
import Pos.Wallet.Web.Error as E
import Pos.Util.BackupPhrase (BackupPhrase (..))
import Pos.Util.BackupPhrase as BP

import Control.Monad.Eff.Exception (error, Error)
import Data.Either (either, Either (..))
import Data.Maybe (Maybe (..))
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Argonaut.Core (fromString)
import Data.Generic (gShow)
import Data.Array.Partial (last)
import Data.Array (length, filter)
import Partial.Unsafe (unsafePartial)
import Data.String (split, null, trim, joinWith, Pattern (..))

import Daedalus.Crypto (isValidMnemonic, blake2b, bytesToB16)
import Data.Types (mkTime)
import Data.Types as DT
import Data.Int53 (fromInt, toString)

space :: Pattern
space = Pattern " "

dot :: Pattern
dot = Pattern "."

backupMnemonicLen :: Int
backupMnemonicLen = 12

paperVendMnemonicLen :: Int
paperVendMnemonicLen = 9

mkBackupPhrase :: Int -> String -> Either Error BackupPhrase
mkBackupPhrase len mnemonic = mkBackupPhraseIgnoreChecksum len mnemonic >>= const do
    if not $ isValidMnemonic mnemonicCleaned
        then Left $ error "Invalid mnemonic: checksum missmatch"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    mnemonicCleaned = cleanMnemonic mnemonic

cleanMnemonic :: String -> String
cleanMnemonic = joinWith " " <<< filter (not <<< null) <<< split space <<< trim

mkBackupPhraseIgnoreChecksum :: Int -> String -> Either Error BackupPhrase
mkBackupPhraseIgnoreChecksum len mnemonic =
    if not $ hasExactlyNwords len mnemonicCleaned
        then Left $ error "Invalid mnemonic: mnemonic should have at least 12 words"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    hasExactlyNwords len' = (==) len' <<< length <<< split space
    mnemonicCleaned = cleanMnemonic mnemonic

showCCurrency :: CT.CCurrency -> String
showCCurrency = dropModuleName <<< gShow
  where
    -- TODO: this is again stupid. We should derive Show for this type instead of doing this
    dropModuleName = unsafePartial last <<< split dot

-- TODO: it would be useful to extend purescript-bridge
-- and generate lenses
walletAddressToUrl :: CWalletAddress -> String
walletAddressToUrl (CWalletAddress r) = _address r.cwaWSAddress <> "@" <> toString r.cwaIndex

_hash :: CHash -> String
_hash (CHash h) = h

_address :: forall a. CAddress a -> String
_address (CAddress a) = _hash a

_passPhrase :: CPassPhrase -> String
_passPhrase (CPassPhrase p) = p

emptyCPassPhrase :: CPassPhrase
emptyCPassPhrase = CPassPhrase ""

mkCPassPhrase :: String -> Maybe CPassPhrase
mkCPassPhrase "" = Nothing
mkCPassPhrase pass = Just <<< CPassPhrase <<< bytesToB16 $ blake2b pass

mkCAddress :: forall a. String -> CAddress a
mkCAddress = CAddress <<< CHash

_ccoin :: CCoin -> String
_ccoin (CCoin c) = c.getCoin

mkCCoin :: String -> CCoin
mkCCoin amount = CCoin { getCoin: amount }

-- NOTE: use genericRead maybe https://github.com/paluh/purescript-generic-read-example
mkCWalletType :: String -> CT.CWalletType
mkCWalletType = either (const CT.CWTPersonal) id <<< decodeJson <<< fromString

mkCCurrency :: String -> CT.CCurrency
mkCCurrency = either (const CT.ADA) id <<< decodeJson <<< fromString

mkCWAssurance :: String -> CT.CWalletAssurance
mkCWAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCWalletMeta :: String -> String -> String -> String -> Int -> CT.CWalletMeta
mkCWalletMeta wType wCurrency wName wAssurance wUnit =
    CT.CWalletMeta { cwType: mkCWalletType wType
                   , cwCurrency: mkCCurrency wCurrency
                   , cwName: wName
                   , cwAssurance: mkCWAssurance wAssurance
                   , cwUnit: wUnit
                   }

mkCInitialized :: Int -> Int -> CT.CInitialized
mkCInitialized total preInit =
    CT.CInitialized { cTotalTime: fromInt total
                    , cPreInit: fromInt preInit
                    }

mkCWalletInit :: String -> String -> String -> CAddress WS -> CT.CWalletInit
mkCWalletInit wType wCurrency wName wSetId =
    CT.CWalletInit { cwInitWSetId: wSetId
                   , cwInitMeta: mkCWalletMeta wType wCurrency wName "CWANormal" 0 -- FIXME: don't use string!
                   }

mkCWalletSetInit :: String -> String -> Either Error CT.CWalletSetInit
mkCWalletSetInit wSetName mnemonic = do
    bp <- mkBackupPhrase backupMnemonicLen mnemonic
    pure $ CT.CWalletSetInit { cwsInitMeta: CWalletSetMeta {cwsName: wSetName }
                             , cwsBackupPhrase: bp
                             }

mkCWalletRedeem :: String -> CWalletAddress -> CT.CWalletRedeem
mkCWalletRedeem seed wAddress = do
    CT.CWalletRedeem { crWalletId: wAddress
                     , crSeed: seed
                     }

mkCPaperVendWalletRedeem :: String -> String -> CWalletAddress -> Either Error CT.CPaperVendWalletRedeem
mkCPaperVendWalletRedeem seed mnemonic wAddress = do
    bp <- mkBackupPhrase paperVendMnemonicLen mnemonic
    pure $ CT.CPaperVendWalletRedeem { pvWalletId: wAddress
                                     , pvBackupPhrase: bp
                                     , pvSeed: seed
                                     }

_ctxIdValue :: CT.CTxId -> String
_ctxIdValue (CT.CTxId tx) = _hash tx

mkCTxId :: String -> CT.CTxId
mkCTxId = CT.CTxId <<< CHash

mkCTxMeta :: String -> String -> String -> Number -> CT.CTxMeta
mkCTxMeta currency title description date =
    CT.CTxMeta { ctmCurrency: mkCCurrency currency
               , ctmTitle: title
               , ctmDescription: description
               , ctmDate: mkTime date
               }

mkCProfile :: String -> CT.CProfile
mkCProfile locale =
    CT.CProfile { cpLocale: locale
                }

getProfileLocale :: CT.CProfile -> String
getProfileLocale (CT.CProfile r) = r.cpLocale

module Daedalus.Types
       ( module CT
       , module C
       , module E
       , module BP
       , module DT
       , _address
       , _ccoin
       , _passPhrase
       , mkCCoin
       , mkCAddress
       , mkCWalletMeta
       , mkCWalletInit
       , mkCTxMeta
       , mkCTxId
       , mkCCurrency
       , mkCProfile
       , _ctxIdValue
       , showCCurrency
       , mkBackupPhrase
       , mkCWalletRedeem
       , mkCPaperVendWalletRedeem
       , mkCInitialized
       , mkCPassPhrase
       , emptyCPassPhrase
       , getProfileLocale
       , walletAddressToUrl
       , mkCWalletSetInit
       ) where

import Prelude

import Pos.Wallet.Web.ClientTypes (CAddress (..), CHash (..), CPassPhrase (..), CCoin (..), WS (..), CWalletAddress (..), CWalletSetMeta (..))

import Pos.Wallet.Web.ClientTypes as CT
import Pos.Core.Types as C
import Pos.Wallet.Web.Error as E
import Pos.Util.BackupPhrase (BackupPhrase (..))
import Pos.Util.BackupPhrase as BP

import Control.Monad.Eff.Exception (error, Error)
import Data.Either (either, Either (..))
import Data.Maybe (Maybe (..))
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Argonaut.Core (fromString)
import Data.Generic (gShow)
import Data.Array.Partial (last)
import Data.Array (length, filter)
import Partial.Unsafe (unsafePartial)
import Data.String (split, null, trim, joinWith, Pattern (..))

import Daedalus.Crypto (isValidMnemonic, blake2b, bytesToB16)
import Data.Types (mkTime)
import Data.Types as DT
import Data.Int53 (fromInt)

space :: Pattern
space = Pattern " "

dot :: Pattern
dot = Pattern "."

backupMnemonicLen :: Int
backupMnemonicLen = 12

paperVendMnemonicLen :: Int
paperVendMnemonicLen = 9

mkBackupPhrase :: Int -> String -> Either Error BackupPhrase
mkBackupPhrase len mnemonic = mkBackupPhraseIgnoreChecksum len mnemonic >>= const do
    if not $ isValidMnemonic mnemonicCleaned
        then Left $ error "Invalid mnemonic: checksum missmatch"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    mnemonicCleaned = cleanMnemonic mnemonic

cleanMnemonic :: String -> String
cleanMnemonic = joinWith " " <<< filter (not <<< null) <<< split space <<< trim

mkBackupPhraseIgnoreChecksum :: Int -> String -> Either Error BackupPhrase
mkBackupPhraseIgnoreChecksum len mnemonic =
    if not $ hasExactlyNwords len mnemonicCleaned
        then Left $ error "Invalid mnemonic: mnemonic should have at least 12 words"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    hasExactlyNwords len' = (==) len' <<< length <<< split space
    mnemonicCleaned = cleanMnemonic mnemonic

showCCurrency :: CT.CCurrency -> String
showCCurrency = dropModuleName <<< gShow
  where
    -- TODO: this is again stupid. We should derive Show for this type instead of doing this
    dropModuleName = unsafePartial last <<< split dot

-- TODO: it would be useful to extend purescript-bridge
-- and generate lenses
walletAddressToUrl :: CWalletAddress -> String
walletAddressToUrl (CWalletAddress r) = _address r.cwaWSAddress <> "@" <> show r.cwaIndex

_hash :: CHash -> String
_hash (CHash h) = h

_address :: forall a. CAddress a -> String
_address (CAddress a) = _hash a

_passPhrase :: CPassPhrase -> String
_passPhrase (CPassPhrase p) = p

emptyCPassPhrase :: CPassPhrase
emptyCPassPhrase = CPassPhrase ""

mkCPassPhrase :: String -> Maybe CPassPhrase
mkCPassPhrase "" = Nothing
mkCPassPhrase pass = Just <<< CPassPhrase <<< bytesToB16 $ blake2b pass

mkCAddress :: forall a. String -> CAddress a
mkCAddress = CAddress <<< CHash

_ccoin :: CCoin -> String
_ccoin (CCoin c) = c.getCoin

mkCCoin :: String -> CCoin
mkCCoin amount = CCoin { getCoin: amount }

-- NOTE: use genericRead maybe https://github.com/paluh/purescript-generic-read-example
mkCWalletType :: String -> CT.CWalletType
mkCWalletType = either (const CT.CWTPersonal) id <<< decodeJson <<< fromString

mkCCurrency :: String -> CT.CCurrency
mkCCurrency = either (const CT.ADA) id <<< decodeJson <<< fromString

mkCWAssurance :: String -> CT.CWalletAssurance
mkCWAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCWalletMeta :: String -> String -> String -> String -> Int -> CT.CWalletMeta
mkCWalletMeta wType wCurrency wName wAssurance wUnit =
    CT.CWalletMeta { cwType: mkCWalletType wType
                   , cwCurrency: mkCCurrency wCurrency
                   , cwName: wName
                   , cwAssurance: mkCWAssurance wAssurance
                   , cwUnit: wUnit
                   }

mkCInitialized :: Int -> Int -> CT.CInitialized
mkCInitialized total preInit =
    CT.CInitialized { cTotalTime: fromInt total
                    , cPreInit: fromInt preInit
                    }

mkCWalletInit :: String -> String -> String -> CAddress WS -> CT.CWalletInit
mkCWalletInit wType wCurrency wName wSetId =
    CT.CWalletInit { cwInitWSetId: wSetId
                   , cwInitMeta: mkCWalletMeta wType wCurrency wName "CWANormal" 0 -- FIXME: don't use string!
                   }

mkCWalletSetInit :: String -> String -> Either Error CT.CWalletSetInit
mkCWalletSetInit wSetName mnemonic = do
    bp <- mkBackupPhrase backupMnemonicLen mnemonic
    pure $ CT.CWalletSetInit { cwsInitMeta: CWalletSetMeta {cwsName: wSetName }
                             , cwsBackupPhrase: bp
                             }

mkCWalletRedeem :: String -> CWalletAddress -> CT.CWalletRedeem
mkCWalletRedeem seed wAddress = do
    CT.CWalletRedeem { crWalletId: wAddress
                     , crSeed: seed
                     }

mkCPaperVendWalletRedeem :: String -> String -> CWalletAddress -> Either Error CT.CPaperVendWalletRedeem
mkCPaperVendWalletRedeem seed mnemonic wAddress = do
    bp <- mkBackupPhrase paperVendMnemonicLen mnemonic
    pure $ CT.CPaperVendWalletRedeem { pvWalletId: wAddress
                                     , pvBackupPhrase: bp
                                     , pvSeed: seed
                                     }

_ctxIdValue :: CT.CTxId -> String
_ctxIdValue (CT.CTxId tx) = _hash tx

mkCTxId :: String -> CT.CTxId
mkCTxId = CT.CTxId <<< CHash

mkCTxMeta :: String -> String -> String -> Number -> CT.CTxMeta
mkCTxMeta currency title description date =
    CT.CTxMeta { ctmCurrency: mkCCurrency currency
               , ctmTitle: title
               , ctmDescription: description
               , ctmDate: mkTime date
               }

mkCProfile :: String -> CT.CProfile
mkCProfile locale =
    CT.CProfile { cpLocale: locale
                }

getProfileLocale :: CT.CProfile -> String
getProfileLocale (CT.CProfile r) = r.cpLocale