Changed 'Start baby station' button to green

module Gonimo.UI.Socket.Views (view, viewParentChannelThumb) where

import Prelude
import Data.Array as Arr
import Data.Map as Map
import Gonimo.Client.Effects as Console
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Channel.Types as ChannelC
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream.Track as Track
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask, runReader)
import Control.Monad.Reader.Class (class MonadReader, ask)
import Control.Monad.State.Class (gets, modify, put, get, class MonadState)
import Data.Array (concat, fromFoldable)
import Data.Foldable (foldl)
import Data.Lens (use, to, (^?), (^.), _Just, (.=))
import Data.Map (Map)
import Data.Maybe (isNothing, isJust, maybe, fromMaybe, Maybe(Nothing, Just))
import Data.Monoid (mempty)
import Data.Profunctor (lmap)
import Data.Traversable (traverse_)
import Data.Tuple (uncurry, snd, Tuple(Tuple))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (wrapAction, noEffects, runGonimo, Component, liftChild, toParent, ComponentType, makeChildData, ToChild, onlyModify, Update, class MonadComponent)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.Db.Entities.Helpers (runFamily)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Internal (mkChannelProps, getParentChannels)
import Gonimo.UI.Socket.Lenses (streamURL, isAvailable, mediaStream, babyName, currentFamily, localStream, authData, newBabyName)
import Gonimo.UI.Socket.Message (decodeFromString)
import Gonimo.UI.Socket.Types (makeChannelId, toCSecret, toTheirId, ChannelId(ChannelId), channel, Props, State, Action(..))
import Gonimo.WebAPI.Lenses (deviceId, _AuthData)
import Gonimo.WebAPI.Subscriber (receiveSocketByFamilyIdByToDevice, receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Pux.Html (Html)
import Servant.Subscriber (Subscriptions)
import WebRTC.MediaStream (mediaStreamToBlob, createObjectURL, stopStream, MediaStreamConstraints(MediaStreamConstraints), getUserMedia, MediaStream, getTracks)
import WebRTC.RTC (RTCPeerConnection)

view :: forall ps. Props ps -> State -> Html Action
view props state =
    H.div [ A.className "container"
          , A.style [Tuple "width" "100%"]]
      [ H.h3 [] [ H.text "Baby Station Management"
                , H.br [] []
                , H.small []
                  [ H.text $ "Here you can promote a device to a baby station,"
                          <> " which means that this device can send video and"
                          <> " audio data, (if enabled) otherwise you need to"
                          <> " allow your browser to access the hardware."
                  ]
                ]
      , if state.isAvailable
         then viewOnline props state
         else viewOffline props state
      ]

viewOffline :: forall ps. Props ps -> State -> Html Action
viewOffline props state =
    H.div []
    [ viewPreviewVideo props state
    , H.div [ A.className "videoContainer" ] [ viewStartButton state ]
    , viewBabyNameSelect props state
    ]

viewOnline :: forall ps. Props ps -> State -> Html Action
viewOnline props state =
  H.div []
    [ viewPreviewVideo props state
    , viewStopButton state
    ]

viewPreviewVideo :: forall ps. Props ps -> State -> Html Action
viewPreviewVideo props state =
  H.div [ A.className "videoContainer" ]
        [ if state.previewEnabled
          then H.div [ A.className "closableBox"]
              [ H.a [ A.className "boxclose"
                      , E.onClick $ const $ EnablePreview false
                    ] []
              , viewVideo props state
              ]
          else H.div [ A.className "btn-group" ]
              [ H.button [ A.className "btn btn-default btn-block"
                          , E.onClick $ const $ EnablePreview true
                          , A.type_ "button" ]
                [ H.text "Adjust camera" ]
              ]
        ]

viewVideo :: forall ps. Props ps -> State -> Html Action
viewVideo props state =
  H.div [ A.className "videoContainer" ]
  [ case state.streamURL of
        Nothing -> H.span [] []
        Just url -> H.video [ A.src url
                            , A.autoPlay "true"
                            , A.controls true
                            , A.muted true
                            , A.width "100%"
                            ] []
  ]

viewBabyNameSelect :: forall ps. Props ps -> State -> Html Action
viewBabyNameSelect props state =
  let
    lastBabies = concat
                 <<< fromFoldable -- Maybe Array -> Array Array
                 <<< map (_.familyLastUsedBabyNames <<< runFamily)
                 $ props.family

   in
     H.div [ A.role "group" ]
       [ H.h3 [] [ H.text "Select a name for your baby station"
                 , H.br [][]
                 , H.small [] [H.text "the last few names you used were:"]]
       , H.div [ A.className "videoContainer list-group", A.role "group" ]
         $ (viewBabyButton state <$> lastBabies) <>
         [ H.a [ A.className $ "list-group-item "
                                   <> if state.newBabyName == state.babyName
                                       then "active"
                                       else "list-group-item-action"
               , E.onClick $ const (SetBabyName state.newBabyName) ]
             [ H.div [] [H.text "Or select a new name for this baby station "]
             , H.input [ A.type_ "text", A.className "form-control", A.placeholder "New baby name"
                   , E.onInput $ \ev -> SetNewBabyName ev.target.value
                   , A.value state.newBabyName ] []
             ]
         ]
       ]

viewBabyButton :: State -> String -> Html Action
viewBabyButton state baby =
   H.a [ A.className $ "list-group-item " <> if baby == state.babyName
                                               then "active"
                                               else "list-group-item-action"
       , E.onClick $ const $ SetBabyName baby
       ] [ H.text baby ]

viewStopButton :: State -> Html Action
viewStopButton state =
  H.div []
  [ H.h3 [] [ H.text $ "Baby monitor running for cute " <> state.babyName <> " …"]
  , H.div [A.className "videoContainer"]
    [ H.button [ A.className "btn btn-block btn-danger"
              , A.style [ Tuple "margin-left" "0px" ]
              , A.type_ "button"
              , E.onClick $ const $ StopBabyStation
              ]
      [ H.text "Stop Baby Monitor "
      , H.span [A.className "glyphicon glyphicon-off"] []
      ]
    ]
  ]

viewStartButton :: State -> Html Action
viewStartButton state =
  H.div []
  [
    H.button [ A.className "btn btn-block btn-success"
             , A.style [ Tuple "margin-left" "0px" ]
             , A.disabled $ isNothing state.localStream
             , A.type_ "button"
             , E.onClick $ const $ StartBabyStation
             ]
    [ H.text $ "Start Baby Station for cute " <> state.babyName <> " "
    , H.span [A.className "glyphicon glyphicon-transfer"] []
    ]
  , H.div []
    $ if isNothing state.localStream
      then [ H.div [ A.className "alert alert-danger" ]
             [ H.p [] [ H.text "We need to enable your camera/microphone first." ]
             , H.button [ A.className "btn btn-block btn-default"
                        , A.style [ Tuple "margin-left" "0px" ]
                        , A.type_ "button"
                        , E.onClick $ const $ GetUserMedia
                        ]
               [ H.text "Enable camera/microphone!" ]
             ]
           ]
      else []
  ]

viewParentChannelThumb :: forall ps. Props ps -> State
                          -> Tuple ChannelId ChannelC.State -> Html Action
viewParentChannelThumb props state (Tuple chanId cState) =
  ChannelA chanId <$> ChannelC.view (mkChannelProps props state chanId) cState

viewParentChannels :: forall ps. Props ps -> State -> Array (Html Action)
viewParentChannels props state = let
    channels = getParentChannels state
  in
     viewParentChannelThumb props state <$> channels

getSubscriptions :: forall ps. Props ps -> State -> Subscriptions Action
getSubscriptions props state =
  let
    authData' = state ^. authData <<< to runAuthData
    familyId' = state ^. currentFamily
    receiveAChannel deviceId' familyId'' =
      receiveSocketByFamilyIdByToDevice
        (maybe Nop (AcceptConnection <<< uncurry makeChannelId ) <<< join)
        familyId''
        deviceId'

    getChannelSubscriptions :: forall m. (MonadReader Settings m)
                                  => ChannelId -> m (Subscriptions Action)
    getChannelSubscriptions channelId' =
      let
        cProps = mkChannelProps props state channelId'
      in
      map (ChannelA channelId') <$> ChannelC.getSubscriptions cProps

    getChannelsSubscriptions :: forall m. (MonadReader Settings m)
                                => Map ChannelId ChannelC.State
                                -> Array (m (Subscriptions Action))
    getChannelsSubscriptions = Arr.fromFoldable <<< map getChannelSubscriptions <<< Map.keys

    subArray :: Array (Subscriptions Action)
    subArray = map (flip runReader props.settings)
                $ getChannelsSubscriptions state.channels
                <> ( if state.isAvailable
                     then fromFoldable $ do
                               familyId'' <- familyId'
                               pure $ receiveAChannel authData'.deviceId familyId''
                     else []
                   )
  in
     foldl append mempty subArray

module Gonimo.UI.Socket.Views (view, viewParentChannelThumb) where

import Prelude
import Data.Array as Arr
import Data.Map as Map
import Gonimo.Client.Effects as Console
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Channel.Types as ChannelC
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream.Track as Track
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask, runReader)
import Control.Monad.Reader.Class (class MonadReader, ask)
import Control.Monad.State.Class (gets, modify, put, get, class MonadState)
import Data.Array (concat, fromFoldable)
import Data.Foldable (foldl)
import Data.Lens (use, to, (^?), (^.), _Just, (.=))
import Data.Map (Map)
import Data.Maybe (isNothing, isJust, maybe, fromMaybe, Maybe(Nothing, Just))
import Data.Monoid (mempty)
import Data.Profunctor (lmap)
import Data.Traversable (traverse_)
import Data.Tuple (uncurry, snd, Tuple(Tuple))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (wrapAction, noEffects, runGonimo, Component, liftChild, toParent, ComponentType, makeChildData, ToChild, onlyModify, Update, class MonadComponent)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.Db.Entities.Helpers (runFamily)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Internal (mkChannelProps, getParentChannels)
import Gonimo.UI.Socket.Lenses (streamURL, isAvailable, mediaStream, babyName, currentFamily, localStream, authData, newBabyName)
import Gonimo.UI.Socket.Message (decodeFromString)
import Gonimo.UI.Socket.Types (makeChannelId, toCSecret, toTheirId, ChannelId(ChannelId), channel, Props, State, Action(..))
import Gonimo.WebAPI.Lenses (deviceId, _AuthData)
import Gonimo.WebAPI.Subscriber (receiveSocketByFamilyIdByToDevice, receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Pux.Html (Html)
import Servant.Subscriber (Subscriptions)
import WebRTC.MediaStream (mediaStreamToBlob, createObjectURL, stopStream, MediaStreamConstraints(MediaStreamConstraints), getUserMedia, MediaStream, getTracks)
import WebRTC.RTC (RTCPeerConnection)

view :: forall ps. Props ps -> State -> Html Action
view props state =
    H.div [ A.className "container"
          , A.style [Tuple "width" "100%"]]
      [ H.h3 [] [ H.text "Baby Station Management"
                , H.br [] []
                , H.small []
                  [ H.text $ "Here you can promote a device to a baby station,"
                          <> " which means that this device can send video and"
                          <> " audio data, (if enabled) otherwise you need to"
                          <> " allow your browser to access the hardware."
                  ]
                ]
      , if state.isAvailable
         then viewOnline props state
         else viewOffline props state
      ]

viewOffline :: forall ps. Props ps -> State -> Html Action
viewOffline props state =
    H.div []
    [ viewPreviewVideo props state
    , H.div [ A.className "videoContainer" ] [ viewStartButton state ]
    , viewBabyNameSelect props state
    ]

viewOnline :: forall ps. Props ps -> State -> Html Action
viewOnline props state =
  H.div []
    [ viewPreviewVideo props state
    , viewStopButton state
    ]

viewPreviewVideo :: forall ps. Props ps -> State -> Html Action
viewPreviewVideo props state =
  H.div [ A.className "videoContainer" ]
        [ if state.previewEnabled
          then H.div [ A.className "closableBox"]
              [ H.a [ A.className "boxclose"
                      , E.onClick $ const $ EnablePreview false
                    ] []
              , viewVideo props state
              ]
          else H.div [ A.className "btn-group" ]
              [ H.button [ A.className "btn btn-default btn-block"
                          , E.onClick $ const $ EnablePreview true
                          , A.type_ "button" ]
                [ H.text "Adjust camera" ]
              ]
        ]

viewVideo :: forall ps. Props ps -> State -> Html Action
viewVideo props state =
  H.div [ A.className "videoContainer" ]
  [ case state.streamURL of
        Nothing -> H.span [] []
        Just url -> H.video [ A.src url
                            , A.autoPlay "true"
                            , A.controls true
                            , A.muted true
                            , A.width "100%"
                            ] []
  ]

viewBabyNameSelect :: forall ps. Props ps -> State -> Html Action
viewBabyNameSelect props state =
  let
    lastBabies = concat
                 <<< fromFoldable -- Maybe Array -> Array Array
                 <<< map (_.familyLastUsedBabyNames <<< runFamily)
                 $ props.family

   in
     H.div [ A.role "group" ]
       [ H.h3 [] [ H.text "Select a name for your baby station"
                 , H.br [][]
                 , H.small [] [H.text "the last few names you used were:"]]
       , H.div [ A.className "videoContainer list-group", A.role "group" ]
         $ (viewBabyButton state <$> lastBabies) <>
         [ H.a [ A.className $ "list-group-item "
                                   <> if state.newBabyName == state.babyName
                                       then "active"
                                       else "list-group-item-action"
               , E.onClick $ const (SetBabyName state.newBabyName) ]
             [ H.div [] [H.text "Or select a new name for this baby station "]
             , H.input [ A.type_ "text", A.className "form-control", A.placeholder "New baby name"
                   , E.onInput $ \ev -> SetNewBabyName ev.target.value
                   , A.value state.newBabyName ] []
             ]
         ]
       ]

viewBabyButton :: State -> String -> Html Action
viewBabyButton state baby =
   H.a [ A.className $ "list-group-item " <> if baby == state.babyName
                                               then "active"
                                               else "list-group-item-action"
       , E.onClick $ const $ SetBabyName baby
       ] [ H.text baby ]

viewStopButton :: State -> Html Action
viewStopButton state =
  H.div []
  [ H.h3 [] [ H.text $ "Baby monitor running for cute " <> state.babyName <> " …"]
  , H.div [A.className "videoContainer"]
    [ H.button [ A.className "btn btn-block btn-danger"
              , A.style [ Tuple "margin-left" "0px" ]
              , A.type_ "button"
              , E.onClick $ const $ StopBabyStation
              ]
      [ H.text "Stop Baby Monitor "
      , H.span [A.className "glyphicon glyphicon-off"] []
      ]
    ]
  ]

viewStartButton :: State -> Html Action
viewStartButton state =
  H.div []
  [
    H.button [ A.className "btn btn-block btn-info"
             , A.style [ Tuple "margin-left" "0px" ]
             , A.disabled $ isNothing state.localStream
             , A.type_ "button"
             , E.onClick $ const $ StartBabyStation
             ]
    [ H.text $ "Start Baby Station for cute " <> state.babyName <> " "
    , H.span [A.className "glyphicon glyphicon-transfer"] []
    ]
  , H.div []
    $ if isNothing state.localStream
      then [ H.div [ A.className "alert alert-danger" ]
             [ H.p [] [ H.text "We need to enable your camera/microphone first." ]
             , H.button [ A.className "btn btn-block btn-default"
                        , A.style [ Tuple "margin-left" "0px" ]
                        , A.type_ "button"
                        , E.onClick $ const $ GetUserMedia
                        ]
               [ H.text "Enable camera/microphone!" ]
             ]
           ]
      else []
  ]

viewParentChannelThumb :: forall ps. Props ps -> State
                          -> Tuple ChannelId ChannelC.State -> Html Action
viewParentChannelThumb props state (Tuple chanId cState) =
  ChannelA chanId <$> ChannelC.view (mkChannelProps props state chanId) cState

viewParentChannels :: forall ps. Props ps -> State -> Array (Html Action)
viewParentChannels props state = let
    channels = getParentChannels state
  in
     viewParentChannelThumb props state <$> channels

getSubscriptions :: forall ps. Props ps -> State -> Subscriptions Action
getSubscriptions props state =
  let
    authData' = state ^. authData <<< to runAuthData
    familyId' = state ^. currentFamily
    receiveAChannel deviceId' familyId'' =
      receiveSocketByFamilyIdByToDevice
        (maybe Nop (AcceptConnection <<< uncurry makeChannelId ) <<< join)
        familyId''
        deviceId'

    getChannelSubscriptions :: forall m. (MonadReader Settings m)
                                  => ChannelId -> m (Subscriptions Action)
    getChannelSubscriptions channelId' =
      let
        cProps = mkChannelProps props state channelId'
      in
      map (ChannelA channelId') <$> ChannelC.getSubscriptions cProps

    getChannelsSubscriptions :: forall m. (MonadReader Settings m)
                                => Map ChannelId ChannelC.State
                                -> Array (m (Subscriptions Action))
    getChannelsSubscriptions = Arr.fromFoldable <<< map getChannelSubscriptions <<< Map.keys

    subArray :: Array (Subscriptions Action)
    subArray = map (flip runReader props.settings)
                $ getChannelsSubscriptions state.channels
                <> ( if state.isAvailable
                     then fromFoldable $ do
                               familyId'' <- familyId'
                               pure $ receiveAChannel authData'.deviceId familyId''
                     else []
                   )
  in
     foldl append mempty subArray


Change -> to ➞ (#91)

Change -> to ➞ (#91)

Use `➞` for pretty-printing.

-- | This module defines a pretty printer for Insect expressions.
module Insect.PrettyPrint
  ( pretty
  , prettyQuantity
  ) where

import Prelude

import Data.Array ((:))
import Data.Decimal as D

import Quantities as Q

import Insect.Language (BinOp(..), Expression(..), Func(..))
import Insect.Format (Markup)
import Insect.Format as F

-- | Pretty print a single operator.
prettyOp ∷ BinOp → Markup
prettyOp op = [ F.text (opToStr op) ]
  where
    opToStr Add       = " + "
    opToStr Sub       = " - "
    opToStr Mul       = " × "
    opToStr Div       = " / "
    opToStr Pow       = "^"
    opToStr ConvertTo = " ➞ "

-- | Pretty print a scalar value.
prettyScalar ∷ D.Decimal → Markup
prettyScalar n = [ F.val (D.toString n) ]

-- | Pretty print a physical unit.
prettyUnit ∷ Q.DerivedUnit → Markup
prettyUnit u = [ F.unit (Q.toString u) ]

-- | Pretty print a physical quantity.
prettyQuantity ∷ Q.Quantity → Markup
prettyQuantity q =
    [ F.val rec.number, F.text space, F.unit rec.unit ]
  where
    rec = Q.prettyPrint' q
    space = if rec.space then " " else ""

-- | Construct and pretty-print a physical quantity
prettyQuantity' ∷ D.Decimal → Q.DerivedUnit → Markup
prettyQuantity' s u = prettyQuantity (Q.quantity' s u)

-- | Pretty print a variable name.
prettyVariable ∷ String → Markup
prettyVariable name = [ F.ident name ]

-- | Petty print a function application.
prettyApply ∷ Func → Expression → Markup
prettyApply fn x = [ F.function (funcToStr fn)
                   , F.text "(" ] <> pretty x <> [ F.text ")" ]
  where
    funcToStr ∷ Func → String
    funcToStr Acosh = "acosh"
    funcToStr Acos  = "acos"
    funcToStr Asinh = "asinh"
    funcToStr Asin  = "asin"
    funcToStr Atanh = "atanh"
    funcToStr Atan  = "atan"
    funcToStr Ceil  = "ceil"
    funcToStr Cosh  = "cosh"
    funcToStr Cos   = "cos"
    funcToStr Exp   = "exp"
    funcToStr Floor = "floor"
    funcToStr Gamma = "gamma"
    funcToStr Log10 = "log10"
    funcToStr Ln    = "ln"
    funcToStr Round = "round"
    funcToStr Sinh  = "sinh"
    funcToStr Sin   = "sin"
    funcToStr Sqrt  = "sqrt"
    funcToStr Tanh  = "tanh"
    funcToStr Tan   = "tan"

-- | Add parenthesis.
parens ∷ Markup → Markup
parens m = F.text "(" : m <> [ F.text ")" ]

-- | Add parenthesis, if needed - conservative version for exponentiation.
withParens' ∷ Expression → Markup
withParens' u@(Unit _)     = pretty u
withParens' s@(Scalar _)   = pretty s
withParens' v@(Variable _) = pretty v
withParens' a@(Apply _ _)  = pretty a
withParens' x              = parens (pretty x)

-- | Add parenthesis, if needed - liberal version, can not be used for
-- | Exponentiation.
withParens ∷ Expression → Markup
withParens e@(BinOp Mul (Scalar s) (Unit u)) = pretty e
withParens e = withParens' e

-- | Pretty print an Insect expression.
pretty ∷ Expression → Markup
pretty (Scalar n)                      = prettyScalar n
pretty (Unit u)                        = prettyUnit u
pretty (Variable name)                 = prettyVariable name
pretty (Factorial x)                   = withParens x <> [F.text "!"]
pretty (Negate x)                      = F.text "-" : withParens x
pretty (Apply fn x)                    = prettyApply fn x
-- ConvertTo (->) never needs parens, it has the lowest precedence:
pretty (BinOp ConvertTo x y)           = pretty x <> prettyOp ConvertTo <> pretty y
-- Fuse multiplication of a scalar and a unit to a quantity:
pretty (BinOp Mul (Scalar s) (Unit u)) = prettyQuantity' s u
-- Leave out parens for multiplication, if possible:
pretty (BinOp Mul x y) = addP x <> prettyOp Mul <> addP y
  where
    addP ex = case ex of
                (BinOp Pow _ _) → pretty ex
                (BinOp Mul _ _) → pretty ex
                _               → withParens ex
-- Leave out parens for division, if possible:
pretty (BinOp Div x y) = addPLeft x <> prettyOp Div <> addPRight y
  where
    addPLeft ex = case ex of
                    (BinOp Pow _ _) → pretty ex
                    (BinOp Mul _ _) → pretty ex
                    _               → withParens ex
    addPRight ex = case ex of
                     (BinOp Pow _ _) → pretty ex
                     _               → withParens ex
-- Leave out parens for addition, if possible:
pretty (BinOp Add x y) = addP x <> prettyOp Add <> addP y
  where
    addP ex = case ex of
                (BinOp Pow _ _) → pretty ex
                (BinOp Mul _ _) → pretty ex
                (BinOp Add _ _) → pretty ex
                _               → withParens ex
-- Leave out parens for subtraction, if possible:
pretty (BinOp Sub x y) = addP x <> prettyOp Sub <> addP y
  where
    addP ex = case ex of
                (BinOp Pow _ _) → pretty ex
                (BinOp Mul _ _) → pretty ex
                _               → withParens ex
pretty (BinOp op x y) = withParens' x <> prettyOp op <> withParens' y

-- | This module defines a pretty printer for Insect expressions.
module Insect.PrettyPrint
  ( pretty
  , prettyQuantity
  ) where

import Prelude

import Data.Array ((:))
import Data.Decimal as D

import Quantities as Q

import Insect.Language (BinOp(..), Expression(..), Func(..))
import Insect.Format (Markup)
import Insect.Format as F

-- | Pretty print a single operator.
prettyOp ∷ BinOp → Markup
prettyOp op = [ F.text (opToStr op) ]
  where
    opToStr Add       = " + "
    opToStr Sub       = " - "
    opToStr Mul       = " × "
    opToStr Div       = " / "
    opToStr Pow       = "^"
    opToStr ConvertTo = " -> "

-- | Pretty print a scalar value.
prettyScalar ∷ D.Decimal → Markup
prettyScalar n = [ F.val (D.toString n) ]

-- | Pretty print a physical unit.
prettyUnit ∷ Q.DerivedUnit → Markup
prettyUnit u = [ F.unit (Q.toString u) ]

-- | Pretty print a physical quantity.
prettyQuantity ∷ Q.Quantity → Markup
prettyQuantity q =
    [ F.val rec.number, F.text space, F.unit rec.unit ]
  where
    rec = Q.prettyPrint' q
    space = if rec.space then " " else ""

-- | Construct and pretty-print a physical quantity
prettyQuantity' ∷ D.Decimal → Q.DerivedUnit → Markup
prettyQuantity' s u = prettyQuantity (Q.quantity' s u)

-- | Pretty print a variable name.
prettyVariable ∷ String → Markup
prettyVariable name = [ F.ident name ]

-- | Petty print a function application.
prettyApply ∷ Func → Expression → Markup
prettyApply fn x = [ F.function (funcToStr fn)
                   , F.text "(" ] <> pretty x <> [ F.text ")" ]
  where
    funcToStr ∷ Func → String
    funcToStr Acosh = "acosh"
    funcToStr Acos  = "acos"
    funcToStr Asinh = "asinh"
    funcToStr Asin  = "asin"
    funcToStr Atanh = "atanh"
    funcToStr Atan  = "atan"
    funcToStr Ceil  = "ceil"
    funcToStr Cosh  = "cosh"
    funcToStr Cos   = "cos"
    funcToStr Exp   = "exp"
    funcToStr Floor = "floor"
    funcToStr Gamma = "gamma"
    funcToStr Log10 = "log10"
    funcToStr Ln    = "ln"
    funcToStr Round = "round"
    funcToStr Sinh  = "sinh"
    funcToStr Sin   = "sin"
    funcToStr Sqrt  = "sqrt"
    funcToStr Tanh  = "tanh"
    funcToStr Tan   = "tan"

-- | Add parenthesis.
parens ∷ Markup → Markup
parens m = F.text "(" : m <> [ F.text ")" ]

-- | Add parenthesis, if needed - conservative version for exponentiation.
withParens' ∷ Expression → Markup
withParens' u@(Unit _)     = pretty u
withParens' s@(Scalar _)   = pretty s
withParens' v@(Variable _) = pretty v
withParens' a@(Apply _ _)  = pretty a
withParens' x              = parens (pretty x)

-- | Add parenthesis, if needed - liberal version, can not be used for
-- | Exponentiation.
withParens ∷ Expression → Markup
withParens e@(BinOp Mul (Scalar s) (Unit u)) = pretty e
withParens e = withParens' e

-- | Pretty print an Insect expression.
pretty ∷ Expression → Markup
pretty (Scalar n)                      = prettyScalar n
pretty (Unit u)                        = prettyUnit u
pretty (Variable name)                 = prettyVariable name
pretty (Factorial x)                   = withParens x <> [F.text "!"]
pretty (Negate x)                      = F.text "-" : withParens x
pretty (Apply fn x)                    = prettyApply fn x
-- ConvertTo (->) never needs parens, it has the lowest precedence:
pretty (BinOp ConvertTo x y)           = pretty x <> prettyOp ConvertTo <> pretty y
-- Fuse multiplication of a scalar and a unit to a quantity:
pretty (BinOp Mul (Scalar s) (Unit u)) = prettyQuantity' s u
-- Leave out parens for multiplication, if possible:
pretty (BinOp Mul x y) = addP x <> prettyOp Mul <> addP y
  where
    addP ex = case ex of
                (BinOp Pow _ _) → pretty ex
                (BinOp Mul _ _) → pretty ex
                _               → withParens ex
-- Leave out parens for division, if possible:
pretty (BinOp Div x y) = addPLeft x <> prettyOp Div <> addPRight y
  where
    addPLeft ex = case ex of
                    (BinOp Pow _ _) → pretty ex
                    (BinOp Mul _ _) → pretty ex
                    _               → withParens ex
    addPRight ex = case ex of
                     (BinOp Pow _ _) → pretty ex
                     _               → withParens ex
-- Leave out parens for addition, if possible:
pretty (BinOp Add x y) = addP x <> prettyOp Add <> addP y
  where
    addP ex = case ex of
                (BinOp Pow _ _) → pretty ex
                (BinOp Mul _ _) → pretty ex
                (BinOp Add _ _) → pretty ex
                _               → withParens ex
-- Leave out parens for subtraction, if possible:
pretty (BinOp Sub x y) = addP x <> prettyOp Sub <> addP y
  where
    addP ex = case ex of
                (BinOp Pow _ _) → pretty ex
                (BinOp Mul _ _) → pretty ex
                _               → withParens ex
pretty (BinOp op x y) = withParens' x <> prettyOp op <> withParens' y


Add Signature newtype for prelude bitfield

module Lambda.Language.Snapshot.Signature
  ( Signature
  , deflate
  , inflate
  , nil
  ) where

import Lambda.Prelude

import Data.Array as Array
import Data.Int.Bits ((.&.), (.|.))
import Lambda.Language.Definition (Definition(..))
import Lambda.Language.Prelude as Prelude

-- | Bit field indicating which prelude definitions are used
newtype Signature = Signature Int

derive newtype instance eqSignature :: Eq Signature
derive newtype instance showSignature :: Show Signature
derive newtype instance readForeignSignature :: ReadForeign Signature
derive newtype instance writeForeignSignature :: WriteForeign Signature

-- | Empty Signature uses no prelude definitions
nil :: Signature
nil = Signature 0

-- | Generate prelude signature by OR'ing together ids
deflate :: Array Definition -> Signature
deflate = Signature <<< flip foldl 0 \acc (Definition {id}) -> acc .|. id

-- | Convert signature back into prelude definitions
inflate :: Signature -> Array Definition
inflate (Signature sig) = Array.filter used Prelude.defs
 where
  used (Definition {id}) = (id .&. sig) /= 0

error: pathspec 'frontend/src/Lambda/Language/Snapshot/Signature.purs' did not match any file(s) known to git


adds js interface

adds js interface

module ModulusCheck.JavaScript
       ( ModulusCheckResult
       , check
       ) where

import Prelude ((>>>))
import Data.Either (either)
import Data.Function.Uncurried (Fn2, mkFn2)

import ModulusCheck as M

type ModulusCheckResult = { isValid :: Boolean
                          , isError :: Boolean
                          , error   :: String  }

check :: Fn2 String String ModulusCheckResult
check =
  mkFn2 \sortCode accountNumber ->
    either { isValid: false, isError: true, error: _ } { isValid: _, isError: false, error: "" }
           (M.check sortCode accountNumber)

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


Make appbar notification icons consistent accross new UI pages (#659)

* Swap enableNotifications flag to on by default

the enableNotifications flag on the template.purs was true by default.
It made more sense to be disableNotifications and false by default, so
that the most common case is the unset case.

* Remove inherit colour inline style on logout icon

logout icon was set to inherit colour which meant it was unaffected by
theming. Removed this style.

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


Move unsafe refFor from tests to lib

Move unsafe refFor from tests to lib

So that we can use it in tests for client projects.

Also removed some duplication in test code.

module Web.Firebase.UnsafeRef
  ( refFor
  ) where

import Control.Monad.Aff
import Control.Monad.Eff.Class (liftEff)
import Data.Either.Unsafe  (fromRight)
import Data.URI (runParseURI)
import qualified Web.Firebase as FB
import qualified Web.Firebase.Types as FBT

-- | Unsafely read a string that might be a reference, and turn it into a firebase reference
-- may throw javascript exceptions, intended to keep test code terse, not meant for production usage
refFor :: String -> forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
refFor s = do
  let fbUri = fromRight (runParseURI s)
  liftEff (FB.newFirebase fbUri)

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


simple render

simple render

module Graphics.Game where

import Prelude
import Data.Int
import Data.Array
import Control.Category ((<<<))
import Control.Monad.Eff (Eff)
import Data.Maybe (Maybe(..))
import Data.Monoid
import Graphics.Canvas (clearRect, getContext2D, getCanvasElementById, CANVAS)
import Graphics.Drawing (fillColor, Drawing, render, rectangle, filled, black)
import Data.Foldable
import Chat.ServerTypes

renderGame :: forall eff. Number -> Number -> String -> GameState -> Eff (canvas :: CANVAS | eff) Unit
renderGame cw ch id g =  do
  mCanvas <- getCanvasElementById id
  case mCanvas of
    Just canvas -> do
      ctx <- getContext2D canvas
      clearRect ctx {x: 0.0, y: 0.0, w: cw, h: ch}
      render ctx $ drawState g
    Nothing -> pure unit

drawState :: GameState -> Drawing
drawState (GameState i) =  filled (fillColor black) $ fold $ (\x -> (  rectangle x x 1.0 1.0)) <$> toNumber <$> range 0 i

error: pathspec 'static/purescript/src/Graphics/Game.purs' did not match any file(s) known to git


Add CanvasM

Add CanvasM

module CanvasM where

import Control.Monad.Eff (Eff())
import Control.Monad.Reader.Trans (ReaderT(), runReaderT, liftReaderT)
import Control.Monad.Reader.Class (ask)
import qualified Graphics.Canvas as GC

type CanvasM e a
  = ReaderT GC.Context2D (Eff (canvas :: GC.Canvas | e)) a

liftC :: forall a e.
  (GC.Context2D -> Eff (canvas :: GC.Canvas | e) a) -> CanvasM e Unit
liftC action = void $ ask >>= \ctx -> liftReaderT (action ctx)

runCanvasM :: forall a e.
  GC.Context2D -> CanvasM e a -> Eff (canvas :: GC.Canvas | e) a
runCanvasM = flip runReaderT

beginPath :: forall e. CanvasM e Unit
beginPath =
  liftC $ GC.beginPath

fillRect :: forall e. GC.Rectangle -> CanvasM e Unit
fillRect rect =
  liftC $ \ctx -> GC.fillRect ctx rect

translate :: forall e. GC.TranslateTransform -> CanvasM e Unit
translate tt =
  liftC $ GC.translate tt

rotate :: forall e. Number -> CanvasM e Unit
rotate a =
  liftC $ GC.rotate a

arc :: forall e. GC.Arc -> CanvasM e Unit
arc a =
  liftC $ \ctx -> GC.arc ctx a

moveTo :: forall e. Number -> Number -> CanvasM e Unit
moveTo x y =
  liftC $ \ctx -> GC.moveTo ctx x y

setFillStyle :: forall e. String -> CanvasM e Unit
setFillStyle style =
  liftC $ GC.setFillStyle style

setStrokeStyle :: forall e. String -> CanvasM e Unit
setStrokeStyle style =
  liftC $ GC.setFillStyle style

lineTo :: forall e. Number -> Number -> CanvasM e Unit
lineTo x y =
  liftC $ \ctx -> GC.lineTo ctx x y

withContext :: forall e. CanvasM e Unit -> CanvasM e Unit
withContext action =
  liftC $ \ctx -> GC.withContext ctx (runCanvasM ctx action)

stroke :: forall e. CanvasM e Unit
stroke =
  liftC GC.stroke

fill :: forall e. CanvasM e Unit
fill =
  liftC GC.fill

clearRect :: forall e. GC.Rectangle -> CanvasM e Unit
clearRect rect =
  liftC $ \ctx -> GC.clearRect ctx rect

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


add testing

add testing

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/aspidites/purescript-generics.git/'


Remove unnecessary do block.

Remove unnecessary do block.

module Data.AddressBook.UI where

import Data.Maybe
import Data.Either
import Data.Foreign
import Data.AddressBook
import Data.AddressBook.Validation

import Data.Traversable

import Control.Bind

import Control.Monad.Eff
import Control.Monad.Eff.DOM

import Debug.Trace

valueOf :: forall eff. String -> Eff (dom :: DOM | eff) String
valueOf sel = do
  maybeEl <- querySelector sel
  case maybeEl of
    Nothing -> return ""
    Just el -> do
      value <- getValue el
      return $ case parseForeign read value of
        Right s -> s
        _ -> ""

displayValidationErrors :: forall eff. [String] -> Eff (dom :: DOM | eff) Unit
displayValidationErrors errs = do
  alert <- createElement "div"
    >>= addClass "alert"
    >>= addClass "alert-danger"

  ul <- createElement "ul"
  ul `appendChild` alert

  foreachE errs $ \err -> do
    li <- createElement "li" >>= setText err
    li `appendChild` ul
    return unit

  Just validationErrors <- querySelector "#validationErrors"
  alert `appendChild` validationErrors

  return unit

validateControls :: forall eff. Eff (trace :: Trace, dom :: DOM | eff) Unit
validateControls = do
  trace "Running validators"

  p <- person <$> valueOf "#inputFirstName"
              <*> valueOf "#inputLastName"
              <*> (address <$> valueOf "#inputStreet"
                           <*> valueOf "#inputCity"
                           <*> valueOf "#inputState")
              <*> sequence [ phoneNumber HomePhone <$> valueOf "#inputHomePhone"
			   , phoneNumber CellPhone <$> valueOf "#inputCellPhone"
                           ]

  Just validationErrors <- querySelector "#validationErrors"
  setInnerHTML "" validationErrors

  case validatePerson' p of
    Left errs -> displayValidationErrors errs
    Right result -> print result

  return unit

setupEventHandlers :: forall eff. Eff (trace :: Trace, dom :: DOM | eff) Unit
setupEventHandlers = do
  -- Listen for changes on form fields
  body >>= addEventListener "change" validateControls

  return unit

module Data.AddressBook.UI where

import Data.Maybe
import Data.Either
import Data.Foreign
import Data.AddressBook
import Data.AddressBook.Validation

import Data.Traversable

import Control.Bind

import Control.Monad.Eff
import Control.Monad.Eff.DOM

import Debug.Trace

valueOf :: forall eff. String -> Eff (dom :: DOM | eff) String
valueOf sel = do
  maybeEl <- querySelector sel
  case maybeEl of
    Nothing -> return ""
    Just el -> do
      value <- getValue el
      return $ case parseForeign read value of
        Right s -> s
        _ -> ""

displayValidationErrors :: forall eff. [String] -> Eff (dom :: DOM | eff) Unit
displayValidationErrors errs = do
  alert <- createElement "div"
    >>= addClass "alert"
    >>= addClass "alert-danger"

  ul <- createElement "ul"
  ul `appendChild` alert

  foreachE errs $ \err -> do
    li <- createElement "li" >>= setText err
    li `appendChild` ul
    return unit

  Just validationErrors <- querySelector "#validationErrors"
  alert `appendChild` validationErrors

  return unit

validateControls :: forall eff. Eff (trace :: Trace, dom :: DOM | eff) Unit
validateControls = do
  trace "Running validators"

  p <- person <$> valueOf "#inputFirstName"
              <*> valueOf "#inputLastName"
              <*> (address <$> valueOf "#inputStreet"
                           <*> valueOf "#inputCity"
                           <*> valueOf "#inputState")
              <*> sequence [ phoneNumber HomePhone <$> valueOf "#inputHomePhone"
			   , phoneNumber CellPhone <$> valueOf "#inputCellPhone"
                           ]

  Just validationErrors <- querySelector "#validationErrors"
  setInnerHTML "" validationErrors

  case validatePerson' p of
    Left errs -> displayValidationErrors errs
    Right result -> do
      print result

  return unit

setupEventHandlers :: forall eff. Eff (trace :: Trace, dom :: DOM | eff) Unit
setupEventHandlers = do
  -- Listen for changes on form fields
  body >>= addEventListener "change" validateControls

  return unit


start of 3d

start of 3d

module Life3 where

import Prelude
import Life
import Life as Life
import Control.Apply (lift2, lift3)
import Control.Comonad (class Comonad, extract)
import Control.Comonad.Trans.Class (class ComonadTrans, lower)
import Control.Extend (class Extend, extend)
import Data.Array (filter, length)
import Data.Foldable (class Foldable)
import Data.Identity (Identity)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (class Traversable, traverse)
import Data.Unfoldable (class Unfoldable, replicate)

newtype ZZ a = ZZ (ZipperT Identity (ZipperT Identity (ZipperT Identity a)))

derive instance newtypeZZ :: Newtype (ZZ a) _
derive newtype instance eqZZ :: (Eq a) => Eq (ZZ a)
derive newtype instance ordZZ :: (Ord a) => Ord (ZZ a)

instance showZZ :: (Show a) => Show (ZZ a) where
  show z = show z'
    where z' :: Array (Array (Array a))
          z' = toUnfoldable z

instance functorZZ :: Functor ZZ where
    map f (ZZ z) = ZZ (map ((map <<< map) f) z)

instance extendZZ :: Extend ZZ where
  extend f (ZZ w) = ZZ (extend (map (f <<< ZZ) <<< rotations) w)

instance comonadZZ :: Comonad ZZ where
    extract (ZZ z) = extract (extract (extract z))

zzUp (ZZ z) = ZZ (up z)
zzDown (ZZ z) = ZZ (down z)
zzLeft (ZZ z) = ZZ (map up z)
zzRight (ZZ z) = ZZ (map down z)
zzIn (ZZ z) = ZZ (map (map up) z)
zzOut (ZZ z) = ZZ (map (map down) z)

emptyZZ :: forall a. (Bounded a) => ZZ a
emptyZZ = ZZ (zipper (zipper (zipper bottom)))

-- | Neighbors in all 8 directions
neighbors :: forall a. Array (ZZ a -> ZZ a)
neighbors = horiz <> vert <> lift2 (>>>) horiz vert <> lift3 (\x y z -> x >>> y >>> z) horiz vert depth
  where horiz = [zzLeft, zzRight]
        vert = [zzUp, zzDown]
        depth = [zzIn, zzOut]

-- | Boundaries are considered dead.
aliveNeighbors :: Z Boolean -> Int
aliveNeighbors z = length <<< filter id $ map (\x -> extract (x z)) neighbors

rule :: Z Boolean -> Boolean
rule z =
  case aliveNeighbors z of
    2 -> extract z
    3 -> true
    _ -> false

evolve :: ZZ Boolean -> ZZ Boolean
evolve = extend rule

toUnfoldable :: forall f a. (Unfoldable f, Functor f) => ZZ a -> f (f (f a))
toUnfoldable (ZZ z) = map (Life.toUnfoldable <<< Z) (toUnfoldableT z)

fromFoldable :: forall a f. (Traversable f, Foldable f) => f (f (f a)) -> Maybe (ZZ a)
fromFoldable x = ZZ <$> (traverse fromFoldable' x >>= fromFoldableT)
  where fromFoldable' = map (\(Z z) -> z) <<< Life.fromFoldable

mkZZ :: forall a. (Bounded a) => Array (Array a) -> Z a
mkZZ = fromMaybe emptyZZ <<< fromFoldable

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


Add Scale module

Add Scale module

module Graphics.D3.Scale
  ( LinearScale()
  , linearScale
  , domain
  , range
  , freeze
  ) where

foreign import data LinearScale :: *

import Graphics.D3.Base

foreign import linearScale
  "var linearScale = d3.scale.linear"
  :: forall e. D3Eff e LinearScale

foreign import domain
  "function domain(min) {\
  \  return function (max) {\
  \    return function (scale) {\
  \      return function () {\
  \        return scale.domain([min, max]);\
  \      };\
  \    };\
  \  };\
  \}"
  :: forall e. Number -> Number -> LinearScale -> D3Eff e LinearScale

foreign import range
  "function range(min) {\
  \  return function (max) {\
  \    return function (scale) {\
  \      return function () {\
  \        return scale.range([min, max]);\
  \      };\
  \    };\
  \  };\
  \}"
  :: forall e. Number -> Number -> LinearScale -> D3Eff e LinearScale

foreign import freeze
  "function freeze(scale) {\
  \  return function () {\
  \    return scale.copy();\
  \  };\
  \}"
  :: forall e. LinearScale -> D3Eff e (Number -> Number)

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


prefer function comp

prefer function comp

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/'


Test for accidental renamer ident shadowing

module Main where

import Control.Monad.Eff
import Debug.Trace

foreign import f
  "function f(x) {\
  \  return function () {\
  \    if (x !== 2) throw new Error('x is not 2');\
  \  }\
  \}" :: forall e. Number -> Eff e Number

foo foo = let foo_1 = \_ -> foo
              foo_2 = foo_1 unit + 1
          in foo_2

main = do
  f (foo 1)
  trace "Done"

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


Updated development version notice

Updated development version notice

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 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.Function.Uncurried (Fn3, runFn3)
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 (Attribute, br)
import Pux.Html.Events (MouseEvent)
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
            | 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
  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)

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

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 is early development software. It has been tested successfully on Chrome, Firefox and Opera."
              ]
            , p []
              [ text $ "Apple iOS devices are not yet supported! They will be supported, once Apple supports 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"
                           , onClickWithCopy "invitationLinkUrlInput" $ const $ InvitationSent SentCopyPaste
                           ]
                  [ 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

-- Triger acttion but also call copyTextFromId, this needs to be done directly
-- in order to make it work in all browsers.
onClickWithCopy :: forall action. String -> (MouseEvent -> action) -> Attribute action
onClickWithCopy id_ = runFn3 handlerWithCopy id_ "onClick"

foreign import handlerWithCopy :: forall ev a. Fn3 String String (ev -> a) (Attribute a)

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 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.Function.Uncurried (Fn3, runFn3)
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 (Attribute, br)
import Pux.Html.Events (MouseEvent)
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
            | 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
  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)

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

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"
                           , onClickWithCopy "invitationLinkUrlInput" $ const $ InvitationSent SentCopyPaste
                           ]
                  [ 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

-- Triger acttion but also call copyTextFromId, this needs to be done directly
-- in order to make it work in all browsers.
onClickWithCopy :: forall action. String -> (MouseEvent -> action) -> Attribute action
onClickWithCopy id_ = runFn3 handlerWithCopy id_ "onClick"

foreign import handlerWithCopy :: forall ev a. Fn3 String String (ev -> a) (Attribute a)


fix layout for small screens

fix layout for small screens

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.DbEntities (Invitation(Invitation), Family(Family))
import Gonimo.Server.Types (InvitationDelivery(EmailInvitation), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Key(Key), Secret(Secret))
import Gonimo.WebAPI (postInvitationsOutbox, postInvitationsByFamilyId, postFamilies, SPParams_(SPParams_), postAccounts, postFunnyName)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (a, button, br, i, input, p, h1, h2, h3, text, span, Html, img, div, small, li, ul, nav)
import Pux.Html.Attributes (letterSpacing, offset)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (gDefaultEncodeURLPiece, defaultSettings, SPSettings_(SPSettings_))
import Signal (constant, Signal)
import Prelude hiding (div)

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

type State =
  { email          :: String
  , 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"
                            <> " families, you only have to visit the"
                            <> " following one-time link on another device." ]
                    ]
            , 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"] []
                  ]
                ]
              ]
            ]
          ]
        , div [ A.className "container"
              , A.style [Tuple "width" "100%"]]
          [ h3 [] [text "copy & paste or share directly"]
          , div [A.className "jumbotron"]
            [ p [] [ text $ "You can either copy & paste it to send it via some means"
                        <> " or share it directly with WhatsApp or Telegram."
                  ]
            , H.div [ A.className "btn-group btn-group-justified" ]
              [
                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"]
                  ]
                ]
              , 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"]
                  ]
                ]
              ]
            , 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"] []
              ]
            ]
          , viewSent props state
          , div [ A.className "container"
                , A.style [Tuple "width" "100%"]]
              [ text "Invitation successfully transmitted? Then go back to overview or make this device a baby station right away .... " ]
          , nav []
            [ ul [ A.className "pager" ]
              [ li [ A.className "previous"
                    , E.onClick $ const $ GoToOverview
                    ] [a [] [ span [A.ariaHidden "true"] [text "← "]
                            , 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 " →"]
                             ]
                      ]
              ]

            ]
          ]
        ]
  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.DbEntities (Invitation(Invitation), Family(Family))
