-----------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ViewPatterns               #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE CPP                        #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Navigator
-- Copyright   :  (C) 2016-2025 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
----------------------------------------------------------------------------
module Miso.Navigator
  ( -- ** User media
    getUserMedia
  , userMedia
  , UserMedia (..)
  , Stream
  -- ** Clipboard
  , copyClipboard
  -- ** OnLine
  , isOnLine
  -- ** Geolocation
  , geolocation
  , Geolocation (..)
  , GeolocationError (..)
  , GeolocationErrorCode (..)
  ) where
-----------------------------------------------------------------------------
import           Control.Monad ((<=<))
import           Language.Javascript.JSaddle
import           Prelude hiding ((!!))
-----------------------------------------------------------------------------
import           Miso.String
import           Miso.Effect
import qualified Miso.FFI.Internal as FFI
----------------------------------------------------------------------------
type Stream = JSVal
----------------------------------------------------------------------------
-- | Get access to user's media devices.
--
-- <https://developer.mozilla.org/en-US/docs/Web/API/MediaDevices/getUserMedia>
--
getUserMedia
  :: UserMedia
  -- ^ Options
  -> (Stream -> action)
  -- ^ Successful callback
  -> (JSVal -> action)
  -- ^ Errorful callback
  -> Effect parent model action
getUserMedia :: forall action parent model.
UserMedia
-> (Stream -> action)
-> (Stream -> action)
-> Effect parent model action
getUserMedia UserMedia {Bool
audio :: Bool
video :: Bool
audio :: UserMedia -> Bool
video :: UserMedia -> Bool
..} Stream -> action
successful Stream -> action
errorful =
  (Sink action -> JSM ()) -> Effect parent model action
forall action parent model.
(Sink action -> JSM ()) -> Effect parent model action
withSink ((Sink action -> JSM ()) -> Effect parent model action)
-> (Sink action -> JSM ()) -> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \Sink action
sink ->
    Bool -> Bool -> (Stream -> JSM ()) -> (Stream -> JSM ()) -> JSM ()
FFI.getUserMedia Bool
audio Bool
video
      (Sink action
sink Sink action -> (Stream -> action) -> Stream -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream -> action
successful)
      (Sink action
sink Sink action -> (Stream -> action) -> Stream -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream -> action
errorful)
-----------------------------------------------------------------------------
-- | Get access to the user's clipboard.
--
-- <https://developer.mozilla.org/en-US/docs/Web/API/Navigator/clipboard>
--
copyClipboard
  :: MisoString
  -- ^ Options
  -> action
  -- ^ Successful callback
  -> (JSVal -> action)
  -- ^ Errorful callback
  -> Effect parent model action
copyClipboard :: forall action parent model.
MisoString
-> action -> (Stream -> action) -> Effect parent model action
copyClipboard MisoString
txt action
successful Stream -> action
errorful =
  (Sink action -> JSM ()) -> Effect parent model action
forall action parent model.
(Sink action -> JSM ()) -> Effect parent model action
withSink ((Sink action -> JSM ()) -> Effect parent model action)
-> (Sink action -> JSM ()) -> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \Sink action
sink ->
    MisoString -> JSM () -> (Stream -> JSM ()) -> JSM ()
FFI.copyClipboard MisoString
txt
      (Sink action
sink action
successful)
      (Sink action
sink Sink action -> (Stream -> action) -> Stream -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream -> action
errorful)
-----------------------------------------------------------------------------
-- | Get user's online status
--
-- <https://developer.mozilla.org/en-US/docs/Web/API/Navigator/onLine>
--
isOnLine
  :: (Bool -> action)
  -- ^ Successful callback
  -> Effect parent model action
