fix `isJust` which was used when developing

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.DbEntities (Family(Family), Device(Device))
import Gonimo.Server.DbEntities.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 (postSocketByFamilyIdByToDevice, deleteOnlineStatusByFamilyIdByDeviceId)
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 []
    [ viewVideo 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 []
    [ 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" ]
             ]
      ]
      , viewStopButton state
    ]

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

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.DbEntities (Family(Family), Device(Device))
import Gonimo.Server.DbEntities.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 (postSocketByFamilyIdByToDevice, deleteOnlineStatusByFamilyIdByDeviceId)
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 []
    [ viewVideo 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 []
    [ 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" ]
             ]
      ]
      , viewStopButton state
    ]

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


Create Try.purs

Create Try.purs

module Thermite.Try where

import Prelude

import Control.Monad.Eff (Eff)
import Data.Maybe (fromJust)
import Data.Newtype (wrap)
import DOM (DOM) as DOM
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToParentNode) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import Partial.Unsafe (unsafePartial)
import React (createFactory) as R
import ReactDOM (render) as R
import Thermite as T

-- | The main method creates the task list component, and renders it to the document body.
defaultMain :: forall state action eff. T.Spec eff state Unit action -> state -> Eff (dom :: DOM.DOM | eff) Unit
defaultMain spec initialState = void do
  let component = T.createClass spec initialState
  document <- DOM.window >>= DOM.document
  container <- unsafePartial fromJust <$> DOM.querySelector (wrap "#app") (DOM.htmlDocumentToParentNode document)
  R.render (R.createFactory component unit) container

error: pathspec 'staging/thermite/src/Thermite/Try.purs' did not match any file(s) known to git


Fix output formatting

Fix output formatting

-- | This module defines the interpreter for Insect.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Array ((:), fromFoldable, singleton)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (foldMap, intercalate, foldl)
import Data.List (sortBy, filter, groupBy)
import Data.List.NonEmpty (NonEmptyList(..), head, length, zip)
import Data.Maybe (Maybe(..))
import Data.StrMap (lookup, insert, delete, toUnfoldable)
import Data.String (toLower)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)

import Quantities (Quantity, ConversionError(..))
import Quantities as Q

import Insect.Language (BinOp(..), Expression(..), Command(..), Identifier,
                        Statement(..), EvalError(..))
import Insect.Environment (Environment, StorageType(..), StoredValue(..),
                           StoredFunction(..), initialEnvironment,
                           MathFunction)
import Insect.Format (Markup)
import Insect.Format as F
import Insect.PrettyPrint (pretty, prettyQuantity)

-- | A type synonym for error handling. A value of type `Expect Number` is
-- | expected to be a number but might also result in an evaluation error.
type Expect = Either EvalError

-- | Different kinds of messages that will be returned by the interpreter.
data MessageType = Value | ValueSet | Info | Error

-- | The output type of the interpreter.
data Message = Message MessageType Markup | MQuit | MClear

-- | Check if the numerical value of a quantity is finite, throw a
-- | `NumericalError` otherwise.
checkFinite ∷ Quantity → Expect Quantity
checkFinite q | Q.isFinite q = pure q
              | otherwise    = Left NumericalError

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Scalar n)             = pure $ Q.scalar' n
eval env (Unit u)               = pure $ Q.quantity 1.0 u
eval env (Variable name)        = case lookup name env.values of
                                    Just (StoredValue _ q) → pure q
                                    Nothing → Left (LookupError name)
eval env (Factorial x)          = eval env x >>= Q.factorial >>> lmap QConversionError
eval env (Negate x)             = Q.qNegate <$> eval env x
eval env (Apply name xs)        = case lookup name env.functions of
                                    Just (StoredFunction _ fn) →
                                      traverse (eval env) xs >>= fn >>= checkFinite
                                    Nothing → Left (LookupError name)
