Switched to our own stun server

Switched to our own stun server

which is also a turn server - hmmm.

module Gonimo.UI.Socket.Channel where

import Prelude
import Data.Array as Arr
import Data.Tuple as Tuple
import Gonimo.UI.Socket.Message as Message
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream as MediaStream
import WebRTC.RTC as RTC
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Control.Monad.State.Class (get)
import Data.Identity (runIdentity)
import Data.Lens ((^?), _Just, lens, Lens, (.=))
import Data.Maybe (fromMaybe, isJust, maybe, Maybe(Nothing, Just))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (noEffects, runGonimo, Component, Update, onlyModify, ComponentType)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.Types.Lenses (_Baby)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Channel.Types (Action, Action(..), State, Props)
import Gonimo.UI.Socket.Lenses (mediaStream)
import Gonimo.UI.Socket.Message (runMaybeIceCandidate, MaybeIceCandidate(JustIceCandidate, NoIceCandidate), encodeToString, decodeFromString, Message)
import Gonimo.Util (coerceEffects)
import Gonimo.WebAPI (putSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Subscriber (receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Pux.Html (text, Html)
import Pux.Html.Attributes (offset)
import Servant.Subscriber (Subscriptions)
import Unsafe.Coerce (unsafeCoerce)
import WebRTC.MediaStream (createObjectURL, mediaStreamToBlob, stopStream, getUserMedia, MediaStreamConstraints(MediaStreamConstraints), MediaStream)
import WebRTC.RTC (MediaStreamEvent, setLocalDescription, createAnswer, iceEventCandidate, IceEvent, onicecandidate, onaddstream, addIceCandidate, setRemoteDescription, fromRTCSessionDescription, createOffer, addStream, RTCIceCandidateInit, RTCPeerConnection, Ice, newRTCPeerConnection)

init :: Maybe MediaStream -> IO State
init stream = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ {url : "stun:gonimo.com:3478"} ] })
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ stream
    liftEff $ MediaStream.clone origStream
  pure $  { mediaStream : ourStream
          , remoteStream : Nothing
          , rtcConnection : rtcConnection
          , isBabyStation : isJust stream
          }

remoteStream :: forall a b r. Lens { "remoteStream" :: a | r } { "remoteStream" :: b | r } a b
remoteStream = lens _."remoteStream" (_ { "remoteStream" = _ })

update :: forall ps. Update (Props ps) State Action
update action = case action of
  InitConnection                     -> handleInit -- Things we can't do in init already.
  StartStreaming constraints         -> handleStartStreaming constraints
  SetMediaStream stream              -> handleSetMediaStream stream
  StopStreaming                      -> closeStream
  CloseConnection                    -> handleCloseConnection
  AcceptMessage message              -> handleAcceptMessage message
  OnIceCandidate iceEvent            -> handleOnIceCandidate iceEvent
  OnAddStream streamEvent            -> handleOnAddStream streamEvent
  SetRemoteStream stream             -> remoteStream .= Just stream *> pure []
  ReportError _                      -> noEffects
  Nop                                -> noEffects

handleInit :: forall ps. ComponentType (Props ps) State Action
handleInit = do
  props <- ask :: Component (Props ps) State (Props ps)
  state <- get :: Component (Props ps) State State
  sendMessage <- getSendMessage
  pure
    [ do
         liftEff $ onaddstream (coerceEffects <<< props.sendAction <<< OnAddStream ) state.rtcConnection
         liftEff $ onicecandidate (coerceEffects <<< props.sendAction <<< OnIceCandidate ) state.rtcConnection
         if state.isBabyStation
           then pure Nop
           else sendMessage Message.StartStreaming
    ]

handleStartStreaming :: forall ps.
                        MediaStreamConstraints
                        -> ComponentType (Props ps) State Action
handleStartStreaming constraints =
  pure [ liftAff $ SetMediaStream <$> coerceEffects (getUserMedia constraints) ]

handleSendStartStreaming :: forall ps. ComponentType (Props ps) State Action
handleSendStartStreaming = do
  sendMessage <- getSendMessage
  pure [ sendMessage Message.StartStreaming ]

handleSetMediaStream :: forall ps. MediaStream -> ComponentType (Props ps) State Action
handleSetMediaStream stream = do
  mediaStream .= Just stream
  startStreaming stream

startStreaming :: forall ps. MediaStream -> ComponentType (Props ps) State Action
startStreaming stream = do
  state <- get
  sendMessage <- getSendMessage
  pure [ do
            liftEff $ addStream stream state.rtcConnection
            offer <- liftAff $ createOffer state.rtcConnection
            liftAff $ setLocalDescription offer state.rtcConnection
            sendMessage $ Message.SessionDescriptionOffer offer
            pure Nop
       ]

handleOnIceCandidate :: forall ps. IceEvent -> ComponentType (Props ps) State Action
handleOnIceCandidate event = do
  let candidate = iceEventCandidate event
  let mCandidate = maybe NoIceCandidate JustIceCandidate candidate
  sendMessage <- getSendMessage
  pure [ sendMessage $ Message.IceCandidate mCandidate ]

handleOnAddStream :: forall ps. MediaStreamEvent  -> ComponentType (Props ps) State Action
handleOnAddStream event = do
  pure [ do
            url <- liftEff <<< createObjectURL <<< mediaStreamToBlob $ event.stream
            pure $ SetRemoteStream $ { stream : event.stream, objectURL : url }
       ]

getSendMessage :: forall ps. Component (Props ps) State (Message -> IO Action)
getSendMessage = do
  let sendString = putSocketByFamilyIdByFromDeviceByToDeviceByChannelId
  props <- ask
  let familyId' = props.familyId
  let fromDevice' = props.ourId
  let toDevice' = props.theirId
  let channelId' = props.cSecret
  pure $ toIO props.settings <<< ( \msg ->  do
    let strMsg = encodeToString msg
    sendString strMsg familyId' fromDevice' toDevice' channelId'
    pure Nop)

handleAcceptMessage :: forall ps. Message -> ComponentType (Props ps) State Action
handleAcceptMessage msg = do
  state <- get
  sendMessage <- getSendMessage
  case msg of
    Message.StartStreaming -> fromMaybe (pure []) $ startStreaming <$> state.mediaStream
    Message.SessionDescriptionOffer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              answer <- liftAff $ createAnswer state.rtcConnection
              liftAff $ setLocalDescription answer state.rtcConnection
              sendMessage $ Message.SessionDescriptionAnswer answer
           ]
    Message.SessionDescriptionAnswer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              pure Nop
           ]
    Message.IceCandidate candidate ->
      pure [ do
               let test = runMaybeIceCandidate candidate
               case test of
                 Nothing -> pure unit -- let's see whether this helps
                 Just c -> liftAff $ addIceCandidate (runMaybeIceCandidate candidate) state.rtcConnection
               pure Nop
           ]
    Message.CloseConnection -> closeStream

closeStream :: forall ps. ComponentType (Props ps) State Action
closeStream = do
  state <- get
  pure $ fromMaybe [] $ do
    stream <- state.mediaStream
    pure [ liftEff $ do
              stopStream stream
              pure Nop
         ]

handleCloseConnection :: forall ps. ComponentType (Props ps) State Action
handleCloseConnection = do
  sendMessage <- getSendMessage
  closeActions <- closeStream
  pure $ closeActions <> [ sendMessage Message.CloseConnection ]

view :: forall ps. Props ps -> State -> Html Action
view props state =
  let
    mBabyDevice = Tuple.lookup props.theirId props.onlineDevices
    babyName = fromMaybe "unknown baby" $ mBabyDevice ^? _Just <<< _Baby
  in
    H.div [ A.className "panel panel-default" ]
            [ H.div [ A.className "panel-heading" ]
              [
                H.text babyName
              ]
            , viewVideo state
            ]

viewVideo :: State -> Html Action
viewVideo state =
   case state.remoteStream of
       Nothing -> H.text $ "Sorry - no video there yet, please check that your camera/microphone "
                  <> "are enabled on the baby station and your browser allows us to access it."
       Just stream ->
         H.video [ A.src stream.objectURL
                 , A.autoPlay "true"
                 , A.controls true
                 , A.width "100%"
                 ] []

getSubscriptions :: forall m ps. (MonadReader Settings m) => Props ps -> m (Subscriptions Action)
getSubscriptions props =
  let
    receiveMessage = receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId
                      doDecode
    doDecode :: Maybe (Maybe String) -> Action
    doDecode = maybe Nop AcceptMessage <<< (\mv -> decodeFromString =<< join mv)
  in
    receiveMessage props.familyId props.theirId props.ourId props.cSecret

module Gonimo.UI.Socket.Channel where

import Prelude
import Data.Array as Arr
import Data.Tuple as Tuple
import Gonimo.UI.Socket.Message as Message
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream as MediaStream
import WebRTC.RTC as RTC
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Control.Monad.State.Class (get)
import Data.Identity (runIdentity)
import Data.Lens ((^?), _Just, lens, Lens, (.=))
import Data.Maybe (fromMaybe, isJust, maybe, Maybe(Nothing, Just))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (noEffects, runGonimo, Component, Update, onlyModify, ComponentType)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.Types.Lenses (_Baby)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Channel.Types (Action, Action(..), State, Props)
import Gonimo.UI.Socket.Lenses (mediaStream)
import Gonimo.UI.Socket.Message (runMaybeIceCandidate, MaybeIceCandidate(JustIceCandidate, NoIceCandidate), encodeToString, decodeFromString, Message)
import Gonimo.Util (coerceEffects)
import Gonimo.WebAPI (putSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Subscriber (receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Pux.Html (text, Html)
import Pux.Html.Attributes (offset)
import Servant.Subscriber (Subscriptions)
import Unsafe.Coerce (unsafeCoerce)
import WebRTC.MediaStream (createObjectURL, mediaStreamToBlob, stopStream, getUserMedia, MediaStreamConstraints(MediaStreamConstraints), MediaStream)
import WebRTC.RTC (MediaStreamEvent, setLocalDescription, createAnswer, iceEventCandidate, IceEvent, onicecandidate, onaddstream, addIceCandidate, setRemoteDescription, fromRTCSessionDescription, createOffer, addStream, RTCIceCandidateInit, RTCPeerConnection, Ice, newRTCPeerConnection)

init :: Maybe MediaStream -> IO State
init stream = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ {url : "stun:stun.l.google.com:19302"} ] })
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ stream
    liftEff $ MediaStream.clone origStream
  pure $  { mediaStream : ourStream
          , remoteStream : Nothing
          , rtcConnection : rtcConnection
          , isBabyStation : isJust stream
          }