isOnLine :: forall action parent model.
(Bool -> action) -> Effect parent model action
isOnLine Bool -> action
action = JSM action -> Effect parent model action
forall action parent model.
JSM action -> Effect parent model action
io (Bool -> action
action (Bool -> action) -> JSM Bool -> JSM action
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSM Bool
FFI.isOnLine)
-----------------------------------------------------------------------------
-- | Type for dealing with 'navigator.mediaDevices.getUserMedia'
--
-- <https://developer.mozilla.org/en-US/docs/Web/API/Navigator/mediaDevices>
--
data UserMedia
  = UserMedia
  { UserMedia -> Bool
audio, UserMedia -> Bool
video :: Bool
  } deriving (Int -> UserMedia -> ShowS
[UserMedia] -> ShowS
UserMedia -> String
(Int -> UserMedia -> ShowS)
-> (UserMedia -> String)
-> ([UserMedia] -> ShowS)
-> Show UserMedia
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserMedia -> ShowS
showsPrec :: Int -> UserMedia -> ShowS
$cshow :: UserMedia -> String
show :: UserMedia -> String
$cshowList :: [UserMedia] -> ShowS
showList :: [UserMedia] -> ShowS
Show, UserMedia -> UserMedia -> Bool
(UserMedia -> UserMedia -> Bool)
-> (UserMedia -> UserMedia -> Bool) -> Eq UserMedia
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UserMedia -> UserMedia -> Bool
== :: UserMedia -> UserMedia -> Bool
$c/= :: UserMedia -> UserMedia -> Bool
/= :: UserMedia -> UserMedia -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Default 'UserMedia'
userMedia :: UserMedia
userMedia :: UserMedia
userMedia = Bool -> Bool -> UserMedia
UserMedia Bool
True Bool
True
-----------------------------------------------------------------------------
-- | Geolocation fetching
--
-- <https://developer.mozilla.org/en-US/docs/Web/API/Navigator/geolocation>
--
geolocation
  :: (Geolocation -> action) 
  -> (GeolocationError -> action) 
  -> Effect parent model action
geolocation :: forall action parent model.
(Geolocation -> action)
-> (GeolocationError -> action) -> Effect parent model action
geolocation Geolocation -> action
successful GeolocationError -> action
errorful = do
  (Sink action -> JSM ()) -> Effect parent model action
forall action parent model.
(Sink action -> JSM ()) -> Effect parent model action
withSink ((Sink action -> JSM ()) -> Effect parent model action)
-> (Sink action -> JSM ()) -> Effect parent model action
forall a b. (a -> b) -> a -> b
$ \Sink action
sink ->
    (Stream -> JSM ()) -> (Stream -> JSM ()) -> JSM ()
FFI.geolocation
      (Sink action
sink Sink action -> (Geolocation -> action) -> Geolocation -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Geolocation -> action
successful (Geolocation -> JSM ())
-> (Stream -> JSM Geolocation) -> Stream -> JSM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Stream -> JSM Geolocation
forall a. FromJSVal a => Stream -> JSM a
fromJSValUnchecked)
      (Sink action
sink Sink action
-> (GeolocationError -> action) -> GeolocationError -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GeolocationError -> action
errorful (GeolocationError -> JSM ())
-> (Stream -> JSM GeolocationError) -> Stream -> JSM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Stream -> JSM GeolocationError
forall a. FromJSVal a => Stream -> JSM a
fromJSValUnchecked)
-----------------------------------------------------------------------------
data GeolocationError = GeolocationError GeolocationErrorCode MisoString
  deriving (Int -> GeolocationError -> ShowS
[GeolocationError] -> ShowS
GeolocationError -> String
(Int -> GeolocationError -> ShowS)
-> (GeolocationError -> String)
-> ([GeolocationError] -> ShowS)
-> Show GeolocationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GeolocationError -> ShowS
showsPrec :: Int -> GeolocationError -> ShowS
$cshow :: GeolocationError -> String
show :: GeolocationError -> String
$cshowList :: [GeolocationError] -> ShowS
showList :: [GeolocationError] -> ShowS
Show, GeolocationError -> GeolocationError -> Bool
(GeolocationError -> GeolocationError -> Bool)
-> (GeolocationError -> GeolocationError -> Bool)
-> Eq GeolocationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GeolocationError -> GeolocationError -> Bool
== :: GeolocationError -> GeolocationError -> Bool
$c/= :: GeolocationError -> GeolocationError -> Bool
/= :: GeolocationError -> GeolocationError -> Bool
Eq)
-----------------------------------------------------------------------------
instance FromJSVal GeolocationError where
  fromJSVal :: Stream -> JSM (Maybe GeolocationError)
fromJSVal Stream
v = do
    code <- Stream -> JSM (Maybe GeolocationErrorCode)
forall a. FromJSVal a => Stream -> JSM (Maybe a)
fromJSVal (Stream -> JSM (Maybe GeolocationErrorCode))
-> JSM Stream -> JSM (Maybe GeolocationErrorCode)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Stream
v Stream -> String -> JSM Stream
forall this name.
(MakeObject this, ToJSString name) =>
this -> name -> JSM Stream
! String
"code")
    msg <- fromJSVal =<< (v ! "message")
    pure (GeolocationError <$> code <*> msg)