import Gonimo.Server.Types (InvitationDelivery(EmailInvitation), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Key(Key), Secret(Secret))
import Gonimo.WebAPI (postInvitationsOutbox, postInvitationsByFamilyId, postFamilies, SPParams_(SPParams_), postAccounts, postFunnyName)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (a, button, br, i, input, p, h1, h2, h3, text, span, Html, img, div, small, li, ul, nav)
import Pux.Html.Attributes (letterSpacing, offset)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (gDefaultEncodeURLPiece, defaultSettings, SPSettings_(SPSettings_))
import Signal (constant, Signal)
import Prelude hiding (div)

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

type State =
  { email          :: String
  , 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"
                            <> " families, you only have to visit the"
                            <> " following one-time link on another device." ]
                    ]
            , 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"] []
                  ]
                ]
              ]
            ]
          ]
        , div [ A.className "container"
              , A.style [Tuple "width" "100%"]]
          [ h3 [] [text "copy & paste or share directly"]
          , div [A.className "jumbotron"]
            [ p [] [ text $ "You can either copy & paste it to send it via some means"
                        <> " or share it directly with WhatsApp or Telegram."
                  ]
            , H.div [ A.className "btn-group btn-group-justified" ]
              [
                H.div [ A.className "btn-group" ]
                [
                  H.button [ A.className "btn btn-default"
                           , A.role "button"
                           , A.type_ "button"
                           , E.onClick $ const $ CopyToClipboard "invitationLinkUrlInput"
                           ]
                  [ H.span [ A.className "glyphicon glyphicon-copy"] []
                  , H.text " Copy to Clipboard"
                  ]
                ]
              , 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.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.text "Telegram"
                  ]
                ]
              ]
            , 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"] []
              ]
            ]
          , viewSent props state
          , div [ A.className "container"
                , A.style [Tuple "width" "100%"]]
              [ text "Invitation successfully transmitted? Then go back to overview or make this device a baby station right away .... " ]
          , nav []
            [ ul [ A.className "pager" ]
              [ li [ A.className "previous"
                    , E.onClick $ const $ GoToOverview
                    ] [a [] [ span [A.ariaHidden "true"] [text "← "]
                            , text "Back to Overview"
                            ]
                      ]
              , li [ A.className "next"
                    , E.onClick $ const $ GoToBabyStation
                    ] [ a [] [ text "Make this device a baby station"
                            , span [A.ariaHidden "true"] [text " →"]
                            ]
                      ]
              ]

            ]
          ]
        ]
  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