remoteStream :: forall a b r. Lens { "remoteStream" :: a | r } { "remoteStream" :: b | r } a b
remoteStream = lens _."remoteStream" (_ { "remoteStream" = _ })

update :: forall ps. Update (Props ps) State Action
update action = case action of
  InitConnection                     -> handleInit -- Things we can't do in init already.
  StartStreaming constraints         -> handleStartStreaming constraints
  SetMediaStream stream              -> handleSetMediaStream stream
  StopStreaming                      -> closeStream
  CloseConnection                    -> handleCloseConnection
  AcceptMessage message              -> handleAcceptMessage message
  OnIceCandidate iceEvent            -> handleOnIceCandidate iceEvent
  OnAddStream streamEvent            -> handleOnAddStream streamEvent
  SetRemoteStream stream             -> remoteStream .= Just stream *> pure []
  ReportError _                      -> noEffects
  Nop                                -> noEffects

handleInit :: forall ps. ComponentType (Props ps) State Action
handleInit = do
  props <- ask :: Component (Props ps) State (Props ps)
  state <- get :: Component (Props ps) State State
  sendMessage <- getSendMessage
  pure
    [ do
         liftEff $ onaddstream (coerceEffects <<< props.sendAction <<< OnAddStream ) state.rtcConnection
         liftEff $ onicecandidate (coerceEffects <<< props.sendAction <<< OnIceCandidate ) state.rtcConnection
         if state.isBabyStation
           then pure Nop
           else sendMessage Message.StartStreaming
    ]

handleStartStreaming :: forall ps.
                        MediaStreamConstraints
                        -> ComponentType (Props ps) State Action
handleStartStreaming constraints =
  pure [ liftAff $ SetMediaStream <$> coerceEffects (getUserMedia constraints) ]

handleSendStartStreaming :: forall ps. ComponentType (Props ps) State Action
handleSendStartStreaming = do
  sendMessage <- getSendMessage
  pure [ sendMessage Message.StartStreaming ]

handleSetMediaStream :: forall ps. MediaStream -> ComponentType (Props ps) State Action
handleSetMediaStream stream = do
  mediaStream .= Just stream
  startStreaming stream

startStreaming :: forall ps. MediaStream -> ComponentType (Props ps) State Action
startStreaming stream = do
  state <- get
  sendMessage <- getSendMessage
  pure [ do
            liftEff $ addStream stream state.rtcConnection
            offer <- liftAff $ createOffer state.rtcConnection
            liftAff $ setLocalDescription offer state.rtcConnection
            sendMessage $ Message.SessionDescriptionOffer offer
            pure Nop
       ]

handleOnIceCandidate :: forall ps. IceEvent -> ComponentType (Props ps) State Action
handleOnIceCandidate event = do
  let candidate = iceEventCandidate event
  let mCandidate = maybe NoIceCandidate JustIceCandidate candidate
  sendMessage <- getSendMessage
  pure [ sendMessage $ Message.IceCandidate mCandidate ]

handleOnAddStream :: forall ps. MediaStreamEvent  -> ComponentType (Props ps) State Action
handleOnAddStream event = do
  pure [ do
            url <- liftEff <<< createObjectURL <<< mediaStreamToBlob $ event.stream
            pure $ SetRemoteStream $ { stream : event.stream, objectURL : url }
       ]

getSendMessage :: forall ps. Component (Props ps) State (Message -> IO Action)
getSendMessage = do
  let sendString = putSocketByFamilyIdByFromDeviceByToDeviceByChannelId
  props <- ask
  let familyId' = props.familyId
  let fromDevice' = props.ourId
  let toDevice' = props.theirId
  let channelId' = props.cSecret
  pure $ toIO props.settings <<< ( \msg ->  do
    let strMsg = encodeToString msg
    sendString strMsg familyId' fromDevice' toDevice' channelId'
    pure Nop)

handleAcceptMessage :: forall ps. Message -> ComponentType (Props ps) State Action
handleAcceptMessage msg = do
  state <- get
  sendMessage <- getSendMessage
  case msg of
    Message.StartStreaming -> fromMaybe (pure []) $ startStreaming <$> state.mediaStream
    Message.SessionDescriptionOffer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              answer <- liftAff $ createAnswer state.rtcConnection
              liftAff $ setLocalDescription answer state.rtcConnection
              sendMessage $ Message.SessionDescriptionAnswer answer
           ]
    Message.SessionDescriptionAnswer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              pure Nop
           ]
    Message.IceCandidate candidate ->
      pure [ do
               let test = runMaybeIceCandidate candidate
               case test of
                 Nothing -> pure unit -- let's see whether this helps
                 Just c -> liftAff $ addIceCandidate (runMaybeIceCandidate candidate) state.rtcConnection
               pure Nop
           ]
    Message.CloseConnection -> closeStream

closeStream :: forall ps. ComponentType (Props ps) State Action
closeStream = do
  state <- get
  pure $ fromMaybe [] $ do
    stream <- state.mediaStream
    pure [ liftEff $ do
              stopStream stream
              pure Nop
         ]

handleCloseConnection :: forall ps. ComponentType (Props ps) State Action
handleCloseConnection = do
  sendMessage <- getSendMessage
  closeActions <- closeStream
  pure $ closeActions <> [ sendMessage Message.CloseConnection ]

view :: forall ps. Props ps -> State -> Html Action
view props state =
  let
    mBabyDevice = Tuple.lookup props.theirId props.onlineDevices
    babyName = fromMaybe "unknown baby" $ mBabyDevice ^? _Just <<< _Baby
  in
    H.div [ A.className "panel panel-default" ]
            [ H.div [ A.className "panel-heading" ]
              [
                H.text babyName
              ]
            , viewVideo state
            ]

viewVideo :: State -> Html Action
viewVideo state =
   case state.remoteStream of
       Nothing -> H.text $ "Sorry - no video there yet, please check that your camera/microphone "
                  <> "are enabled on the baby station and your browser allows us to access it."
       Just stream ->
         H.video [ A.src stream.objectURL
                 , A.autoPlay "true"
                 , A.controls true
                 , A.width "100%"
                 ] []

getSubscriptions :: forall m ps. (MonadReader Settings m) => Props ps -> m (Subscriptions Action)
getSubscriptions props =
  let
    receiveMessage = receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId
                      doDecode
    doDecode :: Maybe (Maybe String) -> Action
    doDecode = maybe Nop AcceptMessage <<< (\mv -> decodeFromString =<< join mv)
  in
    receiveMessage props.familyId props.theirId props.ourId props.cSecret


Actually close connection on close

Actually close connection on close

module Gonimo.UI.Socket.Channel where

import Prelude
import Data.Array as Arr
import Data.Tuple as Tuple
import Gonimo.UI.Socket.Message as Message
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream as MediaStream
import WebRTC.RTC as RTC
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Control.Monad.State.Class (get)
import Data.Identity (runIdentity)
import Data.Lens ((^?), _Just, lens, Lens, (.=))
import Data.Maybe (fromMaybe, isJust, maybe, Maybe(Nothing, Just))
import Data.Tuple (Tuple(Tuple))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (noEffects, runGonimo, Component, Update, onlyModify, ComponentType)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.State.Types (MessageNumber(MessageNumber))
import Gonimo.Server.Types.Lenses (_Baby)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Channel.Types (Action, Action(..), State, Props)
import Gonimo.UI.Socket.Lenses (mediaStream)
import Gonimo.UI.Socket.Message (runMaybeIceCandidate, MaybeIceCandidate(JustIceCandidate, NoIceCandidate), encodeToString, decodeFromString, Message)
import Gonimo.Util (coerceEffects)
import Gonimo.WebAPI (deleteSocketByFamilyIdByFromDeviceByToDeviceByChannelIdMessagesByMessageNumber, putSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Subscriber (getSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Pux.Html (text, Html)
import Pux.Html.Attributes (offset)
import Servant.Subscriber (Subscriptions)
import Unsafe.Coerce (unsafeCoerce)
import WebRTC.MediaStream (createObjectURL, mediaStreamToBlob, stopStream, getUserMedia, MediaStreamConstraints(MediaStreamConstraints), MediaStream)
import WebRTC.RTC (closeRTCPeerConnection, MediaStreamEvent, setLocalDescription, createAnswer, iceEventCandidate, IceEvent, onicecandidate, onaddstream, addIceCandidate, setRemoteDescription, fromRTCSessionDescription, createOffer, addStream, RTCIceCandidateInit, RTCPeerConnection, Ice, newRTCPeerConnection)

init :: Maybe MediaStream -> IO State
init stream = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ {url : "turn:gonimo.com:3478"} ] })
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ stream
    liftEff $ MediaStream.clone origStream
  pure $  { mediaStream : ourStream
          , remoteStream : Nothing
          , rtcConnection : rtcConnection
          , isBabyStation : isJust stream
          }

remoteStream :: forall a b r. Lens { "remoteStream" :: a | r } { "remoteStream" :: b | r } a b
remoteStream = lens _."remoteStream" (_ { "remoteStream" = _ })

update :: forall ps. Update (Props ps) State Action
update action = case action of
  InitConnection                     -> handleInit -- Things we can't do in init already.
  StartStreaming constraints         -> handleStartStreaming constraints
  SetMediaStream stream              -> handleSetMediaStream stream
  StopStreaming                      -> closeConnection
  CloseConnection                    -> handleCloseConnection
  AcceptMessage num message          -> handleAcceptMessage num message
  OnIceCandidate iceEvent            -> handleOnIceCandidate iceEvent
  OnAddStream streamEvent            -> handleOnAddStream streamEvent
  SetRemoteStream stream             -> remoteStream .= Just stream *> pure []
  ReportError _                      -> noEffects
  Nop                                -> noEffects