-----------------------------------------------------------------------------
data GeolocationErrorCode
  = PERMISSION_DENIED
  | POSITION_UNAVAILABLE
  | TIMEOUT
  deriving (Int -> GeolocationErrorCode
GeolocationErrorCode -> Int
GeolocationErrorCode -> [GeolocationErrorCode]
GeolocationErrorCode -> GeolocationErrorCode
GeolocationErrorCode
-> GeolocationErrorCode -> [GeolocationErrorCode]
GeolocationErrorCode
-> GeolocationErrorCode
-> GeolocationErrorCode
-> [GeolocationErrorCode]
(GeolocationErrorCode -> GeolocationErrorCode)
-> (GeolocationErrorCode -> GeolocationErrorCode)
-> (Int -> GeolocationErrorCode)
-> (GeolocationErrorCode -> Int)
-> (GeolocationErrorCode -> [GeolocationErrorCode])
-> (GeolocationErrorCode
    -> GeolocationErrorCode -> [GeolocationErrorCode])
-> (GeolocationErrorCode
    -> GeolocationErrorCode -> [GeolocationErrorCode])
-> (GeolocationErrorCode
    -> GeolocationErrorCode
    -> GeolocationErrorCode
    -> [GeolocationErrorCode])
-> Enum GeolocationErrorCode
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: GeolocationErrorCode -> GeolocationErrorCode
succ :: GeolocationErrorCode -> GeolocationErrorCode
$cpred :: GeolocationErrorCode -> GeolocationErrorCode
pred :: GeolocationErrorCode -> GeolocationErrorCode
$ctoEnum :: Int -> GeolocationErrorCode
toEnum :: Int -> GeolocationErrorCode
$cfromEnum :: GeolocationErrorCode -> Int
fromEnum :: GeolocationErrorCode -> Int
$cenumFrom :: GeolocationErrorCode -> [GeolocationErrorCode]
enumFrom :: GeolocationErrorCode -> [GeolocationErrorCode]
$cenumFromThen :: GeolocationErrorCode
-> GeolocationErrorCode -> [GeolocationErrorCode]
enumFromThen :: GeolocationErrorCode
-> GeolocationErrorCode -> [GeolocationErrorCode]
$cenumFromTo :: GeolocationErrorCode
-> GeolocationErrorCode -> [GeolocationErrorCode]
enumFromTo :: GeolocationErrorCode
-> GeolocationErrorCode -> [GeolocationErrorCode]
$cenumFromThenTo :: GeolocationErrorCode
-> GeolocationErrorCode
-> GeolocationErrorCode
-> [GeolocationErrorCode]
enumFromThenTo :: GeolocationErrorCode
-> GeolocationErrorCode
-> GeolocationErrorCode
-> [GeolocationErrorCode]
Enum, Int -> GeolocationErrorCode -> ShowS
[GeolocationErrorCode] -> ShowS
GeolocationErrorCode -> String
(Int -> GeolocationErrorCode -> ShowS)
-> (GeolocationErrorCode -> String)
-> ([GeolocationErrorCode] -> ShowS)
-> Show GeolocationErrorCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GeolocationErrorCode -> ShowS
showsPrec :: Int -> GeolocationErrorCode -> ShowS
$cshow :: GeolocationErrorCode -> String
show :: GeolocationErrorCode -> String
$cshowList :: [GeolocationErrorCode] -> ShowS
showList :: [GeolocationErrorCode] -> ShowS
Show, GeolocationErrorCode -> GeolocationErrorCode -> Bool
(GeolocationErrorCode -> GeolocationErrorCode -> Bool)
-> (GeolocationErrorCode -> GeolocationErrorCode -> Bool)
-> Eq GeolocationErrorCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GeolocationErrorCode -> GeolocationErrorCode -> Bool
== :: GeolocationErrorCode -> GeolocationErrorCode -> Bool
$c/= :: GeolocationErrorCode -> GeolocationErrorCode -> Bool
/= :: GeolocationErrorCode -> GeolocationErrorCode -> Bool
Eq)
-----------------------------------------------------------------------------
instance FromJSVal GeolocationErrorCode where
  fromJSVal :: Stream -> JSM (Maybe GeolocationErrorCode)