eval env (BinOp op x y)         = do
  x' <- eval env x
  y' <- eval env y
  (run op) x' y' >>= checkFinite
  where
    run :: BinOp -> Quantity -> Quantity -> Expect Quantity
    run Sub       a b = qSubtract a b
    run Add       a b = qAdd a b
    run Mul       a b = pure (Q.qMultiply a b)
    run Div       a b = pure (Q.qDivide a b)
    run Pow       a b = Q.pow a <$> toScalar b
    run Mod       a b = modulo a b
    run ConvertTo a b = convertTo a b

    wrap ∷ ∀ a. Either ConversionError a → Either EvalError a
    wrap = lmap QConversionError

    qSubtract q1 q2 = wrap (Q.qSubtract q1 q2)
    qAdd q1 q2 = wrap (Q.qAdd q1 q2)
    toScalar q = wrap (Q.toScalar' q)
    modulo q1 q2 = wrap (Q.modulo q1 q2)
    convertTo source target = wrap (Q.convertTo source (Q.derivedUnit target))

-- | Like `eval`, but calls `fullSimplify` on the result if the user did not
-- | ask for an explicit conversion.
evalAndSimplify ∷ Environment → Expression → Expect Quantity
evalAndSimplify env e@(BinOp ConvertTo _ _) = eval env e
evalAndSimplify env e = Q.fullSimplify <$> eval env e

-- | Render the error message for a conversion error.
conversionErrorMessage ∷ ConversionError → Markup
conversionErrorMessage (ConversionError u1 u2) =
  if u1 == Q.unity
    then
      [ F.error "  Conversion error:", F.nl, F.nl
      , F.text "    Cannot convert a ", F.unit "scalar"
      , F.text " to a quantity of unit ", F.unit (Q.toString u2)
      ]
    else
      if u2 == Q.unity
        then
          [ F.error "  Conversion error:", F.nl, F.nl
          , F.text "    Cannot convert quantity of unit "
          , F.unit (Q.toString u1)
          , F.text " to a ", F.unit "scalar"
          ]
        else
            [ F.error "  Conversion error:", F.nl, F.nl
            , F.text "    Cannot convert unit ", F.unit (Q.toString u1)
            ] <> baseRep u1 <>
            [ F.nl
            , F.text "                to unit ", F.unit (Q.toString u2)
            ] <> baseRep u2
  where
    baseRep u =
      if fst (Q.toStandardUnit u) == Q.unity
        then []
        else
          if Q.toString u == F.format F.fmtPlain usStrs
            then []
            else br
      where
        br = F.text " (base units: " : usStrs <> [ F.text ")" ]
        us = Q.baseRepresentation u
        us' = sortBy (comparing Q.toString) us
        usStrs = intercalate [ F.text "·" ] $
                   map (singleton <<< F.unit <<< Q.toString) us'

-- | Get the error message for an evaluation error.
evalErrorMessage ∷ EvalError → Markup
evalErrorMessage (QConversionError ue) =
  conversionErrorMessage ue
evalErrorMessage (WrongArityError fn expected given) =
  [ F.optional (F.text "  ")
  , F.error "Wrong number of arguments:", F.nl, F.nl
  , F.text "    The function '", F.function fn, F.text "'"
  , F.text " takes ", F.val (show expected)
  , F.text (if expected == 1 then " argument" else " arguments")
  , F.text " (got ", F.val (show given), F.text ")"
  ]
evalErrorMessage (LookupError name) =
  [ F.optional (F.text "  ")
  , F.error "Unknown identifier: "
  , F.ident name]
evalErrorMessage NumericalError =
  [ F.optional (F.text "  ")
  , F.error "Numerical error: "
  , F.text "division by zero or out-of-bounds error" ]
evalErrorMessage (RedefinedConstantError name) =
  [ F.optional (F.text "  ")
  , F.error "Assignment error: ", F.text "'", F.emph name
  , F.text "' cannot be redefined." ]

-- | Interpreter return type.
type Response = { msg ∷ Message, newEnv ∷ Environment }

-- | Show pretty-printed input and the error message.
errorWithInput ∷ Markup → Expression → Environment → EvalError → Response
errorWithInput prefix expr env err =
  { msg: Message Error $ (F.optional <$> F.text "  " : prefix <> pretty expr)
                         <> (F.optional <$> [ F.nl, F.nl ])
                         <> evalErrorMessage err
  , newEnv: env
  }

-- | Check whether a given identifier is the name of a constant value/function.
isConstant ∷ Environment → Identifier → Boolean
isConstant env name = isConstantValue || isConstantFunction
  where
    isConstantValue =
      case lookup name env.values of
        Just (StoredValue Constant _)       → true
        Just (StoredValue HiddenConstant _) → true
        _ → false
    isConstantFunction =
      case lookup name env.functions of
        Just (StoredFunction Constant _)       → true
        Just (StoredFunction HiddenConstant _) → true
        _ → false

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → Response
runInsect env (Expression e) =
  case evalAndSimplify env e of
    Left evalErr → errorWithInput [] e env evalErr
    Right value →
      { msg: Message Value $    (F.optional <$> F.text "  " : pretty e)
                             <> (F.optional <$> [ F.nl, F.nl , F.text "   = " ])
                             <> prettyQuantity value
      , newEnv: env { values = insert "ans" (StoredValue UserDefined value) env.values }
      }

runInsect env (VariableAssignment name val) =
  case evalAndSimplify env val of
    Left evalErr → errorWithInput [ F.ident name, F.text " = " ] val env evalErr
    Right value →
      if isConstant env name
        then
          errorWithInput [ F.ident name, F.text " = " ] val env (RedefinedConstantError name)
        else
          { msg: Message ValueSet $
                      (F.optional <$> [ F.text "  ", F.ident name, F.text " = " ])
                   <> prettyQuantity value
          , newEnv: env { values = insert name (StoredValue UserDefined value) env.values
                        , functions = delete name env.functions }
          }

runInsect env (FunctionAssignment name argNames expr) =
  if isConstant env name
    then
      errorWithInput fAssign expr env (RedefinedConstantError name)
    else
      { msg: Message ValueSet $ (F.optional <$> (F.text "  " : fAssign)) <> pretty expr
      , newEnv: env { functions = insert name (StoredFunction UserDefined userFunc) env.functions
                    , values = delete name env.values
                    }
      }
  where
    argNames' = NonEmptyList argNames
    numExpected = length argNames'

    fArgs = intercalate [ F.text ", " ] ((\a → [ F.ident a ]) <$> argNames)
    fAssign = [ F.function name, F.text "(" ] <> fArgs <> [ F.text ") = " ]

    userFunc ∷ MathFunction
    userFunc argValues =
      if numGiven == numExpected
        then evalAndSimplify functionEnv expr
        else Left (WrongArityError name numExpected numGiven)
      where
        argValues' = NonEmptyList argValues
        numGiven = length argValues'
        args = zip argNames' argValues'

        insertArg map (Tuple argName val) = insert argName (StoredValue UserDefined val) map
        functionEnv = env { values = foldl insertArg env.values args
                          , functions = delete name env.functions
                          }

runInsect env (Command Help) = { msg: Message Info
  [ F.emph "insect", F.text " evaluates mathematical expressions that can", F.nl
  , F.text "involve physical quantities. You can start by trying", F.nl
  , F.text "one of these examples:", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.val "1920", F.text " / ", F.val "16", F.text " * ", F.val "9", F.text "         "
  , F.emph "  > ", F.function "sin", F.text "(", F.val "30", F.text " ", F.unit "deg", F.text ")", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.val "2", F.text " ", F.unit "min", F.text " + ", F.val "30", F.text " ", F.unit "s", F.text "          "
  , F.emph "  > ", F.val "6", F.text " ", F.unit "Mbit/s", F.text " * ", F.val "1.5", F.text " ", F.unit "h", F.text " -> ", F.unit "GB", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.text "list", F.text "                  "
  , F.emph "  > ", F.ident "r", F.text " = ", F.val "80", F.text " ", F.unit "cm", F.nl
  , F.emph "  > ", F.val "40000", F.text " ", F.unit "km", F.text " / ", F.ident "c", F.text " -> ", F.unit "ms", F.text "    "
  , F.emph "  > ", F.ident "pi", F.text " * ", F.ident "r", F.text "^", F.val "2", F.text " -> ", F.unit "m", F.text "^", F.val "2", F.nl
  , F.text "", F.nl
  , F.text "Full documentation: https://github.com/sharkdp/insect"
  ], newEnv : env }

runInsect env (Command List) =
  { msg: Message Info list
  , newEnv: env }
  where
    storedValue (StoredValue _ value) = value
    storageType (StoredValue t _) = t
    visibleValues = filter (\e → storageType (snd e) /= HiddenConstant) (toUnfoldable env.values)
    envTuples = sortBy (comparing (_.number <<< Q.prettyPrint' <<< storedValue <<< snd)) visibleValues
    envGrouped = groupBy (\x y → storedValue (snd x) == storedValue (snd y)) envTuples
    envSorted = sortBy (comparing (toLower <<< fst <<< head)) envGrouped
    list = [ F.text "List of variables:", F.nl ] <> foldMap toLine envSorted
    toLine kvPairs =
         [ F.nl, F.text "  " ]
      <> identifiers
      <> [ F.text " = " ]
      <> prettyQuantity val
        where
          identifiers = fromFoldable $ intercalate [ F.text " = " ] $
                          (singleton <<< F.ident <<< fst) <$> kvPairs
          val = storedValue (snd (head kvPairs))

runInsect env (Command Reset) =
  { msg: Message Info [F.text "Environment has been reset."]
  , newEnv: initialEnvironment }

runInsect env (Command Quit) = { msg: MQuit, newEnv: initialEnvironment }

runInsect env (Command Clear) = { msg: MClear, newEnv: env }

-- | This module defines the interpreter for Insect.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Array ((:), fromFoldable, singleton)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (foldMap, intercalate, foldl)
import Data.List (sortBy, filter, groupBy)
import Data.List.NonEmpty (NonEmptyList(..), head, length, zip)
import Data.Maybe (Maybe(..))
import Data.StrMap (lookup, insert, delete, toUnfoldable)
import Data.String (toLower)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)

import Quantities (Quantity, ConversionError(..))
import Quantities as Q

import Insect.Language (BinOp(..), Expression(..), Command(..), Identifier,
                        Statement(..), EvalError(..))
import Insect.Environment (Environment, StorageType(..), StoredValue(..),
                           StoredFunction(..), initialEnvironment,
                           MathFunction)
import Insect.Format (Markup)
import Insect.Format as F
import Insect.PrettyPrint (pretty, prettyQuantity)

-- | A type synonym for error handling. A value of type `Expect Number` is
-- | expected to be a number but might also result in an evaluation error.
type Expect = Either EvalError

-- | Different kinds of messages that will be returned by the interpreter.
data MessageType = Value | ValueSet | Info | Error

-- | The output type of the interpreter.
data Message = Message MessageType Markup | MQuit | MClear

-- | Check if the numerical value of a quantity is finite, throw a
-- | `NumericalError` otherwise.
checkFinite ∷ Quantity → Expect Quantity
checkFinite q | Q.isFinite q = pure q
              | otherwise    = Left NumericalError

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Scalar n)             = pure $ Q.scalar' n
eval env (Unit u)               = pure $ Q.quantity 1.0 u
eval env (Variable name)        = case lookup name env.values of
                                    Just (StoredValue _ q) → pure q
                                    Nothing → Left (LookupError name)
eval env (Factorial x)          = eval env x >>= Q.factorial >>> lmap QConversionError
eval env (Negate x)             = Q.qNegate <$> eval env x
eval env (Apply name xs)        = case lookup name env.functions of
                                    Just (StoredFunction _ fn) →
                                      traverse (eval env) xs >>= fn >>= checkFinite
                                    Nothing → Left (LookupError name)
eval env (BinOp op x y)         = do
  x' <- eval env x
  y' <- eval env y
  (run op) x' y' >>= checkFinite
  where
    run :: BinOp -> Quantity -> Quantity -> Expect Quantity
    run Sub       a b = qSubtract a b
    run Add       a b = qAdd a b
    run Mul       a b = pure (Q.qMultiply a b)
    run Div       a b = pure (Q.qDivide a b)
    run Pow       a b = Q.pow a <$> toScalar b
    run Mod       a b = modulo a b
    run ConvertTo a b = convertTo a b

    wrap ∷ ∀ a. Either ConversionError a → Either EvalError a
    wrap = lmap QConversionError

    qSubtract q1 q2 = wrap (Q.qSubtract q1 q2)
    qAdd q1 q2 = wrap (Q.qAdd q1 q2)
    toScalar q = wrap (Q.toScalar' q)
    modulo q1 q2 = wrap (Q.modulo q1 q2)
    convertTo source target = wrap (Q.convertTo source (Q.derivedUnit target))

-- | Like `eval`, but calls `fullSimplify` on the result if the user did not
-- | ask for an explicit conversion.
evalAndSimplify ∷ Environment → Expression → Expect Quantity
evalAndSimplify env e@(BinOp ConvertTo _ _) = eval env e
evalAndSimplify env e = Q.fullSimplify <$> eval env e

-- | Render the error message for a conversion error.
conversionErrorMessage ∷ ConversionError → Markup
conversionErrorMessage (ConversionError u1 u2) =
  if u1 == Q.unity
    then
      [ F.error "  Conversion error:", F.nl, F.nl
      , F.text "    Cannot convert a ", F.unit "scalar"
      , F.text " to a quantity of unit ", F.unit (Q.toString u2)
      ]
    else
      if u2 == Q.unity
        then
          [ F.error "  Conversion error:", F.nl, F.nl
          , F.text "    Cannot convert quantity of unit "
          , F.unit (Q.toString u1)
          , F.text " to a ", F.unit "scalar"
          ]
        else
            [ F.error "  Conversion error:", F.nl, F.nl
            , F.text "    Cannot convert unit ", F.unit (Q.toString u1)
            ] <> baseRep u1 <>
            [ F.nl
            , F.text "                to unit ", F.unit (Q.toString u2)
            ] <> baseRep u2
  where
    baseRep u =
      if fst (Q.toStandardUnit u) == Q.unity
        then []
        else
          if Q.toString u == F.format F.fmtPlain usStrs
            then []
            else br
      where
        br = F.text " (base units: " : usStrs <> [ F.text ")" ]
        us = Q.baseRepresentation u
        us' = sortBy (comparing Q.toString) us
        usStrs = intercalate [ F.text "·" ] $
                   map (singleton <<< F.unit <<< Q.toString) us'

-- | Get the error message for an evaluation error.
evalErrorMessage ∷ EvalError → Markup
evalErrorMessage (QConversionError ue) =
  conversionErrorMessage ue
evalErrorMessage (WrongArityError fn expected given) =
  [ F.optional (F.text "  ")
  , F.error "Wrong number of arguments:", F.nl, F.nl
  , F.text "    The function '", F.function fn, F.text "'"
  , F.text " takes ", F.val (show expected)
  , F.text (if expected == 1 then " argument" else " arguments")
  , F.text " (got ", F.val (show given), F.text ")"
  ]
evalErrorMessage (LookupError name) =
  [ F.optional (F.text "  ")
  , F.error "Unknown identifier: "
  , F.ident name]
evalErrorMessage NumericalError =
  [ F.optional (F.text "  ")
  , F.error "Numerical error: "
  , F.text "division by zero or out-of-bounds error" ]
evalErrorMessage (RedefinedConstantError name) =
  [ F.optional (F.text "  ")
  , F.error "Assignment error: ", F.text "'", F.emph name
  , F.text "' cannot be redefined." ]

-- | Interpreter return type.
type Response = { msg ∷ Message, newEnv ∷ Environment }

-- | Show pretty-printed input and the error message.
errorWithInput ∷ Markup → Expression → Environment → EvalError → Response
errorWithInput prefix expr env err =
  { msg: Message Error $ (F.optional <$> F.text "  " : prefix <> pretty expr)
                         <> (F.optional <$> [ F.nl, F.nl ])
                         <> evalErrorMessage err
  , newEnv: env
  }

-- | Check whether a given identifier is the name of a constant value/function.
isConstant ∷ Environment → Identifier → Boolean
isConstant env name = isConstantValue || isConstantFunction
  where
    isConstantValue =
      case lookup name env.values of
        Just (StoredValue Constant _)       → true
        Just (StoredValue HiddenConstant _) → true
        _ → false
    isConstantFunction =
      case lookup name env.functions of
        Just (StoredFunction Constant _)       → true
        Just (StoredFunction HiddenConstant _) → true
        _ → false

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → Response
runInsect env (Expression e) =
  case evalAndSimplify env e of
    Left evalErr → errorWithInput [] e env evalErr
    Right value →
      { msg: Message Value $    (F.optional <$> F.text "  " : pretty e)
                             <> (F.optional <$> [ F.nl, F.nl , F.text "   = " ])
                             <> prettyQuantity value
      , newEnv: env { values = insert "ans" (StoredValue UserDefined value) env.values }
      }

runInsect env (VariableAssignment name val) =
  case evalAndSimplify env val of
    Left evalErr → errorWithInput [ F.ident name, F.text " = " ] val env evalErr
    Right value →
      if isConstant env name
        then
          errorWithInput [ F.ident name, F.text " = " ] val env (RedefinedConstantError name)
        else
          { msg: Message ValueSet $
                      (F.optional <$> [ F.text "  ", F.ident name, F.text " = " ])
                   <> prettyQuantity value
          , newEnv: env { values = insert name (StoredValue UserDefined value) env.values
                        , functions = delete name env.functions }
          }

runInsect env (FunctionAssignment name argNames expr) =
  if isConstant env name
    then
      errorWithInput fAssign expr env (RedefinedConstantError name)
    else
      { msg: Message ValueSet $ F.optional <$> fAssign <> pretty expr
      , newEnv: env { functions = insert name (StoredFunction UserDefined userFunc) env.functions
                    , values = delete name env.values
                    }
      }
  where
    argNames' = NonEmptyList argNames
    numExpected = length argNames'

    fArgs = intercalate [ F.text ", " ] ((\a → [ F.ident a ]) <$> argNames)
    fAssign = [ F.text "  ", F.function name, F.text "(" ] <> fArgs <> [ F.text ") = " ]

    userFunc ∷ MathFunction
    userFunc argValues =
      if numGiven == numExpected
        then evalAndSimplify functionEnv expr
        else Left (WrongArityError name numExpected numGiven)
      where
        argValues' = NonEmptyList argValues
        numGiven = length argValues'
        args = zip argNames' argValues'

        insertArg map (Tuple argName val) = insert argName (StoredValue UserDefined val) map
        functionEnv = env { values = foldl insertArg env.values args
                          , functions = delete name env.functions
                          }

runInsect env (Command Help) = { msg: Message Info
  [ F.emph "insect", F.text " evaluates mathematical expressions that can", F.nl
  , F.text "involve physical quantities. You can start by trying", F.nl
  , F.text "one of these examples:", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.val "1920", F.text " / ", F.val "16", F.text " * ", F.val "9", F.text "         "
  , F.emph "  > ", F.function "sin", F.text "(", F.val "30", F.text " ", F.unit "deg", F.text ")", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.val "2", F.text " ", F.unit "min", F.text " + ", F.val "30", F.text " ", F.unit "s", F.text "          "
  , F.emph "  > ", F.val "6", F.text " ", F.unit "Mbit/s", F.text " * ", F.val "1.5", F.text " ", F.unit "h", F.text " -> ", F.unit "GB", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.text "list", F.text "                  "
  , F.emph "  > ", F.ident "r", F.text " = ", F.val "80", F.text " ", F.unit "cm", F.nl
  , F.emph "  > ", F.val "40000", F.text " ", F.unit "km", F.text " / ", F.ident "c", F.text " -> ", F.unit "ms", F.text "    "
  , F.emph "  > ", F.ident "pi", F.text " * ", F.ident "r", F.text "^", F.val "2", F.text " -> ", F.unit "m", F.text "^", F.val "2", F.nl
  , F.text "", F.nl
  , F.text "Full documentation: https://github.com/sharkdp/insect"
  ], newEnv : env }

runInsect env (Command List) =
  { msg: Message Info list
  , newEnv: env }
  where
    storedValue (StoredValue _ value) = value
    storageType (StoredValue t _) = t
    visibleValues = filter (\e → storageType (snd e) /= HiddenConstant) (toUnfoldable env.values)
    envTuples = sortBy (comparing (_.number <<< Q.prettyPrint' <<< storedValue <<< snd)) visibleValues
    envGrouped = groupBy (\x y → storedValue (snd x) == storedValue (snd y)) envTuples
    envSorted = sortBy (comparing (toLower <<< fst <<< head)) envGrouped
    list = [ F.text "List of variables:", F.nl ] <> foldMap toLine envSorted
    toLine kvPairs =
         [ F.nl, F.text "  " ]
      <> identifiers
      <> [ F.text " = " ]
      <> prettyQuantity val
        where
          identifiers = fromFoldable $ intercalate [ F.text " = " ] $
                          (singleton <<< F.ident <<< fst) <$> kvPairs
          val = storedValue (snd (head kvPairs))

runInsect env (Command Reset) =
  { msg: Message Info [F.text "Environment has been reset."]
  , newEnv: initialEnvironment }

runInsect env (Command Quit) = { msg: MQuit, newEnv: initialEnvironment }

runInsect env (Command Clear) = { msg: MClear, newEnv: env }


Improve handling of radio buttons

Improve handling of radio buttons

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


add purescript hello world file to examples

module Hello where

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

main :: forall t. Eff ("console" :: CONSOLE | t) Unit
main =
  log "Hello, World!"

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


Added our WebRTC.purs

Added our WebRTC.purs

module Gonimo.WebRTC where

import Prelude
import Data.Generic (class Generic)
import Data.Maybe (Maybe)
import Data.Nullable (toMaybe, toNullable, Nullable)
import WebRTC.RTC (RTCIceCandidate)

newtype IceCandidate = IceCandidate { sdpMLineIndex :: Maybe Int
                                    , sdpMid :: Maybe String
                                    , candidate :: String
                                    }

derive instance genericIceCandidate :: Generic IceCandidate

toJS :: IceCandidate -> RTCIceCandidate
toJS (IceCandidate icecandidate)= {
    candidate : icecandidate.candidate
  , sdpMid  : toNullable icecandidate.sdpMid
  , sdpMLineIndex : toNullable icecandidate.sdpMLineIndex
  }

fromJS :: RTCIceCandidate -> IceCandidate
fromJS icecandidate = IceCandidate
  { candidate : icecandidate.candidate
  , sdpMid  : toMaybe icecandidate.sdpMid
  , sdpMLineIndex : toMaybe icecandidate.sdpMLineIndex
  }

type SessionDescription = { sdp :: String, "type" :: String }

-- data Signal =
--     ICECandidate String
--   | Description String

-- data Error =
--   ParseError String -- A signaling message could not be parsed

-- type Config = {
--     settings :: Settings
--   , ourId :: DeviceId
--   , sendSignaling :: SendSignaling
--   , sendErrors :: ErrorReceiver
--   , iceServers :: Array { url :: String }
--   }

-- testICEServer = "stun:stun.l.google.com:19302"

-- type SendSignaling = String -> IO Unit
-- type ErrorReceiver = Error -> IO Unit

-- type Connection =
--   { config :: Config
--   , rtcConnection :: RTCPeerConnection
--   }

-- make :: Config -> IO Connection
-- make c = do
--   conn <- newRTCPeerConnection { iceServers : c.iceServers }
--   pure
--     { config : c
--     , rtcConnection : conn
--     }

-- addStream :: MediaStream -> Connection -> IO Unit
-- addStream stream conn = addStream conn.rtcConnection stream

-- receiveSignaling :: String -> Connection -> IO Unit
-- receiveSignal = unsafeCrashWith "Not yet implemented"

-- parseSignal :: String -> Either Error Signal

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


Expr example

Expr example

module Expr
  ( Typed()
  , num
  , bool
  , add
  , multiply
  , lt
  , ite
  , eval
  ) where

import Data.Either

data Typed a = Typed Untyped

data Untyped
  = Num Number
  | Bool Boolean
  | Add Untyped Untyped
  | Multiply Untyped Untyped
  | LessThan Untyped Untyped
  | IfThenElse Untyped Untyped Untyped

num :: Number -> Typed Number
num n = Typed $ Num n

bool :: Boolean -> Typed Boolean
bool b = Typed $ Bool b

add :: Typed Number -> Typed Number -> Typed Number
add (Typed n) (Typed m) = Typed $ Add n m

multiply :: Typed Number -> Typed Number -> Typed Number
multiply (Typed n) (Typed m) = Typed $ Multiply n m

lt :: Typed Number -> Typed Number -> Typed Boolean
lt (Typed n) (Typed m) = Typed $ LessThan n m

ite :: forall a. Typed Boolean -> Typed a -> Typed a -> Typed a
ite (Typed b) (Typed x) (Typed y) = Typed $ IfThenElse b x y

eval :: forall a. Typed a -> Either Number Boolean
eval (Typed untyped) = go untyped
  where
  go :: Untyped -> Either Number Boolean
  go (Num n) = Left n
  go (Bool b) = Right b
  go (Add n m) =
    case [go n, go n] of
      [Left x, Left y] -> Left $ x + y
  go (Multiply n m) =
    case [go n, go m] of
      [Left x, Left y] -> Left $ x * y
  go (LessThan n m) =
    case [go n, go m] of
      [Left x, Left y] -> Right $ x < y
  go (IfThenElse b t f) =
    case go b of
      Right true  -> go t
      Right false -> go f

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


Fill out display property values

Fill out display property values

module Css.Display where

import Css.Property
import Css.String
import Css.Stylesheet

newtype Display = Display Value

instance valDisplay :: Val Display where
  value (Display v) = v

inline :: Display
inline = Display $ fromString "inline"

block :: Display
block = Display $ fromString "block"

listItem :: Display
listItem = Display $ fromString "list-item"

runIn :: Display
runIn = Display $ fromString "runIn"

inlineBlock :: Display
inlineBlock = Display $ fromString "inline-block"

table :: Display
table = Display $ fromString "table"

inlineTable :: Display
inlineTable = Display $ fromString "inline-table"

tableRowGroup :: Display
tableRowGroup = Display $ fromString "table-row-Group"

tableHeaderGroup :: Display
tableHeaderGroup = Display $ fromString "table-header-group"

tableFooterGroup :: Display
tableFooterGroup = Display $ fromString "table-footer-group"

tableRow :: Display
tableRow = Display $ fromString "table-row"

tableColumnGroup :: Display
tableColumnGroup = Display $ fromString "table-column-group"

tableColumn :: Display
tableColumn = Display $ fromString "table-column"

tableCell :: Display
tableCell = Display $ fromString "table-cell"

tableCaption :: Display
tableCaption = Display $ fromString "table-caption"

displayNone :: Display
displayNone = Display $ fromString "none"

displayInherit :: Display
displayInherit = Display $ fromString "inherit"

flex :: Display
flex = Display $ fromString "flex"

inlineFlex :: Display
inlineFlex = Display $ fromString "inline-flex"

grid :: Display
grid = Display $ fromString "grid"

inlineGrid :: Display
inlineGrid = Display $ fromString "inline-grid"

display :: Display -> Css
display = key $ fromString "display"

module Css.Display where

import Css.Property
import Css.String
import Css.Stylesheet

newtype Display = Display Value

instance valDisplay :: Val Display where
  value (Display v) = v

block :: Display
block = Display $ fromString "block"

display :: Display -> Css
display = key $ fromString "display"


Adapted for new layout because of Kopernikus (transition to new company).

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


Send invitation on Enter press

Send invitation on Enter press

module Gonimo.UI.Invite where

import Prelude
import Gonimo.UI.Html
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Types as Client
import Gonimo.WebAPI.Types as WebAPI
import Pux.Html.Attributes as A
import Pux.Html.Events as E
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.Reader.Class (ask)
import Control.Monad.Reader.Trans (runReaderT)
import Data.Either (Either(Right, Left))
import Data.Generic (gShow)
import Data.Maybe (isJust, isNothing, Maybe(..))
import Data.Tuple (Tuple(Tuple))
import Gonimo.Client.Effects (handleError)
import Gonimo.Client.Types (Effects, Settings, runEffectsT)
import Gonimo.Pux (noEffects, justEffect, onlyEffects, EffModel(EffModel))
import Gonimo.Server.Types (InvitationDelivery(EmailInvitation), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Key(Key), Family(Family), Secret(Secret))
import Gonimo.WebAPI (postInvitationOutbox, postInvitations, postFamilies, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (button, input, p, h1, text, span, Html, img, div)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Signal (constant, Signal)

type State =
  { familyName :: String
  , email      :: String
  , familyId   :: Maybe (Key Family)
  , invitationSent :: Boolean
  , errorOccurred :: Maybe Client.Error
  }

init :: State
init = { familyName : "Family"
       , email : ""
       , familyId : Nothing
       , invitationSent : false
       , errorOccurred : Nothing
       }

data Action = SetFamilyName String
            | SetEmail String
            | SendInvitation
            | InvitationSent
            | ReportError Client.Error
            | Nop

update :: forall eff. Settings -> Action -> State -> EffModel eff State Action
update settings action = case action of
  (SetFamilyName name ) -> \state -> noEffects state { familyName = name }
  (SetEmail email )     -> \state -> noEffects state { email = email }
  InvitationSent        -> \state -> noEffects state { invitationSent = true }
  SendInvitation        -> \state -> justEffect (runEffect settings (handleSendInvitation state)) state
  Nop                   -> noEffects
  ReportError err       -> \state -> justEffect (Gonimo.handleError Nop err) state { errorOccurred = Just err }

handleSendInvitation :: forall eff. State -> Effects eff Action
handleSendInvitation state = do
  (SPSettings_ settings) <- ask
  let params = case settings.params of (SPParams_ params) -> params
  Gonimo.log $ "Using AuthToken: " <> gShow params.authorization
  fid <- case state.familyId of
    Nothing   -> postFamilies state.familyName
    Just fid' -> pure fid'
  (Tuple invId invitation) <- postInvitations fid
  postInvitationOutbox $ WebAPI.SendInvitation invId (EmailInvitation state.email)
  pure InvitationSent

runEffect :: forall eff. Settings -> Effects eff Action
             -> Aff (Client.EffEffects eff) Action
runEffect settings m = do
    er <- runExceptT <<< flip runReaderT settings <<< runEffectsT $ m
    case er of
      Left err -> pure $ ReportError err
      Right v -> pure v

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

view :: State -> Html Action
view state = if state.invitationSent
  then viewSent state
  else viewSend state

viewSend :: State -> Html Action
viewSend state =
  div []
      [ h1 [] [ text "Welcome To Gonimo!"]
      , p []  [ text $ "In order to get you started, invite a second device via email to your family " <> state.familyName <> ":"]
      , div [ E.onKeyUp handleEnter ]
            [ p []
                if isNothing state.familyId -- We can only set the family name here, if we are creating one!
                then
                  [ text "FamilyName: "
                  , input [ A.type_ "text"
                          , E.onInput $ \ev -> SetFamilyName ev.target.value
                          , A.value state.familyName
                          ] []
                  ]
                else
                  []
            , p []
                [ text "email Address: "
                , input [ A.type_ "text"
                        , E.onInput $ \ev -> SetEmail ev.target.value
                        , A.value state.email
                        ] []
                ]
            , button [ E.onClick $ const $ SendInvitation ]
                      [ text "Send Invitation!" ]
            , p []
                if isJust state.errorOccurred
                then [ text $ "Error occurred!"]
                else []
            ]
      ]
  where
    handleEnter :: E.KeyboardEvent -> Action
    handleEnter ev = if ev.keyCode == 13 then SendInvitation else Nop

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

module Gonimo.UI.Invite where

import Prelude
import Gonimo.UI.Html
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Types as Client
import Pux.Html.Attributes as A
import Pux.Html.Events as E
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.Reader.Class (ask)
import Control.Monad.Reader.Trans (runReaderT)
import Data.Either (Either(Right, Left))
import Data.Generic (gShow)
import Data.Maybe (isJust, isNothing, Maybe(..))
import Data.Tuple (Tuple(Tuple))
import Gonimo.Client.Effects (handleError)
import Gonimo.Client.Types (Effects, Settings, runEffectsT)
import Gonimo.Pux (noEffects, justEffect, onlyEffects, EffModel(EffModel))
import Gonimo.Server.Types (AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Key(Key), Family(Family), Secret(Secret))
import Gonimo.WebAPI (postInvitations, postFamilies, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (button, input, p, h1, text, span, Html, img, div)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Signal (constant, Signal)

type State =
  { familyName :: String
  , email      :: String
  , familyId   :: Maybe (Key Family)
  , invitationSent :: Boolean
  , errorOccurred :: Maybe Client.Error
  }

init :: State
init = { familyName : "Family"
       , email : ""
       , familyId : Nothing
       , invitationSent : false
       , errorOccurred : Nothing
       }

data Action = SetFamilyName String
            | SetEmail String
            | SendInvitation
            | InvitationSent
            | ReportError Client.Error
            | Nop

update :: forall eff. Settings -> Action -> State -> EffModel eff State Action
update settings action = case action of
  (SetFamilyName name ) -> \state -> noEffects state { familyName = name }
  (SetEmail email )     -> \state -> noEffects state { email = email }
  InvitationSent        -> \state -> noEffects state { invitationSent = true }
  SendInvitation        -> \state -> justEffect (runEffect settings (handleSendInvitation state)) state
  Nop                   -> noEffects
  ReportError err       -> \state -> justEffect (Gonimo.handleError Nop err) state { errorOccurred = Just err }

handleSendInvitation :: forall eff. State -> Effects eff Action
handleSendInvitation state = do
  (SPSettings_ settings) <- ask
  let params = case settings.params of (SPParams_ params) -> params
  Gonimo.log $ "Using AuthToken: " <> gShow params.authorization
  fid <- case state.familyId of
    Nothing   -> postFamilies state.familyName
    Just fid' -> pure fid'
  (Tuple invId invitation) <- postInvitations fid
  pure InvitationSent

runEffect :: forall eff. Settings -> Effects eff Action
             -> Aff (Client.EffEffects eff) Action
runEffect settings m = do
    er <- runExceptT <<< flip runReaderT settings <<< runEffectsT $ m
    case er of
      Left err -> pure $ ReportError err
      Right v -> pure v

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

view :: State -> Html Action
view state = if state.invitationSent
  then viewSent state
  else viewSend state

viewSend :: State -> Html Action
viewSend state =
  div []
      [ h1 [] [ text "Welcome To Gonimo!"]
      , p []  [ text $ "In order to get you started, invite a second device via email to your family " <> state.familyName <> ":"]
      , div []
            [ p []
                if isNothing state.familyId -- We can only set the family name here, if we are creating one!
                then
                  [ text "FamilyName: "
                  , input [ A.type_ "text"
                          , E.onInput $ \ev -> SetFamilyName ev.target.value
                          , A.value state.familyName
                          ] []
                  ]
                else
                  []
            , p []
                [ text "email Address: "
                , input [ A.type_ "text"
                        , E.onInput $ \ev -> SetEmail ev.target.value
                        , A.value state.email
                        ] []
                ]
            , button [ E.onClick $ const $ SendInvitation ]
                      [ text "Send Invitation!" ]
            , p []
                if isJust state.errorOccurred
                then [ text $ "Error occurred!"]
                else []
            ]
      ]

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


Add Stash representing suspended computations

A Stash is a stack of Stacks. We currently only use this to evaluate the
operand of a stuck application, but it can also be used to scrutinize
structured data (which I may or may not add). This is also called the
Dump in the literature. I just like that Stash looks like Stack (and we
are stashing Stacks away for later).

module Machine.Stash
  ( Stash(..)
  , empty
  , suspend
  , restore
  ) where

import Prelude

import Control.Monad.State (class MonadState, gets, modify_)
import Data.List (List(..), (:))
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype)
import Machine.Address (Address)
import Machine.Stack (Stack, fromList)

newtype Stash = Stash (List Stack)

derive instance newtypeStash :: Newtype Stash _

empty :: Stash
empty = Stash Nil

suspend :: forall s m. MonadState { stack :: Stack, stash :: Stash | s } m => m Unit
suspend = do
  {top, rest} <- gets _.stack
  Stash stacks <- gets _.stash
  modify_ $ _
    { stack = {top, rest: Nil}
    , stash = Stash $ extend stacks rest
    }
 where
  extend stash = maybe stash (_ : stash) <<< fromList

restore :: forall s m. MonadState { stack :: Stack, stash :: Stash | s } m => m (Maybe Address)
restore = do
  Stash stash <- gets _.stash
  case stash of
    Cons stack stacks -> do
      modify_ $ _
        { stack = stack
        , stash = Stash stacks
        }
      pure $ Just stack.top
    _ -> pure Nothing

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


modify example

modify example

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/llozovaya/purescript-phantomjs.git/'


include stages

include stages

module KanColle.DamageAnalysis.Stages where

import Prelude
import Data.Maybe
import Data.Monoid
import Data.Foldable

import KanColle.KCAPI.Battle
import KanColle.DamageAnalysis.DamageVector

-- | get `DamageVector` of kouku stage from battle data
-- | all the names in this module are kept consistent with functions in
-- | `KanColle.DamageAnalysis.DamageVector`.
koukuDV :: Battle -> DamageVector
koukuDV = foldMap calcKoukuDamage <<< getKouku

kouku2DV :: Battle -> DamageVector
kouku2DV = foldMap calcKoukuDamage <<< getKouku2

openingDV :: Battle -> DamageVector
openingDV = foldMap calcRaigekiDamage <<< getOpeningAttack

hougeki1DV :: Battle -> DamageVector
hougeki1DV = foldMap calcHougekiDamage <<< getHougeki1

hougeki2DV :: Battle -> DamageVector
hougeki2DV = foldMap calcHougekiDamage <<< getHougeki2

hougeki3DV :: Battle -> DamageVector
hougeki3DV = foldMap calcHougekiDamage <<< getHougeki3

raigekiDV :: Battle -> DamageVector
raigekiDV = foldMap calcRaigekiDamage <<< getRaigeki

hougekiDV :: Battle -> DamageVector
hougekiDV = foldMap calcHougekiDamage <<< getHougeki

-- | get `DamageVector` of a regular / aerial battle from battle data
-- | a regular battle consists of the following stages:
-- |
-- | * `kouku`  (aerial battle)
-- | * `kouku2` (aerial battle)
-- | * `opening` (openning torpedo attack)
-- | * `hougeki1` (first shelling stage)
-- | * `hougeki2` (second shelling stage)
-- | * `hougeki3` (third shelling stage, always empty for now)
-- | * `raigeki` (closing torpedo attack)
battleDV :: Battle -> DamageVector
battleDV = mconcat [ koukuDV, kouku2DV
                   , openingDV
                   , hougeki1DV, hougeki2DV, hougeki3DV
                   , raigekiDV
                   ]

-- | get `DamageVector` of a night battle
-- | a night battle involves only `hougeki` (shelling stage)
nightBattleDV :: Battle -> DamageVector
nightBattleDV = hougekiDV

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


Use Data.Quantity.fullSimplify, fixes #20

-- | This module defines the interpreter for the Insect language.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.StrMap (lookup, insert, foldMap)
import Data.Bifunctor (lmap)

import Quantities (Quantity, DerivedUnit, UnificationError, asValueIn, pow,
                   qNegate, qAdd, qDivide, qMultiply, qSubtract, quantity,
                   unity, convert, errorMessage, prettyPrint, fullSimplify)

import Insect.Language (BinOp(..), Expression(..), Command(..), Statement(..))
import Insect.Environment (Environment, initialEnvironment)

-- | The types of errors that may appear during evaluation
data EvalError
  = UnificationError UnificationError
  | LookupError String

type Expect = Either EvalError

data MessageType = Value | Info | Error

data Message = Message MessageType String

-- A few helper functions
qSubtract' ∷ Quantity → Quantity → Expect Quantity
qSubtract' q1 q2 = lmap UnificationError (qSubtract q1 q2)

qAdd' ∷ Quantity → Quantity → Expect Quantity
qAdd' q1 q2 = lmap UnificationError (qAdd q1 q2)

asScalar ∷ Quantity → Expect Number
asScalar q = lmap UnificationError (q `asValueIn` unity)

convert' ∷ DerivedUnit → Quantity → Expect Quantity
convert' d q = lmap UnificationError (convert d q)

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Q n u)         = pure $ quantity n u
eval env (Negate x)      = qNegate <$> eval env x
eval env (BinOp Sub x y) = join $ qSubtract' <$> eval env x <*> eval env y
eval env (BinOp Add x y) = join $ qAdd'      <$> eval env x <*> eval env y
eval env (BinOp Mul x y) =        qMultiply  <$> eval env x <*> eval env y
eval env (BinOp Div x y) =        qDivide    <$> eval env x <*> eval env y
eval env (BinOp Pow x y) = do
  base ← eval env x
  exp ← eval env y
  expNumber ← asScalar exp
  pure $ base `pow` expNumber
eval env (Variable name) =
  case lookup name env of
    Just q → pure q
    Nothing → Left (LookupError name)

evalErrorMessage ∷ EvalError → String
evalErrorMessage (UnificationError ue) = errorMessage ue
evalErrorMessage (LookupError name) = "Unknown variable '" <> name <> "'"

message ∷ Environment → Expect Quantity → { msg ∷ Message, newEnv ∷ Environment }
message env (Left e) = { msg: Message Error (evalErrorMessage e), newEnv: env }
message env (Right q) = { msg: Message Value (prettyPrint q), newEnv: env }

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → { msg ∷ Message, newEnv ∷ Environment }
runInsect env (Expression e) = message env (fullSimplify <$> eval env e)
runInsect env (Conversion e u) = message env (eval env e >>= convert' u)
runInsect env (Assignment n v) =
  case eval env v of
    Left evalErr → message env (Left evalErr)
    Right value → message (insert n value env) (Right (fullSimplify value))
runInsect env (Command Help) = { msg: Message Info (intercalate "\n"
  [ "insect is a command-line scientific calculator."
  , ""
  , "It evaluates simple calculations like 1920/16·9 as"
  , "well as expressions involving physical quantities."
  , ""
  , "You can start by trying one of these examples:"
  , ""
  , "--> 1920/16*9"
  , ""
  , "--> 2min + 30s"
  , ""
  , "--> 60mph -> m/s"
  , ""
  , "--> 6Mbps*1.5h -> Gb"
  ]), newEnv : env }
runInsect env (Command List) =
  { msg: Message Info list
  , newEnv: env }
  where
    list = foldMap toLine env
    toLine k v = k <> " = " <> prettyPrint v <> "\n"
runInsect env (Command Reset) =
  { msg: Message Info "Environment has been reset"
  , newEnv: initialEnvironment }
  where
    list = foldMap toLine env
    toLine k v = k <> " = " <> prettyPrint v <> "\n"
runInsect env (Command _) = { msg: Message Error "???", newEnv: env }

-- | This module defines the interpreter for the Insect language.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.StrMap (lookup, insert, foldMap)
import Data.Bifunctor (lmap)

import Quantities (Quantity, DerivedUnit, UnificationError, asValueIn, pow,
                   qNegate, qAdd, qDivide, qMultiply, qSubtract, quantity,
                   unity, convert, errorMessage, prettyPrint, simplifyUnit)

import Insect.Language (BinOp(..), Expression(..), Command(..), Statement(..))
import Insect.Environment (Environment, initialEnvironment)

-- | The types of errors that may appear during evaluation
data EvalError
  = UnificationError UnificationError
  | LookupError String

type Expect = Either EvalError

data MessageType = Value | Info | Error

data Message = Message MessageType String

-- A few helper functions
qSubtract' ∷ Quantity → Quantity → Expect Quantity
qSubtract' q1 q2 = lmap UnificationError (qSubtract q1 q2)

qAdd' ∷ Quantity → Quantity → Expect Quantity
qAdd' q1 q2 = lmap UnificationError (qAdd q1 q2)

asScalar ∷ Quantity → Expect Number
asScalar q = lmap UnificationError (q `asValueIn` unity)

convert' ∷ DerivedUnit → Quantity → Expect Quantity
convert' d q = lmap UnificationError (convert d q)

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Q n u)         = pure $ quantity n u
eval env (Negate x)      = qNegate <$> eval env x
eval env (BinOp Sub x y) = join $ qSubtract' <$> eval env x <*> eval env y
eval env (BinOp Add x y) = join $ qAdd'      <$> eval env x <*> eval env y
eval env (BinOp Mul x y) =        qMultiply  <$> eval env x <*> eval env y
eval env (BinOp Div x y) =        qDivide    <$> eval env x <*> eval env y
eval env (BinOp Pow x y) = do
  base ← eval env x
  exp ← eval env y
  expNumber ← asScalar exp
  pure $ base `pow` expNumber
eval env (Variable name) =
  case lookup name env of
    Just q → pure q
    Nothing → Left (LookupError name)

evalErrorMessage ∷ EvalError → String
evalErrorMessage (UnificationError ue) = errorMessage ue
evalErrorMessage (LookupError name) = "Unknown variable '" <> name <> "'"

message ∷ Environment → Expect Quantity → { msg ∷ Message, newEnv ∷ Environment }
message env (Left e) = { msg: Message Error (evalErrorMessage e), newEnv: env }
message env (Right q) = { msg: Message Value (prettyPrint q), newEnv: env }

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → { msg ∷ Message, newEnv ∷ Environment }
runInsect env (Expression e) = message env (simplifyUnit <$> eval env e)
runInsect env (Conversion e u) = message env (eval env e >>= convert' u)
runInsect env (Assignment n v) =
  case eval env v of
    Left evalErr → message env (Left evalErr)
    Right value → message (insert n value env) (Right (simplifyUnit value))
runInsect env (Command Help) = { msg: Message Info (intercalate "\n"
  [ "insect is a command-line scientific calculator."
  , ""
  , "It evaluates simple calculations like 1920/16·9 as"
  , "well as expressions involving physical quantities."
  , ""
  , "You can start by trying one of these examples:"
  , ""
  , "--> 1920/16*9"
  , ""
  , "--> 2min + 30s"
  , ""
  , "--> 60mph -> m/s"
  , ""
  , "--> 6Mbps*1.5h -> Gb"
  ]), newEnv : env }
runInsect env (Command List) =
  { msg: Message Info list
  , newEnv: env }
  where
    list = foldMap toLine env
    toLine k v = k <> " = " <> prettyPrint v <> "\n"
runInsect env (Command Reset) =
  { msg: Message Info "Environment has been reset"
  , newEnv: initialEnvironment }
  where
    list = foldMap toLine env
    toLine k v = k <> " = " <> prettyPrint v <> "\n"
runInsect env (Command _) = { msg: Message Error "???", newEnv: env }


Cleaned up the imports in the test suite.

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


Fix broken handlers

Fix broken handlers

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


Add ApproxNumber

Add ApproxNumber

module Test.StrongCheck.Data.ApproxNumber where

import Prelude

import Test.StrongCheck.Arbitrary (class Coarbitrary, class Arbitrary, coarbitrary, arbitrary)

-- | A newtype for `Number` whose `Eq` instance uses an epsilon value to allow
-- | for precision erros when comparing.
newtype ApproxNumber = ApproxNumber Number

-- Approximate equality comparison
approximateEqual :: Number -> Number -> Boolean
approximateEqual x y = (y - x) <= epsilon && (y - x) >= (-epsilon)
  where
  epsilon = 0.00000001

infix 2 approximateEqual as =~=

instance arbitraryApproxNumber :: Arbitrary ApproxNumber where
  arbitrary = ApproxNumber <$> arbitrary

instance coarbitraryApproxNumber :: Coarbitrary ApproxNumber where
  coarbitrary (ApproxNumber n) = coarbitrary n

instance eqApproxNumber :: Eq ApproxNumber where
  eq (ApproxNumber x) (ApproxNumber y) = x =~= y

instance ordApproxNumber :: Ord ApproxNumber where
  compare (ApproxNumber x) (ApproxNumber y) = compare x y

instance semiringApproxNumber :: Semiring ApproxNumber where
  add (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x + y)
  zero = ApproxNumber zero
  mul (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x * y)
  one = ApproxNumber one

instance ringApproxNumber :: Ring ApproxNumber where
  sub (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x - y)

instance commutativeRingApproxNumber :: CommutativeRing ApproxNumber

instance euclideanRingApproxNumber :: EuclideanRing ApproxNumber where
  degree (ApproxNumber x) = degree x
  div (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x / y)
  mod (ApproxNumber x) (ApproxNumber y) = ApproxNumber (x `mod` y)

instance fieldApproxNumber :: Field ApproxNumber

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


Changes to header row.

Changes to header row.


Fleshed out helper function jobToSHours(). TIL How to process a Map, and toUnfoldable.


First pass at Clipboard module

First pass at Clipboard module

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/freebroccolo/purescript-atom-api.git/'


Renamed Reauthentication.purs

Renamed Reauthentication.purs

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Quasar.Auth.Authentication
  ( authentication
  , getIdToken
  , fromEither
  , AuthEffects
  , EIdToken
  , AuthenticationError
  , RequestIdTokenBus
  ) where

import Control.Apply as Apply
import Control.Coroutine as Coroutine
import Control.Coroutine.Stalling (($$?))
import Control.Coroutine.Stalling as StallingCoroutine
import Control.Monad.Aff (Aff)
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (AVar, AVAR, AffAVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus (BusRW, BusW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Aff.Promise (Promise)
import Control.Monad.Aff.Promise as Promise
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Ref (Ref, REF)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Except.Trans (ExceptT(..), runExceptT)
import Control.Monad.Rec.Class (forever)
import Control.Parallel.Class (race)
import Control.UI.Browser as Browser
import DOM (DOM)
import DOM.HTML as DOMHTML
import DOM.HTML.Document as DOMHTMLDocument
import DOM.HTML.HTMLIFrameElement as DOMHTMLIFrameElement
import DOM.HTML.Types (HTMLIFrameElement)
import DOM.HTML.Types as DOMHTMLTypes
import DOM.HTML.Window as DOMHTMLWindow
import DOM.Node.Document as DOMNodeDocument
import DOM.Node.Node as DOMNode
import DOM.Node.Types (Node, Element)
import Data.Either as E
import Data.Foldable as F
import Data.Foreign as Foreign
import Data.Maybe as M
import Data.Nullable as Nullable
import Data.Traversable as T
import OIDC.Aff as OIDCAff
import OIDC.Crypt (RSASIGNTIME)
import OIDC.Crypt as OIDCCrypt
import OIDC.Crypt.JSONWebKey (JSONWebKey)
import OIDC.Crypt.Types (IdToken(..), UnhashedNonce(..))
import Quasar.Advanced.Types as QAT
import SlamData.Config as Config
import SlamData.Prelude
import SlamData.Quasar.Auth.IdTokenStorageEvents (getIdTokenStorageEvents)
import SlamData.Quasar.Auth.Keys as AuthKeys
import SlamData.Quasar.Auth.Store as AuthStore
import Text.Parsing.StringParser (ParseError(..))
import Utils (passover)
import Utils.DOM as DOMUtils
import Utils.LocalStorage as LocalStorage

fromEither ∷ ∀ a b. E.Either a b → M.Maybe b
fromEither = E.either (\_ → M.Nothing) (M.Just)

getIdToken ∷ ∀ eff. RequestIdTokenBus → Aff (AuthEffects eff) EIdToken
getIdToken requestNewIdTokenBus =
  AVar.takeVar =<< passover (flip Bus.write requestNewIdTokenBus) =<< AVar.makeVar

data AuthenticationError
  = IdTokenInvalid
  | IdTokenUnavailable String
  | DOMError String
  | NoAuthProviderInLocalStorage

instance semigroupAuthenticationError ∷ Semigroup AuthenticationError where
  append x y = y

type RequestIdTokenBus = BusW (AVar EIdToken)

type EIdToken = Either AuthenticationError IdToken

type AuthEffects eff =
  ( rsaSignTime ∷ RSASIGNTIME
  , avar ∷ AVAR
  , ref ∷ REF
  , dom ∷ DOM
  , random ∷ RANDOM
  | eff)

firstValueFromStallingProducer
  ∷ forall o eff
  . StallingCoroutine.StallingProducer o (Aff (avar ∷ AVAR | eff)) Unit
  → AffAVar eff o
firstValueFromStallingProducer producer = do
  firstValue ← AVar.makeVar
  Aff.forkAff
    $ StallingCoroutine.runStallingProcess
        (producer $$? (Coroutine.consumer \o → liftAff (AVar.putVar firstValue o) $> Just unit))
  AVar.takeVar firstValue

writeOnlyBus ∷ ∀ a. BusRW a → BusW a
writeOnlyBus = snd ∘ Bus.split

-- | Write an AVar to the returned bus to get a valid OIDC id token from the given provider.
authentication ∷ ∀ eff. Aff (AuthEffects eff) RequestIdTokenBus
authentication = do
  stateRef ← liftEff $ Ref.newRef Nothing
  requestBus ← Bus.make
  Aff.forkAff $ forever (authenticate stateRef =<< Bus.read requestBus)
  pure $ writeOnlyBus requestBus

authenticate
  ∷ ∀ eff
  . Ref (Maybe (Promise EIdToken))
  → AVar EIdToken
  → Aff (AuthEffects eff) Unit
authenticate stateRef replyAvar = do
  state ← liftEff $ Ref.readRef stateRef
  case state of
    Nothing → do
      idTokenPromise ← requestIdToken
      writeState $ Just idTokenPromise
      void $ Aff.forkAff $ reply idTokenPromise *> writeState Nothing
    Just idTokenPromise → do
      void $ Aff.forkAff $ reply idTokenPromise
  where
  writeState ∷ Maybe (Promise EIdToken) → Aff (AuthEffects eff) Unit
  writeState = liftEff ∘ Ref.writeRef stateRef

  reply ∷ Promise EIdToken → Aff (AuthEffects eff) Unit
  reply = AVar.putVar replyAvar <=< Promise.wait

requestReauthenticationSilently
  ∷ ∀ eff. Aff (AuthEffects eff) EIdToken
requestReauthenticationSilently = do
  either (pure ∘ Left) await =<< request
  where
  await authenticationIFrameNode = do
    idToken ← retrieveIdTokenFromLSOnChange
    liftEff $ removeBodyChild authenticationIFrameNode
    pure idToken
  request =
    either
      (const $ pure $ Left $ NoAuthProviderInLocalStorage)
      (liftEff ∘ map (lmap DOMError) ∘ appendHiddenIFrameToBody)
      =<< requestReauthenticationURI OIDCAff.None

requestPromptedAuthentication ∷ ∀ eff. Aff (AuthEffects eff) EIdToken
requestPromptedAuthentication =
  request *> retrieveIdTokenFromLSOnChange
  where
  request =
    either
      (const $ pure $ Left $ NoAuthProviderInLocalStorage)
      (map Right ∘ liftEff ∘ DOMUtils.openPopup)
      =<< requestReauthenticationURI OIDCAff.Login

appendHiddenIFrameToBody ∷ ∀ eff. String → Eff (AuthEffects eff) (Either String Node)
appendHiddenIFrameToBody uri =
  either
    (pure ∘ Left)
    (appendIFrameToBody <=< configureHiddenIFrame uri)
    =<< createIFrameElement

configureHiddenIFrame
  ∷ ∀ eff
  . String
  → HTMLIFrameElement
  → Eff (AuthEffects eff) HTMLIFrameElement
configureHiddenIFrame uri iFrameElement = do
  DOMHTMLIFrameElement.setSrc uri iFrameElement
  DOMHTMLIFrameElement.setWidth "0" iFrameElement
  DOMHTMLIFrameElement.setHeight "0" iFrameElement
  pure iFrameElement

appendIFrameToBody
  ∷ ∀ eff
  . HTMLIFrameElement
  → Eff (AuthEffects eff) (Either String Node)
appendIFrameToBody iFrameElement =
  traverse (appendIFrameToNode iFrameElement) =<< getBodyNode

appendIFrameToNode
  ∷ ∀ eff
  . HTMLIFrameElement
  → Node
  → Eff (AuthEffects eff) Node
appendIFrameToNode iFrameElement node =
  passover (flip DOMNode.appendChild node)
    $ DOMHTMLTypes.htmlElementToNode
    $ DOMHTMLTypes.htmlIFrameElementToHTMLElement iFrameElement

createIFrameElement ∷ ∀ eff. Eff (AuthEffects eff) (Either String HTMLIFrameElement)
createIFrameElement =
  (lmap show ∘ DOMHTMLTypes.readHTMLIFrameElement ∘ Foreign.toForeign)
    <$> createElement "iframe"

createElement ∷ ∀ eff.  String → Eff (AuthEffects eff) Element
createElement name =
  DOMNodeDocument.createElement name
    ∘ DOMHTMLTypes.htmlDocumentToDocument
    =<< DOMHTMLWindow.document
    =<< DOMHTML.window

removeBodyChild ∷ ∀ eff.  Node → Eff (AuthEffects eff) (Either String Node)
removeBodyChild child =
  either (pure ∘ Left) (map Right ∘ DOMNode.removeChild child) =<< getBodyNode

getBodyNode ∷ ∀ eff. Eff (AuthEffects eff) (Either String Node)
getBodyNode =
  toEitherStringNode
    <$> (DOMHTMLDocument.body =<< DOMHTMLWindow.document =<< DOMHTML.window)
  where
  toEitherStringNode =
    maybe
      (Left "Couldn't find body element.")
      Right
      ∘ map DOMHTMLTypes.htmlElementToNode
      ∘ Nullable.toMaybe

requestIdToken ∷ ∀ eff. Aff (AuthEffects eff) (Promise EIdToken)
requestIdToken = Promise.defer do
  startIdToken ← retrieveIdTokenFromLS
  provider ← liftEff $ retrieveProvider
  idToken ← case startIdToken of
    Left (IdTokenUnavailable _) | isJust provider →
      runExceptT
        $ ExceptT requestReauthenticationSilently
        <|> ExceptT requestPromptedAuthentication
    Left IdTokenInvalid →
      requestReauthenticationSilently
    _ ->
      pure startIdToken
  either (const $ liftEff AuthStore.clearProvider) (const $ pure unit) idToken
  pure idToken

retrieveIdTokenFromLSOnChange ∷ ∀ eff. Aff (AuthEffects eff) EIdToken
retrieveIdTokenFromLSOnChange =
  race
    (validTokenIdFromIdTokenStorageEvent
      =<< firstValueFromStallingProducer
      =<< liftEff getIdTokenStorageEvents)
    (Aff.later'
      Config.authenticationTimeout
      $ pure $ Left $ IdTokenUnavailable "No id token received before timeout.")

validTokenIdFromIdTokenStorageEvent
  ∷ ∀ eff
  . LocalStorage.StorageEvent (Either String IdToken)
  → Aff (AuthEffects eff) EIdToken
validTokenIdFromIdTokenStorageEvent =
  either (pure ∘ Left) verify ∘ lmap IdTokenUnavailable ∘ _.newValue

retrieveIdTokenFromLS ∷ ∀ eff. Aff (AuthEffects eff) EIdToken
retrieveIdTokenFromLS =
  either
    (pure ∘ Left ∘ IdTokenUnavailable)
    verify
    =<< (flip bind (map IdToken) <$> retrieveRaw)
  where
  retrieveRaw ∷ Aff (AuthEffects eff) (Either String (Either String String))
  retrieveRaw = LocalStorage.getLocalStorage AuthKeys.idTokenLocalStorageKey

retrieveProviderRFromLS ∷ ∀ eff. Eff (AuthEffects eff) (Either String QAT.ProviderR)
retrieveProviderRFromLS =
  map QAT.runProvider <$> LocalStorage.getLocalStorage AuthKeys.providerLocalStorageKey

appendAuthPath ∷ String → String
appendAuthPath s = (s <> _) Config.redirectURIString

runParseError ∷ ParseError → String
runParseError (ParseError s) = s

requestReauthenticationURI
  ∷ ∀ eff
  . OIDCAff.Prompt
  → Aff (AuthEffects eff) (Either String String)
requestReauthenticationURI prompt =
  liftEff do
    redirectUri ← appendAuthPath <$> Browser.locationString
    runExceptT
      $ ExceptT ∘ request redirectUri
      =<< ExceptT retrieveProviderRFromLS
  where
  request redirectUri =
    map (bimap runParseError id)
      ∘ flip (OIDCAff.requestAuthenticationURI prompt) redirectUri

verify ∷ ∀ eff. IdToken → Aff (AuthEffects eff) EIdToken
verify idToken = do
  verified ← liftEff $ verifyBoolean idToken
  if verified
    then pure $ Right idToken
    else pure $ Left IdTokenInvalid

verifyBoolean ∷ ∀ eff. IdToken → Eff (AuthEffects eff) Boolean
verifyBoolean idToken = do
  jwks ← map (fromMaybe []) retrieveJwks
  F.or <$> T.traverse (verifyBooleanWithJwk idToken) jwks

verifyBooleanWithJwk ∷ ∀ eff. IdToken → JSONWebKey → Eff (AuthEffects eff) Boolean
verifyBooleanWithJwk idToken jwk = do
  issuer ← retrieveIssuer
  clientId ← retrieveClientID
  nonce ← retrieveNonce
  fromMaybe (pure false)
    $ Apply.lift4 (OIDCCrypt.verifyIdToken idToken) issuer clientId nonce (Just jwk)

retrieveProvider ∷ ∀ eff. Eff (AuthEffects eff) (Maybe QAT.Provider)
retrieveProvider =
  LocalStorage.getLocalStorage AuthKeys.providerLocalStorageKey <#> fromEither

retrieveProviderR ∷ ∀ eff. Eff (AuthEffects eff) (Maybe QAT.ProviderR)
retrieveProviderR = map QAT.runProvider <$> retrieveProvider

retrieveIssuer ∷ ∀ eff. Eff (AuthEffects eff) (Maybe OIDCCrypt.Issuer)
retrieveIssuer =
  map (_.issuer <<< _.openIDConfiguration) <$> retrieveProviderR

retrieveJwks ∷ ∀ eff. Eff (AuthEffects eff) (Maybe (Array JSONWebKey))
retrieveJwks =
  map (_.jwks <<< _.openIDConfiguration) <$> retrieveProviderR

retrieveClientID ∷ ∀ eff. Eff (AuthEffects eff) (Maybe OIDCCrypt.ClientID)
retrieveClientID =
  map _.clientID <$> retrieveProviderR

retrieveNonce ∷ ∀ eff. Eff (AuthEffects eff) (Maybe UnhashedNonce)
retrieveNonce =
  LocalStorage.getLocalStorage AuthKeys.nonceLocalStorageKey <#>
    either (\_ → Nothing) (Just <<< UnhashedNonce)

error: pathspec 'src/SlamData/Quasar/Auth/Authentication.purs' did not match any file(s) known to git


Start on track event manager

Start on track event manager

module Genetics.Browser.Events.TrackManager where

import Prelude

import Control.Monad.Aff.Bus (BusRW)
import Data.List (List)
import Data.Monoid (mempty)
import Data.StrMap (StrMap)
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Variant (Variant)
import Genetics.Browser.Events.TrackSink (TrackSink)
import Genetics.Browser.Events.TrackSink as Sink
import Genetics.Browser.Events.TrackSource as Source
import Type.Proxy (Proxy(..))

-- newtype TrackManager sos sis = TrackManager { sources :: StrMap sos
--                                             , sinks :: StrMap sis
--                                             }

newtype SourceManager sources = SourceManager (List (BusRW (Variant sources)))

mkSourceManager :: SourceManager ()
mkSourceManager = SourceManager mempty

-- addSource :: ∀ l a r1 r2.
--              TrackSource
--              SourceManager r1

newtype SinkManager (sinks :: # Type) (sinkFuns :: # Type) output = SinkManager (Record sinkFuns)

mkSinkManager = SinkManager {}

-- addSink :: ∀ rIn1 rFun1 o.
--            TrackSink rIn1 rFun1 o
--         -> SinkManager sinks funs o
--         -> SinkManager sinks2 funs2 o
-- addSink sink mng = ?help

getSinks :: ∀ sinks0 sinks sinkFuns l t output rIn0 rIn rFun.
            RowCons l t sinks0 sinks
         => RowCons l t rIn0 rIn
         => IsSymbol l
         => SProxy l
         -> Proxy t
         -> SinkManager sinks sinkFuns output
         -> List (TrackSink rIn rFun output)
getSinks l t (SinkManager sinkFuns) = ?undef

-- a SinkManager can be fed some event (i.e. a label and a value of the appropriate type)
-- to apply the appropriate record to each sink.

-- well, isn't that just sequence_, basically?

-- data TrackSink (rIn :: # Type) (rFun :: # Type) output = TrackSink (Record rFun)

error: pathspec 'src/Genetics/Browser/Events/TrackManager.purs' did not match any file(s) known to git


Added Jump Search in Purescript

Added Jump Search in Purescript

module JumpSearch where

import Data.Maybe
import Data.Array (index, length)
import Data.Int (floor, toNumber)
import Math (sqrt, min)
import Prelude (otherwise, (&&), (<), (<=), (-), (+), (>=), (==), (>))

--Example List
alist :: Array Int
alist = [1, 3, 5, 7, 9, 11, 13, 15, 17]

-- use Jump Search t find a value
findVal :: Array Int -> Int -> Int
findVal list val = doJumpSearch list val 0 0 (getIndexVal list 0)

findJump :: forall t2. Array t2 -> Int
findJump list = floor (sqrt (toNumber (length list)))

getIndexVal :: Array Int -> Int -> Maybe Int
getIndexVal list left = (index list left)

doJumpSearch :: Array Int -> Int -> Int -> Int -> Maybe Int -> Int
doJumpSearch list val left right (Just leftIndex) | left < (length list) && (leftIndex <= val) = confirmSection list val left (floor (findRight list left)) (getIndexVal list left) (getIndexVal list (floor (findRight list left)))
								 		   		  | otherwise = (0-1)
doJumpSearch list val left right Nothing = (0-1)

findRight :: Array Int -> Int -> Number
findRight list left = min (toNumber(length list) - 1.0) (toNumber (left + (findJump list)))

confirmSection :: Array Int -> Int -> Int -> Int -> Maybe Int -> Maybe Int -> Int
confirmSection list val left right (Just leftIndex) (Just rightIndex) | (leftIndex <= val) && (val <= rightIndex) = checkValInSection list val left right (getIndexVal list left)
								   			 						  | otherwise = doJumpSearch list val (left + (findJump list)) right (getIndexVal list (left + (findJump list)))
confirmSection list val left right _ Nothing = (0-1)
confirmSection list val left right Nothing _ = (0-1)

checkValInSection :: Array Int -> Int -> Int -> Int -> Maybe Int -> Int
checkValInSection list val left right (Just leftIndex) | left >= (length list) = (0-1)
											  		   | leftIndex > val = (0-1)
											  		   | otherwise = findPosition list val left (newRight list right) (getIndexVal list left)
checkValInSection list val left right Nothing = (0-1)

newRight :: Array Int -> Int -> Int
newRight list right = floor (min (toNumber(length list) - 1.0) (toNumber right))

findPosition :: Array Int -> Int -> Int -> Int -> Maybe Int -> Int
findPosition list val left right (Just leftIndex) | (left <= right) && (leftIndex <= val) = confirmPosition list val left right (getIndexVal list left)
								 		   		  | otherwise = (0-1)
findPosition list val left right Nothing = (0-1)

confirmPosition :: Array Int -> Int -> Int -> Int -> Maybe Int -> Int
confirmPosition list val left right (Just leftIndex) | leftIndex == val = left
											 		 | otherwise = findPosition list val (left + 1) right (getIndexVal list (left + 1))
confirmPosition list val left right Nothing = (0-1)

error: pathspec 'search/jump_search/purescript/JumpSearch.purs' did not match any file(s) known to git