handleInit :: forall ps. ComponentType (Props ps) State Action
handleInit = do
  props <- ask :: Component (Props ps) State (Props ps)
  state <- get :: Component (Props ps) State State
  sendMessage <- getSendMessage
  pure
    [ do
         liftEff $ onaddstream (coerceEffects <<< props.sendAction <<< OnAddStream ) state.rtcConnection
         liftEff $ onicecandidate (coerceEffects <<< props.sendAction <<< OnIceCandidate ) state.rtcConnection
         if state.isBabyStation
           then pure Nop
           else sendMessage Message.StartStreaming
    ]

handleStartStreaming :: forall ps.
                        MediaStreamConstraints
                        -> ComponentType (Props ps) State Action
handleStartStreaming constraints =
  pure [ liftAff $ SetMediaStream <$> coerceEffects (getUserMedia constraints) ]

handleSendStartStreaming :: forall ps. ComponentType (Props ps) State Action
handleSendStartStreaming = do
  sendMessage <- getSendMessage
  pure [ sendMessage Message.StartStreaming ]

handleSetMediaStream :: forall ps. MediaStream -> ComponentType (Props ps) State Action
handleSetMediaStream stream = do
  mediaStream .= Just stream
  startStreaming stream

startStreaming :: forall ps. MediaStream -> ComponentType (Props ps) State Action
startStreaming stream = do
  state <- get
  sendMessage <- getSendMessage
  pure [ do
            liftEff $ addStream stream state.rtcConnection
            offer <- liftAff $ createOffer state.rtcConnection
            liftAff $ setLocalDescription offer state.rtcConnection
            sendMessage $ Message.SessionDescriptionOffer offer
            pure Nop
       ]

handleOnIceCandidate :: forall ps. IceEvent -> ComponentType (Props ps) State Action
handleOnIceCandidate event = do
  let candidate = iceEventCandidate event
  let mCandidate = maybe NoIceCandidate JustIceCandidate candidate
  sendMessage <- getSendMessage
  pure [ sendMessage $ Message.IceCandidate mCandidate ]

handleOnAddStream :: forall ps. MediaStreamEvent  -> ComponentType (Props ps) State Action
handleOnAddStream event = do
  pure [ do
            url <- liftEff <<< createObjectURL <<< mediaStreamToBlob $ event.stream
            pure $ SetRemoteStream $ { stream : event.stream, objectURL : url }
       ]

getSendMessage :: forall ps. Component (Props ps) State (Message -> IO Action)
getSendMessage = do
  let sendString = putSocketByFamilyIdByFromDeviceByToDeviceByChannelId
  props <- ask
  let familyId' = props.familyId
  let fromDevice' = props.ourId
  let toDevice' = props.theirId
  let channelId' = props.cSecret
  pure $ toIO props.settings <<< ( \msg ->  do
    let strMsg = encodeToString msg
    sendString strMsg familyId' fromDevice' toDevice' channelId'
    pure Nop)

handleAcceptMessage :: forall ps. MessageNumber -> Message -> ComponentType (Props ps) State Action
handleAcceptMessage msgNumber msg = do
    props <- ask
    actions <- handleMessage
    let deleteMessage = deleteSocketByFamilyIdByFromDeviceByToDeviceByChannelIdMessagesByMessageNumber
    deleteActions <- runGonimo $ do
      deleteMessage props.familyId props.theirId props.ourId props.cSecret msgNumber
      pure Nop
    pure $ deleteActions <> actions
  where
    handleMessage :: ComponentType (Props ps) State Action
    handleMessage = do
      state <- get
      sendMessage <- getSendMessage
      case msg of
        Message.StartStreaming -> fromMaybe (pure []) $ startStreaming <$> state.mediaStream
        Message.SessionDescriptionOffer description ->
          pure [ do
                  liftAff $ setRemoteDescription description state.rtcConnection
                  answer <- liftAff $ createAnswer state.rtcConnection
                  liftAff $ setLocalDescription answer state.rtcConnection
                  sendMessage $ Message.SessionDescriptionAnswer answer
              ]
        Message.SessionDescriptionAnswer description ->
          pure [ do
                  liftAff $ setRemoteDescription description state.rtcConnection
                  pure Nop
              ]
        Message.IceCandidate candidate ->
          pure [ do
                  let test = runMaybeIceCandidate candidate
                  case test of
                    Nothing -> pure unit -- let's see whether this helps
                    Just c -> liftAff $ addIceCandidate (runMaybeIceCandidate candidate) state.rtcConnection
                  pure Nop
              ]
        Message.CloseConnection -> closeConnection

closeConnection :: forall ps. ComponentType (Props ps) State Action
closeConnection = do
  state <- get
  let conn = state.rtcConnection
  pure $ fromMaybe [] $ do
    stream <- state.mediaStream
    pure [ liftEff $ do
              stopStream stream
              closeRTCPeerConnection conn
              pure Nop
         ]

handleCloseConnection :: forall ps. ComponentType (Props ps) State Action
handleCloseConnection = do
  sendMessage <- getSendMessage
  closeActions <- closeConnection
  pure $ closeActions <> [ sendMessage Message.CloseConnection ]

view :: forall ps. Props ps -> State -> Html Action
view props state =
  let
    mBabyDevice = Tuple.lookup props.theirId props.onlineDevices
    babyName = fromMaybe "unknown baby" $ mBabyDevice ^? _Just <<< _Baby
  in
    H.div [ A.className "panel panel-default" ]
            [ H.div [ A.className "panel-heading" ]
              [
                H.text babyName
              ]
            , viewVideo state
            ]

viewVideo :: State -> Html Action
viewVideo state =
   case state.remoteStream of
       Nothing -> H.text $ "Sorry - no video there yet, please check that your camera/microphone "
                  <> "are enabled on the baby station and your browser allows us to access it."
       Just stream ->
         H.video [ A.src stream.objectURL
                 , A.autoPlay "true"
                 , A.controls true
                 , A.width "100%"
                 ] []

getSubscriptions :: forall m ps. (MonadReader Settings m) => Props ps -> m (Subscriptions Action)
getSubscriptions props =
  let
    receiveMessage = getSocketByFamilyIdByFromDeviceByToDeviceByChannelId doDecode
    doDecode :: Maybe (Maybe (Tuple MessageNumber String)) -> Action
    doDecode (Just (Just (Tuple num msg))) = fromMaybe Nop
                                             $ AcceptMessage num <$> decodeFromString msg
    doDecode _                             = Nop
  in
    receiveMessage props.familyId props.theirId props.ourId props.cSecret

module Gonimo.UI.Socket.Channel where

import Prelude
import Data.Array as Arr
import Data.Tuple as Tuple
import Gonimo.UI.Socket.Message as Message
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream as MediaStream
import WebRTC.RTC as RTC
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Control.Monad.State.Class (get)
import Data.Identity (runIdentity)
import Data.Lens ((^?), _Just, lens, Lens, (.=))
import Data.Maybe (fromMaybe, isJust, maybe, Maybe(Nothing, Just))
import Data.Tuple (Tuple(Tuple))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (noEffects, runGonimo, Component, Update, onlyModify, ComponentType)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.State.Types (MessageNumber(MessageNumber))
import Gonimo.Server.Types.Lenses (_Baby)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Channel.Types (Action, Action(..), State, Props)
import Gonimo.UI.Socket.Lenses (mediaStream)
import Gonimo.UI.Socket.Message (runMaybeIceCandidate, MaybeIceCandidate(JustIceCandidate, NoIceCandidate), encodeToString, decodeFromString, Message)
import Gonimo.Util (coerceEffects)
import Gonimo.WebAPI (deleteSocketByFamilyIdByFromDeviceByToDeviceByChannelIdMessagesByMessageNumber, putSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Subscriber (getSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Pux.Html (text, Html)
import Pux.Html.Attributes (offset)
import Servant.Subscriber (Subscriptions)
import Unsafe.Coerce (unsafeCoerce)
import WebRTC.MediaStream (createObjectURL, mediaStreamToBlob, stopStream, getUserMedia, MediaStreamConstraints(MediaStreamConstraints), MediaStream)
import WebRTC.RTC (MediaStreamEvent, setLocalDescription, createAnswer, iceEventCandidate, IceEvent, onicecandidate, onaddstream, addIceCandidate, setRemoteDescription, fromRTCSessionDescription, createOffer, addStream, RTCIceCandidateInit, RTCPeerConnection, Ice, newRTCPeerConnection)

init :: Maybe MediaStream -> IO State
init stream = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ {url : "turn:gonimo.com:3478"} ] })
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ stream
    liftEff $ MediaStream.clone origStream
  pure $  { mediaStream : ourStream
          , remoteStream : Nothing
          , rtcConnection : rtcConnection
          , isBabyStation : isJust stream
          }

remoteStream :: forall a b r. Lens { "remoteStream" :: a | r } { "remoteStream" :: b | r } a b
remoteStream = lens _."remoteStream" (_ { "remoteStream" = _ })

update :: forall ps. Update (Props ps) State Action
update action = case action of
  InitConnection                     -> handleInit -- Things we can't do in init already.
  StartStreaming constraints         -> handleStartStreaming constraints
  SetMediaStream stream              -> handleSetMediaStream stream
  StopStreaming                      -> closeStream
  CloseConnection                    -> handleCloseConnection
  AcceptMessage num message          -> handleAcceptMessage num message
  OnIceCandidate iceEvent            -> handleOnIceCandidate iceEvent
  OnAddStream streamEvent            -> handleOnAddStream streamEvent
  SetRemoteStream stream             -> remoteStream .= Just stream *> pure []
  ReportError _                      -> noEffects
  Nop                                -> noEffects

handleInit :: forall ps. ComponentType (Props ps) State Action
handleInit = do
  props <- ask :: Component (Props ps) State (Props ps)
  state <- get :: Component (Props ps) State State
  sendMessage <- getSendMessage
  pure
    [ do
         liftEff $ onaddstream (coerceEffects <<< props.sendAction <<< OnAddStream ) state.rtcConnection
         liftEff $ onicecandidate (coerceEffects <<< props.sendAction <<< OnIceCandidate ) state.rtcConnection
         if state.isBabyStation
           then pure Nop
           else sendMessage Message.StartStreaming
    ]

handleStartStreaming :: forall ps.
                        MediaStreamConstraints
                        -> ComponentType (Props ps) State Action
handleStartStreaming constraints =
  pure [ liftAff $ SetMediaStream <$> coerceEffects (getUserMedia constraints) ]