fromJSVal Stream
code =
    Stream -> JSM Int
forall a. FromJSVal a => Stream -> JSM a
fromJSValUnchecked Stream
code JSM Int
-> (Int -> JSM (Maybe GeolocationErrorCode))
-> JSM (Maybe GeolocationErrorCode)
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Int
1 :: Int) -> Maybe GeolocationErrorCode -> JSM (Maybe GeolocationErrorCode)
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GeolocationErrorCode -> Maybe GeolocationErrorCode
forall a. a -> Maybe a
Just GeolocationErrorCode
PERMISSION_DENIED)
      Int
2 -> Maybe GeolocationErrorCode -> JSM (Maybe GeolocationErrorCode)
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GeolocationErrorCode -> Maybe GeolocationErrorCode
forall a. a -> Maybe a
Just GeolocationErrorCode
POSITION_UNAVAILABLE)
      Int
3 -> Maybe GeolocationErrorCode -> JSM (Maybe GeolocationErrorCode)
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GeolocationErrorCode -> Maybe GeolocationErrorCode
forall a. a -> Maybe a
Just GeolocationErrorCode
TIMEOUT)
      Int
_ -> Maybe GeolocationErrorCode -> JSM (Maybe GeolocationErrorCode)
forall a. a -> JSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GeolocationErrorCode
forall a. Maybe a
Nothing
-----------------------------------------------------------------------------
data Geolocation
  = Geolocation
  { Geolocation -> Double
latitude, Geolocation -> Double
longitude, Geolocation -> Double
accuracy :: Double
  } deriving (Int -> Geolocation -> ShowS
[Geolocation] -> ShowS
Geolocation -> String
(Int -> Geolocation -> ShowS)
-> (Geolocation -> String)
-> ([Geolocation] -> ShowS)
-> Show Geolocation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Geolocation -> ShowS
showsPrec :: Int -> Geolocation -> ShowS
$cshow :: Geolocation -> String
show :: Geolocation -> String
$cshowList :: [Geolocation] -> ShowS
showList :: [Geolocation] -> ShowS
Show, Geolocation -> Geolocation -> Bool
(Geolocation -> Geolocation -> Bool)
-> (Geolocation -> Geolocation -> Bool) -> Eq Geolocation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Geolocation -> Geolocation -> Bool
== :: Geolocation -> Geolocation -> Bool
$c/= :: Geolocation -> Geolocation -> Bool
/= :: Geolocation -> Geolocation -> Bool
Eq)
-----------------------------------------------------------------------------
instance FromJSVal Geolocation where
  fromJSVal :: Stream -> JSM (Maybe Geolocation)
fromJSVal Stream
geo = do
    lat <- Stream -> JSM (Maybe Double)
forall a. FromJSVal a => Stream -> JSM (Maybe a)
fromJSVal (Stream -> JSM (Maybe Double)) -> JSM Stream -> JSM (Maybe Double)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stream
geo Stream -> String -> JSM Stream
forall this name.
(MakeObject this, ToJSString name) =>
this -> name -> JSM Stream
! String
"coords" JSM Stream -> String -> JSM Stream
forall this name.
(MakeObject this, ToJSString name) =>
this -> name -> JSM Stream
! String
"latitude"
    lon <- fromJSVal =<< geo ! "coords" ! "longitude"
    acc <- fromJSVal =<< geo ! "coords" ! "accuracy"
    pure (Geolocation <$> lat <*> lon <*> acc)
-----------------------------------------------------------------------------