handleSendStartStreaming :: forall ps. ComponentType (Props ps) State Action
handleSendStartStreaming = do
  sendMessage <- getSendMessage
  pure [ sendMessage Message.StartStreaming ]

handleSetMediaStream :: forall ps. MediaStream -> ComponentType (Props ps) State Action
handleSetMediaStream stream = do
  mediaStream .= Just stream
  startStreaming stream

startStreaming :: forall ps. MediaStream -> ComponentType (Props ps) State Action
startStreaming stream = do
  state <- get
  sendMessage <- getSendMessage
  pure [ do
            liftEff $ addStream stream state.rtcConnection
            offer <- liftAff $ createOffer state.rtcConnection
            liftAff $ setLocalDescription offer state.rtcConnection
            sendMessage $ Message.SessionDescriptionOffer offer
            pure Nop
       ]

handleOnIceCandidate :: forall ps. IceEvent -> ComponentType (Props ps) State Action
handleOnIceCandidate event = do
  let candidate = iceEventCandidate event
  let mCandidate = maybe NoIceCandidate JustIceCandidate candidate
  sendMessage <- getSendMessage
  pure [ sendMessage $ Message.IceCandidate mCandidate ]

handleOnAddStream :: forall ps. MediaStreamEvent  -> ComponentType (Props ps) State Action
handleOnAddStream event = do
  pure [ do
            url <- liftEff <<< createObjectURL <<< mediaStreamToBlob $ event.stream
            pure $ SetRemoteStream $ { stream : event.stream, objectURL : url }
       ]

getSendMessage :: forall ps. Component (Props ps) State (Message -> IO Action)
getSendMessage = do
  let sendString = putSocketByFamilyIdByFromDeviceByToDeviceByChannelId
  props <- ask
  let familyId' = props.familyId
  let fromDevice' = props.ourId
  let toDevice' = props.theirId
  let channelId' = props.cSecret
  pure $ toIO props.settings <<< ( \msg ->  do
    let strMsg = encodeToString msg
    sendString strMsg familyId' fromDevice' toDevice' channelId'
    pure Nop)

handleAcceptMessage :: forall ps. MessageNumber -> Message -> ComponentType (Props ps) State Action
handleAcceptMessage msgNumber msg = do
    props <- ask
    actions <- handleMessage
    let deleteMessage = deleteSocketByFamilyIdByFromDeviceByToDeviceByChannelIdMessagesByMessageNumber
    deleteActions <- runGonimo $ do
      deleteMessage props.familyId props.theirId props.ourId props.cSecret msgNumber
      pure Nop
    pure $ deleteActions <> actions
  where
    handleMessage :: ComponentType (Props ps) State Action
    handleMessage = do
      state <- get
      sendMessage <- getSendMessage
      case msg of
        Message.StartStreaming -> fromMaybe (pure []) $ startStreaming <$> state.mediaStream
        Message.SessionDescriptionOffer description ->
          pure [ do
                  liftAff $ setRemoteDescription description state.rtcConnection
                  answer <- liftAff $ createAnswer state.rtcConnection
                  liftAff $ setLocalDescription answer state.rtcConnection
                  sendMessage $ Message.SessionDescriptionAnswer answer
              ]
        Message.SessionDescriptionAnswer description ->
          pure [ do
                  liftAff $ setRemoteDescription description state.rtcConnection
                  pure Nop
              ]
        Message.IceCandidate candidate ->
          pure [ do
                  let test = runMaybeIceCandidate candidate
                  case test of
                    Nothing -> pure unit -- let's see whether this helps
                    Just c -> liftAff $ addIceCandidate (runMaybeIceCandidate candidate) state.rtcConnection
                  pure Nop
              ]
        Message.CloseConnection -> closeStream

closeStream :: forall ps. ComponentType (Props ps) State Action
closeStream = do
  state <- get
  pure $ fromMaybe [] $ do
    stream <- state.mediaStream
    pure [ liftEff $ do
              stopStream stream
              pure Nop
         ]

handleCloseConnection :: forall ps. ComponentType (Props ps) State Action
handleCloseConnection = do
  sendMessage <- getSendMessage
  closeActions <- closeStream
  pure $ closeActions <> [ sendMessage Message.CloseConnection ]

view :: forall ps. Props ps -> State -> Html Action
view props state =
  let
    mBabyDevice = Tuple.lookup props.theirId props.onlineDevices
    babyName = fromMaybe "unknown baby" $ mBabyDevice ^? _Just <<< _Baby
  in
    H.div [ A.className "panel panel-default" ]
            [ H.div [ A.className "panel-heading" ]
              [
                H.text babyName
              ]
            , viewVideo state
            ]

viewVideo :: State -> Html Action
viewVideo state =
   case state.remoteStream of
       Nothing -> H.text $ "Sorry - no video there yet, please check that your camera/microphone "
                  <> "are enabled on the baby station and your browser allows us to access it."
       Just stream ->
         H.video [ A.src stream.objectURL
                 , A.autoPlay "true"
                 , A.controls true
                 , A.width "100%"
                 ] []

getSubscriptions :: forall m ps. (MonadReader Settings m) => Props ps -> m (Subscriptions Action)
getSubscriptions props =
  let
    receiveMessage = getSocketByFamilyIdByFromDeviceByToDeviceByChannelId doDecode
    doDecode :: Maybe (Maybe (Tuple MessageNumber String)) -> Action
    doDecode (Just (Just (Tuple num msg))) = fromMaybe Nop
                                             $ AcceptMessage num <$> decodeFromString msg
    doDecode _                             = Nop
  in
    receiveMessage props.familyId props.theirId props.ourId props.cSecret


add Request.UpdateSpot

add Request.UpdateSpot

module Request.UpdateSpot (updateSpot) where

import Control.Monad.Aff (Aff)
import Data.GetSpotResponse (GetSpotResponse(..))
import Data.Options ((:=))
import Data.StrMap (fromFoldable) as StrMap
import Data.Tuple (Tuple(..))
import Fetch (HTTP, fetch)
import Fetch.Options (Method(..), body, headers, method, url) as FetchOptions
import Prelude (Unit, ($), (<>), (<$>), const, show, unit)

body :: GetSpotResponse -> String
body (GetSpotResponse { description
                      -- , details :: Array Detail
                      , lat
                      , lng
                      , name
                      , radius
                      , stampByLocation
                      , stampByQrCode
                      , tagline
                      , zoom
                      }) =
  "{"
  <> " " <> show "view_type" <> ":" <> show "admin" <> ","
  <> " " <> show "description" <> ":" <> show description <> ","
  -- TODO: details
  <> " " <> show "lat" <> ":" <> show lat <> ","
  <> " " <> show "lng" <> ":" <> show lng <> ","
  <> " " <> show "name" <> ":" <> show name <> ","
  <> " " <> show "radius" <> ":" <> show radius <> ","
  <> " " <> show "stamp_by_location" <> ":" <> show stampByLocation <> ","
  <> " " <> show "stamp_by_qr_code" <> ":" <> show stampByQrCode <> ","
  <> " " <> show "tagline" <> ":" <> show tagline <> ","
  <> " " <> show "zoom" <> ":" <> show zoom
  <> " }"

url :: Int -> String
url spotId = "https://api.rallyapp.jp/spots/" <> show spotId

updateSpot
  :: forall eff
   . Int
  -> GetSpotResponse
  -> String
  -> Aff ( http :: HTTP
         | eff
         ) Unit
updateSpot spotId spot token = const unit <$> fetch options
  where
    headers = StrMap.fromFoldable [ Tuple "Content-Type" "application/json"
                                  , Tuple "User-Agent" "rally-cli"
                                  , Tuple "Authorization" $ "Token token=\"" <> token <> "\""
                                  ]
    options = FetchOptions.method := FetchOptions.PATCH
              <> FetchOptions.url := (url spotId)
              <> FetchOptions.headers := headers
              <> FetchOptions.body := (body spot)

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


Fund requests are shown in UI

Fund requests are shown in UI

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


Add failing test case for #1169

Add failing test case for #1169

-- @shouldFailWith IncorrectConstructorArity
module Test where

data Outer a = Outer a

data Inner a b = Inner a b

test1 :: forall a b. Outer (Inner a b) -> Boolean
test1 (Outer (Inner _)) = true

test2 :: forall a b. Inner a b -> Boolean
test2 (Inner _) = true

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


Add Pursuit search code migrated from atom plugin

module IdePurescript.Pursuit where

import Prelude

import Control.Error.Util (hush)
import Control.Monad.Aff (Aff)
import Data.Argonaut (class DecodeJson, Json, decodeJson, (.?))
import Data.Argonaut.Decode ((.??))
import Data.Array (filter)
import Data.Either (either)
import Data.Maybe (Maybe)
import Data.MediaType.Common (applicationJSON)
import Network.HTTP.Affjax (AJAX, Affjax, affjax, defaultRequest)
import Network.HTTP.RequestHeader (RequestHeader(..))

newtype PursuitSearchInfo = PursuitSearchInfo
  { typeOrValue :: Maybe String
  , mod :: Maybe String
  , typeText :: Maybe String
  , title :: Maybe String
  , typ :: String
  }

instance decodeJsonPursuitSearchInfo :: DecodeJson PursuitSearchInfo where
  decodeJson json =
    do
      obj <- decodeJson json
      typeOrValue <- obj .?? "typeOrValue"
      mod <- obj .?? "module"
      typeText <- pure $ hush $ obj .? "typeText"
      title <- obj .?? "title"
      typ <- obj .? "type"
      pure $ PursuitSearchInfo { typeOrValue, mod, typeText, title, typ }

newtype PursuitSearchResult = PursuitSearchResult
  { text :: String
  , markup :: String
  , url :: String
  , version :: String
  , package :: String
  , info :: PursuitSearchInfo
  }

instance decodeJsonPursuitSearchResult :: DecodeJson PursuitSearchResult where
  decodeJson json =
    do
      obj <- decodeJson json
      text <- obj .? "text"
      markup <- obj .? "markup"
      url <- obj .? "url"
      version <- obj .? "version"
      package <- obj .? "package"
      info <- obj .? "info"
      pure $ PursuitSearchResult { text, markup, url, version, package, info }

pursuitRequest :: forall e a. String -> Affjax e Json
pursuitRequest text = affjax $ defaultRequest
  { url = "https://pursuit.purescript.org/search?q=" <> text
  , headers = [ Accept applicationJSON ]
  }

pursuitSearchRequest :: forall eff. String -> Aff ( ajax :: AJAX | eff ) (Array PursuitSearchResult)
pursuitSearchRequest text = do
  res <- pursuitRequest text
  let decoded = decodeJson res.response
  pure $ either (pure []) id $ decoded

pursuitModuleSearchRequest :: forall eff. String -> Aff ( ajax :: AJAX | eff ) (Array PursuitSearchResult)
pursuitModuleSearchRequest text = do
  res <- pursuitRequest text
  let decoded = decodeJson res.response
      results = either (pure []) id $ decoded
  pure $ filter isModule results

  where
    isModule (PursuitSearchResult { info: PursuitSearchInfo { typ: "module" } }) = true
    isModule _ = false

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


Added integration tests

Added integration tests

module Test.Main where

import Prelude hiding (degree)

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

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

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

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

import Quantities ((./), (.*), milli, nano, meter, inch, hour, minute, kilo,
                   mile, gram, second, deci, tera, hertz, degree, radian)

import Insect.Language (Func(..), BinOp(..), Expression(..), Statement(..))
import Insect.Parser (parseInsect)
import Insect.Environment (Environment, initialEnvironment)
import Insect (repl)

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

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

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

expectOutput ∷ ∀ eff. Environment → String → String → Aff eff Unit
expectOutput env expected inp =
  let res = repl env inp
      out = res.msg
  in
    unless (out == expected) do
      failure $ "Unexpected result:\n" <>
                "Input:    '" <> inp <> "'\n" <>
                "Output:   '" <> out <> "'\n" <>
                "Expected: '" <> expected <> "'\n"

main ∷ Eff (console ∷ CONSOLE, testOutput ∷ TESTOUTPUT, avar ∷ AVAR) Unit
main = runTest do
  -- Helper to construct quantities
  let q s u = BinOp Mul (Scalar s) (Unit u)

  suite "Parser - Numbers" do
    test "Simple numbers" do
      allParseAs (Expression (Scalar 1.0))
        [ "1"
        , "1.0"
        , "  1  "
        , " 1.0000   "
        , " +1.0   "
        , "+1"
        ]

      allParseAs (Expression (Scalar 3.5))
        [ "3.5"
        , "  3.5  "
        , "3.50"
        , "+3.50"
        ]

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

    test "Negative numbers" do
      shouldParseAs (Expression (Negate (Scalar 123.45)))
        "-123.45"

    test "Exponential notation" do
      shouldParseAs (Expression (Negate (Scalar 1.3e13)))
        "-1.3e13"

      shouldParseAs (Expression (Scalar 2.7e-3))
        "2.7e-3"

      shouldFail "2.7e 3"

  suite "Parser - Units" do
    test "Simple" do
      allParseAs (Expression (Unit meter))
        [ "m"
        , "      m "
        , "meter"
        , "meters"
        ]

      allParseAs (Expression (Unit inch))
        [ "in"
        , "      in "
        , "inch"
        , "inches"
        ]

      allParseAs (Expression (Unit degree))
        [ "°"
        , "      ° "
        , "deg"
        , "degree"
        , "degrees"
        ]

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

      allParseAs (Expression (q 5.0 second))
        [ "5s"
        , "5second"
        , "5 seconds"
        ]

      allParseAs (Expression (q 5.0 gram))
        [ "5g"
        , "5gram"
        , "5 grams"
        ]

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

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

      allParseAs (Expression (q 360.0 degree))
        [ "360degrees"
        , "360degree"
        , "360deg"
        , "360°"
        , "360.0°"
        ]

      allParseAs (Expression (q 1.0 radian))
        [ "1.0rad"
        , "1.0 radian"
        , "1.0 radians"
        ]

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

      allParseAs (Expression (q 2.3 (milli meter)))
        [ "2.3mm"
        , "  2.3 mm "
        , "  2.3 mmeter "
        , "  2.3 mmeters "
        ]

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

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

      allParseAs (Expression (q 2.3 (deci meter)))
        [ "2.3dm"
        , "  2.3 dm "
        ]

      allParseAs (Expression (q 42.3 (tera hertz)))
        [ "42.3THz"
        , "42.3Thertz"
        ]

    test "Divisions" do
      allParseAs (Expression (BinOp Mul (Scalar 2.3) (BinOp Div (Unit (kilo meter)) (Unit hour))))
        [ "2.3km/h"
        , "2.30km/h"
        ]

  suite "Parser - Operators" do
    test "Exponentiation" do
      allParseAs (Expression (BinOp Pow (Scalar 5.0) (Scalar 3.0))) $
        [ "5^3"
        , " 5 ^ 3 "
        , " ( 5 ) ^ ( 3 ) "
        , " ( ( 5 ) ^ ( 3 ) ) "
        , " ( 5 ^ 3 ) "
        , "5^(+3)"
        , "+5^3"
        ]

      shouldParseAs (Expression (BinOp Pow (Scalar 2.0) (BinOp Pow (Scalar 3.0) (BinOp Pow (Scalar 4.0) (Scalar 5.0))))) $
        "2^3^4^5"

      allParseAs (Expression (BinOp Pow (Scalar 4.0) (Scalar 3.0))) $
        [ "4^3"
        , "4 ^ 3"
        , "4**3"
        , "4 ** 3"
        , "4³"
        , "4  ³"
        ]

      allParseAs (Expression (BinOp Pow (Variable "pi") (Scalar 2.0))) $
        [ "pi^2"
        , "pi ^ 2"
        , "pi**2"
        , "pi ** 2"
        , "pi²"
        , "(pi)²"
        ]

      allParseAs (Expression (Negate (BinOp Pow (Scalar 3.0) (Scalar 4.0)))) $
        [ "-3^4"
        , "-3 ^ 4"
        , "-3**4"
        , "-3 ** 4"
        , "-(3^4)"
        ]

      allParseAs (Expression (BinOp Pow (Scalar 3.0) (Negate (Scalar 1.4)))) $
        [ "3 ^ (-1.4)"
        , "3 ** (-1.4)"
        ]

    test "Multiplication" do
      allParseAs (Expression (BinOp Mul (Scalar 5.0) (Scalar 3.0))) $
        [ "5*3"
        , " 5 * 3 "
        , " ( 5 ) * ( 3 ) "
        , " ( 5 ) ( 3 ) "
        , " ( ( 5 ) * ( 3 ) ) "
        , " ( 5 * 3 ) "
        , "5(3)"
        , "(5)3"
        , "5(+3)"
        , "+5*3"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 5.0) (Negate $ Scalar 3.0))) $
        [ "5*(-3)"
        , " 5 * (-3) "
        , " ( 5 ) * ( -3 ) "
        , " ( ( 5 ) * (-( 3 )) ) "
        , " ( 5 * (-3) ) "
        , "+5*(-3)"
        ]

    test "Division" do
      allParseAs (Expression (BinOp Div (Scalar 5.0) (Scalar 3.0))) $
        [ "5/3"
        , " 5 / 3 "
        , " ( 5 ) / ( 3 ) "
        , " ( ( 5 ) / ( 3 ) ) "
        , " ( 5 / 3 ) "
        ]

    test "Addition" do
      allParseAs (Expression (BinOp Add (Scalar 5.0) (Scalar 3.0))) $
        [ "5+3"
        , " 5 + 3 "
        , " ( 5 ) + ( 3 ) "
        , " ( ( 5 ) + ( 3 ) ) "
        , " ( 5 + 3 ) "
        ]

    test "Precedence" do
      allParseAs (Expression (BinOp Add (q 5.0 meter) (BinOp Mul (q 3.0 inch) (Scalar 7.0)))) $
        [ "5m+3in*7"
        , "5m+(3in*7)"
        , "5m+(3in·7)"
        , "  5 m +   3  in * 7    "
        ]

      allParseAs (Expression (BinOp Mul (BinOp Add (q 5.0 meter) (q 3.0 inch)) (Scalar 7.0))) $
        [ "(5m+3in)*7"
        , "((5m+3in))*7"
        , "(((((((5m))+((3in)))))))*((7))"
        , "  (  5 m + ( 3  in )  )  * 7    "
        ]

      allParseAs (Expression (BinOp Mul (BinOp Div (Scalar 5.0) (Scalar 3.0)) (Scalar 2.0)))
        [ "5/3*2"
        , "(5/3)*2"
        ]

      shouldFail "3+*4"
      shouldFail "3*/4"
      shouldFail "(3+4"
      shouldFail "3+4)"
      shouldFail "3+("
      shouldFail "()"
      shouldFail "(3+)4"

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

    test "Involving units" do
      allParseAs (Expression (BinOp Pow (q 3.0 meter) (Scalar 2.0))) $
        [ "(3m)^2"
        , "(3.0m)^(2.0)"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 3.0) (BinOp Pow (Unit meter) (Scalar 2.0)))) $
        [ "3m^2"
        , "3.0(m)^(2.0)"
        , "3m²"
        , "3 m²"
        , "3·m²"
        , "3·m^(2.0)"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 3.0) (BinOp Div (Unit meter) (Unit second)))) $
        [ "3m/s"
        , "3·m/s"
        , "3 meter / second"
        , "3 meter / sec"
        ]

      allParseAs (Expression (BinOp Pow (Unit meter) (Negate $ Scalar 1.0))) $
        [ "m^(-1)"
        , "m^(-1.0)"
        , "meter^(-1.0)"
        ]

  suite "Parser - Conversions" do
    test "Simple" do
      allParseAs (Expression (BinOp ConvertTo (q (2.3) meter) (Unit inch)))
        [ "2.3m -> in"
        , "  2.3 meters->inches "
        , "  2.3 m  ->  in "
        ]

      allParseAs (Expression (BinOp ConvertTo (q 120.0 minute) (Unit hour)))
        [ "120min -> h"
        , "120minutes -> hours"
        ]

      shouldFail "2.3m->"

    test "Complex units" do
      allParseAs (Expression (BinOp ConvertTo (BinOp Mul (Scalar 36.0) (BinOp Div (Unit (kilo meter)) (Unit hour))) (Unit (mile ./ hour))))
        [ "36km/h -> mph"
        , "36·km/h -> mph"
        ]

      allParseAs (Expression (BinOp ConvertTo (BinOp Mul (Scalar 36.0) (BinOp Div (Unit (kilo meter)) (Unit hour))) (BinOp Div (Unit meter) (Unit second))))
        [ "36km/h -> m/s"
        , "36·km/h -> m/s"
        ]

  suite "Parser - Identifiers" do
    test "Valid and invalid names" do
      shouldParseAs (Expression (Variable "x")) "x"
      shouldParseAs (Expression (Variable "µ")) "µ"
      shouldParseAs (Expression (Variable "pi")) "pi"
      shouldParseAs (Expression (Variable "x_2")) "x_2"
      shouldParseAs (Expression (Variable "länge")) "länge"
      shouldParseAs (Expression (Variable "_prefixed")) "_prefixed"
      shouldParseAs (Expression (Variable "x'")) "x'"
      shouldParseAs (Expression (Variable "t''")) "t''"

      shouldFail "xs,as"
      shouldFail "hello$"

    test "Variables which begin like units" do
      shouldParseAs (Expression (Variable "myVariable")) "myVariable"
      shouldParseAs (Expression (Variable "density")) "density"

  suite "Parser - Functions" do
    test "Simple" do
      allParseAs (Expression (Apply Sin (q 30.0 degree)))
        [ "sin(30°)"
        , "  sin( 30° )  "
        , "  sin( +30° )  "
        ]

      allParseAs (Expression (Apply Sqrt (Scalar 2.0)))
        [ "sqrt(2)"
        , "  sqrt( 2.0 )  "
        , "  sqrt( +2.0 )  "
        ]

      allParseAs (Expression (Apply Exp (Negate $ Scalar 10.0)))
        [ "exp(-10)"
        , "  exp( -10 )  "
        ]

  suite "Parser - Assignments" do
    test "Simple" do
      allParseAs (Assignment "xyz_123" (Scalar 1.0)) $
        [ "xyz_123 = 1"
        , "xyz_123=1"
        , "  xyz_123  =  1  "
        ]

      shouldFail "x²=3"
      shouldFail "x+y=3"
      shouldFail "x+2=3"
      shouldFail "3=5"
      shouldFail "x="

  let expectOutput' = expectOutput initialEnvironment

  suite "Integration" do
    test "Simple" do
      expectOutput' "3.0m" "3m"
      expectOutput' "3.0m" " 3.0 meter  "

    test "Implicit multiplication" do
      let myEnv = insert "x" (5.0 .* meter) initialEnvironment
      expectOutput myEnv "5.0m" "x"
      expectOutput myEnv "10.0m" "2x"
      expectOutput myEnv "10.0m" "2 x"
      expectOutput myEnv "25.0m²" "x x"
      expectOutput myEnv "25.0m²" "x²"
      expectOutput myEnv "Unknown variable 'x2'" "x2"

    test "Simple" do
      expectOutput' "1080.0" "1920/16*9"
      expectOutput' "4294967296.0" "2^32"
      expectOutput' "36.316811075498" "pi(1.4+2)²"
      expectOutput' "904778684233.8604km³" "4/3 pi (6000km)³"
      expectOutput' "2.5min" "2min + 30s"
      expectOutput' "150.0s" "2min + 30s -> sec"
      expectOutput' "26.8224m/s" "60mph -> m/s"
      expectOutput' "10.0km/h" "240km/day -> km/h"
      expectOutput' "0.057295779513082325°" "1mrad -> °"
      expectOutput' "364.0d" "52weeks -> days"
      expectOutput' "12.7cm" "5in -> cm"
      expectOutput' "0.7071067811865476" "cos(pi/4)"
      expectOutput' "0.49999999999999994" "sin(30°)"
      expectOutput' "8.530765609948133°" "atan(30cm/(2m)) -> °"

    test "Earth mass" do
      let env1 = initialEnvironment
          env2 = (repl env1 "r = 6000km").newEnv
          env3 = (repl env2 "vol = 4/3 pi r³").newEnv
          env4 = (repl env3 "density = 5g/cm³").newEnv

      expectOutput env4 "4.5238934211693013e+24kg" "vol * density -> kg"

    test "Pendulum" do
      let env1 = initialEnvironment
          env2 = (repl env1 "grav = 9.81m/s²").newEnv
          env3 = (repl env2 "L = 20cm").newEnv

      expectOutput env3 "897.1402930932747ms" "2pi*sqrt(L/grav) -> ms"

module Test.Main where

import Prelude hiding (degree)

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

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

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

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

import Quantities ((./), milli, nano, meter, inch, hour, minute, kilo, mile,
                   gram, second, deci, tera, hertz, degree, radian)

import Insect.Language (Func(..), BinOp(..), Expression(..), Statement(..))
import Insect.Parser (parseInsect)

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

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

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

main ∷ Eff (console ∷ CONSOLE, testOutput ∷ TESTOUTPUT, avar ∷ AVAR) Unit
main = runTest do
  -- Helper to construct quantities
  let q s u = BinOp Mul (Scalar s) (Unit u)

  suite "Parser - Numbers" do
    test "Simple numbers" do
      allParseAs (Expression (Scalar 1.0))
        [ "1"
        , "1.0"
        , "  1  "
        , " 1.0000   "
        , " +1.0   "
        , "+1"
        ]

      allParseAs (Expression (Scalar 3.5))
        [ "3.5"
        , "  3.5  "
        , "3.50"
        , "+3.50"
        ]

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

    test "Negative numbers" do
      shouldParseAs (Expression (Negate (Scalar 123.45)))
        "-123.45"

    test "Exponential notation" do
      shouldParseAs (Expression (Negate (Scalar 1.3e13)))
        "-1.3e13"

      shouldParseAs (Expression (Scalar 2.7e-3))
        "2.7e-3"

      shouldFail "2.7e 3"

  suite "Parser - Units" do
    test "Simple" do
      allParseAs (Expression (Unit meter))
        [ "m"
        , "      m "
        , "meter"
        , "meters"
        ]

      allParseAs (Expression (Unit inch))
        [ "in"
        , "      in "
        , "inch"
        , "inches"
        ]

      allParseAs (Expression (Unit degree))
        [ "°"
        , "      ° "
        , "deg"
        , "degree"
        , "degrees"
        ]

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

      allParseAs (Expression (q 5.0 second))
        [ "5s"
        , "5second"
        , "5 seconds"
        ]

      allParseAs (Expression (q 5.0 gram))
        [ "5g"
        , "5gram"
        , "5 grams"
        ]

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

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

      allParseAs (Expression (q 360.0 degree))
        [ "360degrees"
        , "360degree"
        , "360deg"
        , "360°"
        , "360.0°"
        ]

      allParseAs (Expression (q 1.0 radian))
        [ "1.0rad"
        , "1.0 radian"
        , "1.0 radians"
        ]

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

      allParseAs (Expression (q 2.3 (milli meter)))
        [ "2.3mm"
        , "  2.3 mm "
        , "  2.3 mmeter "
        , "  2.3 mmeters "
        ]

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

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

      allParseAs (Expression (q 2.3 (deci meter)))
        [ "2.3dm"
        , "  2.3 dm "
        ]

      allParseAs (Expression (q 42.3 (tera hertz)))
        [ "42.3THz"
        , "42.3Thertz"
        ]

    test "Divisions" do
      allParseAs (Expression (BinOp Mul (Scalar 2.3) (BinOp Div (Unit (kilo meter)) (Unit hour))))
        [ "2.3km/h"
        , "2.30km/h"
        ]

  suite "Parser - Operators" do
    test "Exponentiation" do
      allParseAs (Expression (BinOp Pow (Scalar 5.0) (Scalar 3.0))) $
        [ "5^3"
        , " 5 ^ 3 "
        , " ( 5 ) ^ ( 3 ) "
        , " ( ( 5 ) ^ ( 3 ) ) "
        , " ( 5 ^ 3 ) "
        , "5^(+3)"
        , "+5^3"
        ]

      shouldParseAs (Expression (BinOp Pow (Scalar 2.0) (BinOp Pow (Scalar 3.0) (BinOp Pow (Scalar 4.0) (Scalar 5.0))))) $
        "2^3^4^5"

      allParseAs (Expression (BinOp Pow (Scalar 4.0) (Scalar 3.0))) $
        [ "4^3"
        , "4 ^ 3"
        , "4**3"
        , "4 ** 3"
        , "4³"
        , "4  ³"
        ]

      allParseAs (Expression (BinOp Pow (Variable "pi") (Scalar 2.0))) $
        [ "pi^2"
        , "pi ^ 2"
        , "pi**2"
        , "pi ** 2"
        , "pi²"
        , "(pi)²"
        ]

      allParseAs (Expression (Negate (BinOp Pow (Scalar 3.0) (Scalar 4.0)))) $
        [ "-3^4"
        , "-3 ^ 4"
        , "-3**4"
        , "-3 ** 4"
        , "-(3^4)"
        ]

      allParseAs (Expression (BinOp Pow (Scalar 3.0) (Negate (Scalar 1.4)))) $
        [ "3 ^ (-1.4)"
        , "3 ** (-1.4)"
        ]

    test "Multiplication" do
      allParseAs (Expression (BinOp Mul (Scalar 5.0) (Scalar 3.0))) $
        [ "5*3"
        , " 5 * 3 "
        , " ( 5 ) * ( 3 ) "
        , " ( 5 ) ( 3 ) "
        , " ( ( 5 ) * ( 3 ) ) "
        , " ( 5 * 3 ) "
        , "5(3)"
        , "(5)3"
        , "5(+3)"
        , "+5*3"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 5.0) (Negate $ Scalar 3.0))) $
        [ "5*(-3)"
        , " 5 * (-3) "
        , " ( 5 ) * ( -3 ) "
        , " ( ( 5 ) * (-( 3 )) ) "
        , " ( 5 * (-3) ) "
        , "+5*(-3)"
        ]

    test "Division" do
      allParseAs (Expression (BinOp Div (Scalar 5.0) (Scalar 3.0))) $
        [ "5/3"
        , " 5 / 3 "
        , " ( 5 ) / ( 3 ) "
        , " ( ( 5 ) / ( 3 ) ) "
        , " ( 5 / 3 ) "
        ]

    test "Addition" do
      allParseAs (Expression (BinOp Add (Scalar 5.0) (Scalar 3.0))) $
        [ "5+3"
        , " 5 + 3 "
        , " ( 5 ) + ( 3 ) "
        , " ( ( 5 ) + ( 3 ) ) "
        , " ( 5 + 3 ) "
        ]

    test "Precedence" do
      allParseAs (Expression (BinOp Add (q 5.0 meter) (BinOp Mul (q 3.0 inch) (Scalar 7.0)))) $
        [ "5m+3in*7"
        , "5m+(3in*7)"
        , "5m+(3in·7)"
        , "  5 m +   3  in * 7    "
        ]

      allParseAs (Expression (BinOp Mul (BinOp Add (q 5.0 meter) (q 3.0 inch)) (Scalar 7.0))) $
        [ "(5m+3in)*7"
        , "((5m+3in))*7"
        , "(((((((5m))+((3in)))))))*((7))"
        , "  (  5 m + ( 3  in )  )  * 7    "
        ]

      allParseAs (Expression (BinOp Mul (BinOp Div (Scalar 5.0) (Scalar 3.0)) (Scalar 2.0)))
        [ "5/3*2"
        , "(5/3)*2"
        ]

      shouldFail "3+*4"
      shouldFail "3*/4"
      shouldFail "(3+4"
      shouldFail "3+4)"
      shouldFail "3+("
      shouldFail "()"
      shouldFail "(3+)4"

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

    test "Involving units" do
      allParseAs (Expression (BinOp Pow (q 3.0 meter) (Scalar 2.0))) $
        [ "(3m)^2"
        , "(3.0m)^(2.0)"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 3.0) (BinOp Pow (Unit meter) (Scalar 2.0)))) $
        [ "3m^2"
        , "3.0(m)^(2.0)"
        , "3m²"
        , "3 m²"
        , "3·m²"
        , "3·m^(2.0)"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 3.0) (BinOp Div (Unit meter) (Unit second)))) $
        [ "3m/s"
        , "3·m/s"
        , "3 meter / second"
        , "3 meter / sec"
        ]

      allParseAs (Expression (BinOp Pow (Unit meter) (Negate $ Scalar 1.0))) $
        [ "m^(-1)"
        , "m^(-1.0)"
        , "meter^(-1.0)"
        ]

  suite "Parser - Conversions" do
    test "Simple" do
      allParseAs (Expression (BinOp ConvertTo (q (2.3) meter) (Unit inch)))
        [ "2.3m -> in"
        , "  2.3 meters->inches "
        , "  2.3 m  ->  in "
        ]

      allParseAs (Expression (BinOp ConvertTo (q 120.0 minute) (Unit hour)))
        [ "120min -> h"
        , "120minutes -> hours"
        ]

      shouldFail "2.3m->"

    test "Complex units" do
      allParseAs (Expression (BinOp ConvertTo (BinOp Mul (Scalar 36.0) (BinOp Div (Unit (kilo meter)) (Unit hour))) (Unit (mile ./ hour))))
        [ "36km/h -> mph"
        , "36·km/h -> mph"
        ]

      allParseAs (Expression (BinOp ConvertTo (BinOp Mul (Scalar 36.0) (BinOp Div (Unit (kilo meter)) (Unit hour))) (BinOp Div (Unit meter) (Unit second))))
        [ "36km/h -> m/s"
        , "36·km/h -> m/s"
        ]

  suite "Parser - Identifiers" do
    test "Valid and invalid names" do
      shouldParseAs (Expression (Variable "x")) "x"
      shouldParseAs (Expression (Variable "µ")) "µ"
      shouldParseAs (Expression (Variable "pi")) "pi"
      shouldParseAs (Expression (Variable "x_2")) "x_2"
      shouldParseAs (Expression (Variable "länge")) "länge"
      shouldParseAs (Expression (Variable "_prefixed")) "_prefixed"
      shouldParseAs (Expression (Variable "x'")) "x'"
      shouldParseAs (Expression (Variable "t''")) "t''"

      shouldFail "xs,as"
      shouldFail "hello$"

    test "Variables which begin like units" do
      shouldParseAs (Expression (Variable "myVariable")) "myVariable"
      shouldParseAs (Expression (Variable "density")) "density"

  suite "Parser - Functions" do
    test "Simple" do
      allParseAs (Expression (Apply Sin (q 30.0 degree)))
        [ "sin(30°)"
        , "  sin( 30° )  "
        , "  sin( +30° )  "
        ]

      allParseAs (Expression (Apply Sqrt (Scalar 2.0)))
        [ "sqrt(2)"
        , "  sqrt( 2.0 )  "
        , "  sqrt( +2.0 )  "
        ]

      allParseAs (Expression (Apply Exp (Negate $ Scalar 10.0)))
        [ "exp(-10)"
        , "  exp( -10 )  "
        ]

  suite "Parser - Assignments" do
    test "Simple" do
      allParseAs (Assignment "xyz_123" (Scalar 1.0)) $
        [ "xyz_123 = 1"
        , "xyz_123=1"
        , "  xyz_123  =  1  "
        ]

      shouldFail "x²=3"
      shouldFail "x+y=3"
      shouldFail "x+2=3"
      shouldFail "3=5"
      shouldFail "x="


Add `odd`, `even`

Add `odd`, `even`

module Data.Int
  ( fromNumber
  , toNumber
  , even
  , odd
  ) where

import Data.Int.Bits

-- | Creates an `Int` from a `Number` value. If the value is not already an
-- | integer it is rounded towards zero (so both `0.9` and `-0.9` will become
-- | `Int 0`).
foreign import fromNumber
  """
  function fromNumber(n) {
    return n|0;
  }
  """ :: Number -> Int

-- | Converts an `Int` value back into a `Number`. Any `Int` is a valid `Number`
-- | so there is no loss of precision with this function.
foreign import toNumber
  """
  function toNumber(n) {
    return n;
  }
  """ :: Int -> Number

-- | Returns whether an `Int` is an even number.
-- |
-- |     even 0 == true
-- |     even 1 == false
even :: Int -> Boolean
even x = x .&. 1 == 0

-- | The negation of `even`.
-- |
-- |     odd 0 == false
-- |     odd 1 == false
odd :: Int -> Boolean
odd = not <<< even

module Data.Int
  ( fromNumber
  , toNumber
  ) where

-- | Creates an `Int` from a `Number` value. If the value is not already an
-- | integer it is rounded towards zero (so both `0.9` and `-0.9` will become
-- | `Int 0`).
foreign import fromNumber
  """
  function fromNumber(n) {
    return n|0;
  }
  """ :: Number -> Int

-- | Converts an `Int` value back into a `Number`. Any `Int` is a valid `Number`
-- | so there is no loss of precision with this function.
foreign import toNumber
  """
  function toNumber(n) {
    return n;
  }
  """ :: Int -> Number


impl Damage

impl Damage

module KanColle.DamageAnalysis.Damage
  ( DameCon(..)
  , Ship
  , Damage
  , mkDamage
  , mergeDamage
  , addDamage
  , applyDamage
  )
where

import Prelude
import Data.Maybe
import Data.Int as Int

data DameCon
  = RepairTeam
  | RepairGodness

type Ship =
  { hp :: Int
  , fullHp :: Int
  , sunk :: Boolean
  , dameCon :: Maybe DameCon
  }

-- a Damage modifies a ship's state properly
newtype Damage = Damage (Ship -> Ship)

-- apply DameCon to a Ship, regardless of ship's own DameCon setting
applyDameCon :: DameCon -> Ship -> Ship
applyDameCon dc s = case dc of
    RepairTeam -> s1 {hp = Int.floor (0.2 * Int.toNumber s.fullHp)}
    RepairGodness -> s1 {hp = s.fullHp}
  where
    s1 = s {sunk = false, dameCon = Nothing}

-- when a Ship is sinking, apply DameCon to a Ship if any.
tryDameCon :: Ship -> Ship
tryDameCon s = if s.sunk
    then -- only attempt applying damecon if the ship is sinking
      maybe s (\dc -> applyDameCon dc s) s.dameCon
    else s

-- apply a damage number to a ship
applyDamageNum :: Int -> Ship -> Ship
applyDamageNum v s =
    let newHp = s.hp - v
    in s {hp = newHp, sunk = newHp <= 0}

-- create "Damage"
mkDamage :: Int -> Damage
mkDamage 0 = Damage id
mkDamage v = Damage (applyDamageNum v >>> tryDameCon)

-- create new Damage by applying two Damages in order
mergeDamage :: Damage -> Damage -> Damage
mergeDamage (Damage d1) (Damage d2) = Damage (d1 >>> d2)

-- add damage value to an existing Damage
addDamage :: Damage -> Int -> Damage
addDamage dmg v = dmg `mergeDamage` mkDamage v

-- apply Damage to a Ship, DameCon will be used if applicable.
applyDamage :: Damage -> Ship -> Ship
applyDamage (Damage f) = f

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


Cover failing case in BindingGroups

Cover failing case in BindingGroups

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


Add Evaluator skeleton

Add Evaluator skeleton

module Evaluator where

import Data.StrMap
import Data.Tuple
import Data.Maybe

import AST

type Env = StrMap (Tuple [Binding] Expr)

defsToEnv :: [Definition] -> Env
defsToEnv _ = empty

eval1 :: Env -> Expr -> Expr
eval1 _ _ = Atom $ Name $ "not_implemented"

apply :: Env -> String -> [Expr] -> Maybe Expr
apply _ _ _ = Nothing

matchAndReplace :: [Binding] -> [Expr] -> Expr -> Maybe Expr
matchAndReplace _ _ _ = Nothing

replace :: String -> Expr -> Expr -> Expr
replace _ _ _ = Atom $ Name $ "not_implemented"

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


add Data.Export

add Data.Export

module Data.Export (Export(..)) where

import Data.Foreign.Class (class IsForeign, readProp)
import Data.GetSpotResponse (GetSpotResponse)
import Data.GetStampRallyResponse (GetStampRallyResponse)
import Data.Show (class Show, show)
import Prelude (($), (<>), bind, pure)

data Export = Export { spots :: Array GetSpotResponse
                     , stampRally :: GetStampRallyResponse
                     }

instance exportShow :: Show Export where
  show (Export { spots
               , stampRally
               }) =
    "{"
    <> " \"spots\": " <> show spots <> ","
    <> " \"stampRally\": " <> show stampRally
    <> " }"

instance exportIsForeign :: IsForeign Export where
  read v = do
    spots <- readProp "spots" v
    stampRally <- readProp "stampRally" v
    pure $ Export { spots
                  , stampRally
                  }

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


Added utility types/functions for servant-purescript codegen

-- | Utility functions and types needed by servant-purescript code generator.
module Servant.Subscriber.Util where

import Prelude
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(Tuple))
import Data.Generic (class Generic)
import Data.Traversable (traverse)
import Servant.PureScript.Settings (gDefaultToURLPiece)
import Data.Array (concatMap)

import Servant.Subscriber (ToUserType)

type TypedToUser a b = Maybe a -> b

toUserType :: forall a b. Generic a => TypedToUser a b -> ToUserType b
toUserType typed = map typed <<< traverse decodeJson

subGenNormalQuery :: forall a . Generic a => String -> a -> Array (Tuple String (Maybe String))
subGenNormalQuery fName val = [ Tuple fName ((Just <<< gDefaultToURLPiece) val) ]

subGenListQuery :: forall a . Generic a => String -> Array a -> Array (Tuple String (Maybe String))
subGenListQuery fName = concatMap (subGenNormalQuery fName)

subGenFlagQuery :: String -> Boolean -> Array (Tuple String (Maybe String))
subGenFlagQuery fName false = []
subGenFlagQuery fName true  = [ Tuple fName Nothing ]

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


Code cleanup

Code cleanup

-- | 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)
import Data.List (List, sortBy, filter, groupBy)
import Data.List.NonEmpty (NonEmptyList(..), head)
import Data.Maybe (Maybe(..))
import Data.NonEmpty (NonEmpty)
import Data.String (toLower)
import Data.StrMap (lookup, insert, toUnfoldable)
import Data.Tuple (fst, snd)
import Data.Traversable (traverse)

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

import Insect.Language (Func(..), BinOp(..), Expression(..), Command(..),
                        Statement(..), Identifier)
import Insect.Environment (Environment, StorageType(..), StoredValue(..),
                           initialEnvironment)
import Insect.Functions (fromCelsius, fromFahrenheit, toCelsius, toFahrenheit)
import Insect.Format (Markup)
import Insect.Format as F
import Insect.PrettyPrint (pretty, prettyQuantity)

-- | Types of errors that may appear during evaluation.
data EvalError
  = QConversionError ConversionError
  | LookupError String
  | NumericalError
  | RedefinedConstantError Identifier

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

-- | Apply a mathematical function to a physical quantity.
applyFunction ∷ Func → NonEmpty List Quantity → Expect Quantity
applyFunction fn qs = lmap QConversionError $ (run fn) (head (NonEmptyList qs))
  where
    run Acos           = Q.acos
    run Acosh          = Q.acosh
    run Asin           = Q.asin
    run Asinh          = Q.asinh
    run Atan           = Q.atan
    run Atanh          = Q.atanh
    run Ceil           = Q.ceil
    run Cos            = Q.cos
    run Cosh           = Q.cosh
    run Exp            = Q.exp
    run Floor          = Q.floor
    run FromCelsius    = fromCelsius
    run FromFahrenheit = fromFahrenheit
    run Gamma          = Q.gamma
    run Ln             = Q.ln
    run Log10          = Q.log10
    run Round          = Q.round
    run Sin            = Q.sin
    run Sinh           = Q.sinh
    run Sqrt           = Q.sqrt >>> pure
    run Tan            = Q.tan
    run Tanh           = Q.tanh
    run ToCelsius      = toCelsius
    run ToFahrenheit   = toFahrenheit

-- | 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 fn xs)   = traverse (eval env) xs >>= applyFunction fn >>= checkFinite
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 (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 "The constant ", F.ident 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
  }

-- | 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 (Assignment n v) =
  case evalAndSimplify env v of
    Left evalErr → errorWithInput [ F.ident n, F.text " = " ] v env evalErr
    Right value →
      let response =
            { msg: Message ValueSet $
                        (F.optional <$> [ F.text "  ", F.ident n, F.text " = " ])
                     <> prettyQuantity value
            , newEnv: env { values = insert n (StoredValue UserDefined value) env.values }
          }
      in
        case lookup n env.values of
          Just (StoredValue t _) →
            if t == Constant || t == HiddenConstant
              then errorWithInput [ F.ident n, F.text " = " ] v env (RedefinedConstantError n)
              else response
          _ → response
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)
import Data.List (List, sortBy, filter, groupBy)
import Data.List.NonEmpty (NonEmptyList(..), head)
import Data.Maybe (Maybe(..))
import Data.NonEmpty (NonEmpty)
import Data.String (toLower)
import Data.StrMap (lookup, insert, toUnfoldable)
import Data.Tuple (fst, snd)
import Data.Traversable (traverse)

import Quantities (Quantity, ConversionError(..), pow, scalar', qNegate, qAdd,
                   qDivide, qMultiply, qSubtract, quantity, toScalar', sqrt,
                   convertTo, prettyPrint', fullSimplify, derivedUnit, acos,
                   asin, atan, sin, cos, tan, exp, ln, sinh, cosh, tanh, asinh,
                   acosh, atanh, ceil, floor, gamma, log10, round, isFinite,
                   toStandardUnit, unity, toString, baseRepresentation,
                   factorial, modulo)

import Insect.Language (Func(..), BinOp(..), Expression(..), Command(..),
                        Statement(..), Identifier)
import Insect.Environment (Environment, StorageType(..), StoredValue(..), initialEnvironment)
import Insect.Functions (fromCelsius, fromFahrenheit, toCelsius, toFahrenheit)
import Insect.Format (Markup)
import Insect.Format as F
import Insect.PrettyPrint (pretty, prettyQuantity)

-- | Types of errors that may appear during evaluation.
data EvalError
  = QConversionError ConversionError
  | LookupError String
  | NumericalError
  | RedefinedConstantError Identifier

-- | 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 | isFinite q = pure q
              | otherwise  = Left NumericalError

-- | Apply a mathematical function to a physical quantity.
applyFunction ∷ Func → NonEmpty List Quantity → Expect Quantity
applyFunction fn qs = lmap QConversionError $ (run fn) (head (NonEmptyList qs))
  where
    run Acos           = acos
    run Acosh          = acosh
    run Asin           = asin
    run Asinh          = asinh
    run Atan           = atan
    run Atanh          = atanh
    run Ceil           = ceil
    run Cos            = cos
    run Cosh           = cosh
    run Exp            = exp
    run Floor          = floor
    run FromCelsius    = fromCelsius
    run FromFahrenheit = fromFahrenheit
    run Gamma          = gamma
    run Ln             = ln
    run Log10          = log10
    run Round          = round
    run Sin            = sin
    run Sinh           = sinh
    run Sqrt           = sqrt >>> pure
    run Tan            = tan
    run Tanh           = tanh
    run ToCelsius      = toCelsius
    run ToFahrenheit   = toFahrenheit

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Scalar n)      = pure $ scalar' n
eval env (Unit u)        = pure $ 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 >>= factorial >>> lmap QConversionError
eval env (Negate x)      = qNegate <$> eval env x
eval env (Apply fn xs)   = traverse (eval env) xs >>= applyFunction fn >>= checkFinite
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 (qMultiply a b)
    run Div       a b = pure (qDivide a b)
    run Pow       a b = 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 (qSubtract q1 q2)
    qAdd' q1 q2 = wrap (qAdd q1 q2)
    toScalar'' q = wrap (toScalar' q)
    modulo' q1 q2 = wrap (modulo q1 q2)
    convertTo' source target = wrap (convertTo source (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 = fullSimplify <$> eval env e

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

-- | Get the error message for an evaluation error.
evalErrorMessage ∷ EvalError → Markup
evalErrorMessage (QConversionError ue) =
  conversionErrorMessage ue
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 "The constant ", F.ident 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
  }

-- | 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 (Assignment n v) =
  case evalAndSimplify env v of
    Left evalErr → errorWithInput [ F.ident n, F.text " = " ] v env evalErr
    Right value →
      let response =
            { msg: Message ValueSet $
                        (F.optional <$> [ F.text "  ", F.ident n, F.text " = " ])
                     <> prettyQuantity value
            , newEnv: env { values = insert n (StoredValue UserDefined value) env.values }
          }
      in
        case lookup n env.values of
          Just (StoredValue t _) →
            if t == Constant || t == HiddenConstant
              then errorWithInput [ F.ident n, F.text " = " ] v env (RedefinedConstantError n)
              else response
          _ → response
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 <<< 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 }


Adding an ADT for the program's state

Adding an ADT for the program's state

module AppState where

import Control.Monad.JQuery(JQuery(..))

data AppState = AppState
  { adderBtn       :: JQuery
  , adderTable     :: JQuery
  , cardHolder     :: JQuery
  , cardNumSpinner :: JQuery
  , nameInput      :: JQuery
  , pickBtn        :: JQuery
  , playerNums     :: [Number]
  }

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


Restore Profunctor newtype for Component

module Halogen.Component.Profunctor (ProComponent(..)) where

import Prelude

import Data.Bifunctor (lmap)
import Data.Newtype (class Newtype)
import Data.Profunctor (class Profunctor, dimap)
import Halogen.Component (Component, ComponentSpec', component', unComponent)
import Halogen.Query.HalogenM as HM

newtype ProComponent h f m i o = ProComponent (Component h f i o m)

derive instance newtypeProComponent :: Newtype (ProComponent h f m i o) _

instance profunctorProComponent :: Functor f => Profunctor (ProComponent h f m) where
  dimap f g (ProComponent c) =
    ProComponent (unComponent (component' <<< dimapSpec f g) c)

dimapSpec
  :: forall h s f act ps i j o p m
   . Functor f
  => (j -> i)
  -> (o -> p)
  -> ComponentSpec' h s f act ps i o m
  -> ComponentSpec' h s f act ps j p m
dimapSpec f g spec =
  { initialState: spec.initialState <<< f
  , render: spec.render
  , eval: dimap (lmap f) (HM.mapOutput g) spec.eval
  }

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