Safe union, now with good type errors

Safe union, now with good type errors

module Genetics.Browser.Track
       ( class TrackRecord
       , buildTrack
       , makeTrack
       , TrackConfigRecord
       , class TrackConfig
       , makeContainersImpl
       , makeContainers
       , class TrackData
       , fetchDataImpl
       , fetchData
       , class CombineFuns
       , combineFunsImpl
       , combineFuns
       , class SafeUnion
       , class UnionConflict
       , class ConflictingList
       , class ConflictsWith
       , LayerDef(..)
       ) where

import Prelude

import Data.Foldable (foldMap)
import Data.Maybe (Maybe)
import Data.Pair (Pair)
import Effect (Effect)
import Effect.Aff (Aff)
import Genetics.Browser.Canvas (TrackContainer, trackContainer, withLoadingIndicator)
import Genetics.Browser.Coordinates (CoordSysView)
import Genetics.Browser.Layer (TrackPadding)
import Genetics.Browser.Types (Point)
import Prim.Boolean (False, True, kind Boolean)
import Prim.Row as Row
import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
import Prim.TypeError (class Fail, Above, Beside, Quote, Text)
import Record (delete, get, insert)
import Type.Data.Boolean as Boolean
import Type.Data.Symbol as Symbol
import Type.Prelude (class IsSymbol, class TypeEquals, Proxy(..), RLProxy(..), RProxy(..), SProxy(..), from)
import Unsafe.Coerce (unsafeCoerce)

type TrackInterface a =
  { render   :: Pair Number -> CoordSysView -> Aff Unit
  , hotspots :: Aff (Number -> Point -> Array a) }

class TrackRecord
      (trackList :: RowList)
      (trackRow :: # Type)
      a
      | trackList -> trackRow
      , trackList -> a where
  buildTrack :: RLProxy trackList
             -> Record trackRow
             -> TrackContainer
             -> Aff { render   :: Pair Number -> CoordSysView -> Aff Unit
                    , hotspots :: Aff (Number -> Point -> Array a) }

instance trackRecordRender ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Pair Number -> CoordSysView -> Aff Unit) trackRow' trackRow
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Pair Number -> CoordSysView -> Aff Unit) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let rLayer p c = (get name r) p c

    pure { render:   rLayer <> rest.render
         , hotspots: rest.hotspots }

instance trackRecordUI ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Aff Unit) trackRow' trackRow
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Aff Unit) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let rLayer _ _ = (get name r)

    pure { render:   rLayer <> rest.render
         , hotspots: rest.hotspots }

instance trackRecordHotspots ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Aff (Number -> pt -> Array a)) trackRow' trackRow
  , TypeEquals pt Point
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Aff (Number -> pt -> Array a)) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let hotspots = ado
          h  <- get name r
          h' <- rest.hotspots
          in \rad p -> h rad (from p) <> h' rad p

    pure { render: rest.render, hotspots }

instance trackRecordNil ::
  ( TypeEquals (Record trackRow) {}
  ) => TrackRecord Nil trackRow a where
  buildTrack _ _ _ = mempty

makeTrack :: ∀ row list a.
             RowToList row list
          => TrackRecord list row a
          => Record row
          -> TrackContainer
          -> Aff (TrackInterface a)
makeTrack r c = buildTrack (RLProxy :: RLProxy list) r c

type TrackConfigRecord r =
  { trackHeight :: Number
  , padding :: TrackPadding | r }

class TrackConfig
  (confList :: RowList)
  (confRow  :: # Type)
  (trackRow :: # Type)
  | confList -> confRow trackRow
  where
  makeContainersImpl :: RLProxy confList
                     -> Number
                     -> Record confRow
                     -> Effect (Record trackRow)

instance trackConfigNil ::
  ( TypeEquals (Record tr) {}
  ) => TrackConfig Nil cr tr where
  makeContainersImpl _ _ _ = pure $ from {}

instance trackConfigCons ::
  ( IsSymbol name
  , TrackConfig tail confRow' trackRow'
  , Row.Cons name c confRow' confRow
  , Row.Lacks name confRow'
  , Row.Cons name TrackContainer trackRow' trackRow
  , Row.Lacks name trackRow'
  , TypeEquals (TrackConfigRecord we) c
  ) => TrackConfig (Cons name c tail) confRow trackRow where
  makeContainersImpl _ width r = do
    let n = SProxy :: SProxy name

        c :: TrackConfigRecord we
        c = from $ get n r

    cont <- trackContainer
              {width, height: c.trackHeight}
              c.padding
              (Symbol.reflectSymbol n)

    rest <- makeContainersImpl
              (RLProxy :: RLProxy tail)
              width
              (delete n $ from r)

    pure $ insert n cont rest

makeContainers :: ∀ cl cr tr.
                  RowToList cr cl
               => TrackConfig cl cr tr
               => Number
               -> Record cr
               -> Effect (Record tr)
makeContainers = makeContainersImpl (RLProxy :: RLProxy cl)

class TrackData
      (fetcherList :: RowList)
      (fetcherRow :: # Type)
      (urlRow :: # Type)
      (dataRow :: # Type)
      | fetcherList -> fetcherRow
      , fetcherList -> urlRow
      , fetcherList -> dataRow where
  fetchDataImpl :: RLProxy fetcherList
            -> Record fetcherRow
            -> Record urlRow
            -> Aff (Record dataRow)

instance trackDataCons ::
  ( IsSymbol  name
  , Row.Lacks name fetcherRow'
  , Row.Cons  name (String -> Aff x) fetcherRow' fetcherRow
  , Monoid x
  , Row.Cons  name (Maybe String) urlRow' urlRow
  , Row.Lacks name dataRow'
  , Row.Cons  name x dataRow' dataRow
  , TrackData fetcherTail fetcherRow' urlRow dataRow'
  ) => TrackData (Cons name (String -> Aff x) fetcherTail)
                 fetcherRow
                 urlRow
                 dataRow where
  fetchDataImpl _ fetchers urls = do
    let name = SProxy :: _ name

    rest <- fetchDataImpl (RLProxy :: _ fetcherTail)
                          (delete name fetchers)
                          urls

    dataset <- foldMap (get name fetchers) (get name urls)

    pure $ insert name dataset rest

instance trackDataNil ::
  ( TypeEquals (Record dataRow) {}
  ) => TrackData Nil () urlRow dataRow where
  fetchDataImpl _ _ _ = pure $ from {}

-- | `fetchData` puts a loading indicator in the provided TrackContainer,
-- | fetches the data in the provided `urlRow` record, and parses it
-- | using the parsers in the provided `parserRow` record.
fetchData :: ∀ fetcherRow fetcherList urlRow urlList dataRow.
             RowToList fetcherRow fetcherList
          => RowToList urlRow urlList
          => TrackData fetcherList fetcherRow urlRow dataRow
          => TrackContainer
          -> Record fetcherRow
          -> Record urlRow
          -> Aff (Record dataRow)
fetchData tc fs urls = withLoadingIndicator tc
                       $ fetchDataImpl (RLProxy :: _ fetcherList)
                                       fs
                                       urls

-- | Combine a record of functions from records,
-- | into a function from a record of their union,
-- | to a record of their outputs.
-- | E.g. `{f :: Record r1 -> a, g :: Record r2 -> b}`
-- | into `Record (r1 + r2) -> { f :: a, g :: b }`
class CombineFuns
  (funsList :: RowList)
  (funsRow :: # Type)
  (argRow :: # Type)
  (outRow :: # Type)
  | funsList -> funsRow
  , funsList -> argRow
  , funsList -> outRow where
  combineFunsImpl :: RLProxy funsList
              -> Record funsRow
              -> Record argRow
              -> Record outRow

instance combineFunCons ::
  ( IsSymbol  name
  , Row.Lacks name funsRow'
  , Row.Cons  name (Record r -> a) funsRow' funsRow
  , SafeUnion argRow' r argRowUnion
  , Row.Lacks name outRow'
  , Row.Cons  name a outRow' outRow
  , CombineFuns funsTail funsRow' argRow' outRow'
  ) => CombineFuns (Cons name (Record r -> a) funsTail)
                  funsRow
                  argRowUnion
                  outRow where
  combineFunsImpl _ funs args =
    let name = SProxy :: _ name

        thoseArgs :: Record argRow'
        thoseArgs = unsafeCoerce args

        theseArgs :: Record r
        theseArgs = unsafeCoerce args

        rest = combineFunsImpl (RLProxy :: _ funsTail)
                               (delete name funs)
                               thoseArgs
        fn = (get name funs)

    in (insert name (fn theseArgs) rest)

instance combineFunNil ::
  ( TypeEquals (Record outRow) {}
  ) => CombineFuns Nil () () outRow where
  combineFunsImpl _ _ _ = from {}

-- | Note! this isn't actually type safe yet.
-- | If two functions use arguments with the same label
-- | but different types, things break...
combineFuns :: ∀ funsList funsRow argRow outRow.
               RowToList funsRow funsList
            => CombineFuns funsList funsRow argRow outRow
            => Record funsRow
            -> Record argRow
            -> Record outRow
combineFuns funs args = combineFunsImpl (RLProxy :: _ funsList) funs args

class BuildLayers
  (layers :: # Type)
  (output :: # Type)
  | layers -> output

class GetBrowserConfig
  (totalConfig :: # Type)
  (browser :: # Type)
  | totalConfig -> browser where
    getBrowserConfigImpl :: Record totalConfig
                         -> Record browser

instance getBrowserConfig ::
  ( IsSymbol sBrowser
  , TypeEquals (SProxy sBrowser) (SProxy "browser")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")

  , Row.Cons sBrowser (Record browser') totalConfig' totalConfig
  , Row.Lacks sBrowser totalConfig'

  , Row.Cons sLayers layers browser browser'
  , Row.Lacks sLayers browser
  ) => GetBrowserConfig totalConfig browser where
  getBrowserConfigImpl total =
    let browser' :: Record browser'
        browser' = get (from (SProxy :: _ "browser")) total
    in delete (from (SProxy :: _ "layers")) browser'

class GetTrackConfig
  (totalConfig :: # Type)
  (track :: # Type)
  (trackName :: Symbol)
  | totalConfig trackName -> track where
    getTrackConfigImpl :: Record totalConfig
                       -> SProxy trackName
                       -> Record track

instance getTrackConfig ::
  ( IsSymbol sTracks
  , TypeEquals (SProxy sTracks) (SProxy "tracks")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")
  , IsSymbol trackName

  , Row.Cons sTracks (Record tracks) totalConfig' totalConfig
  , Row.Lacks sTracks totalConfig'

  , Row.Cons trackName (Record thisTrack') tracks' tracks
  , Row.Lacks trackName tracks'

  , Row.Cons sLayers layers thisTrack thisTrack'
  , Row.Lacks sLayers thisTrack

  ) => GetTrackConfig totalConfig thisTrack trackName where
    getTrackConfigImpl total _ =
      let tracks' :: Record tracks
          tracks' = get (from (SProxy :: _ "tracks")) total

          thisTrack :: Record thisTrack'
          thisTrack = get (from (SProxy :: _ trackName)) tracks'

      in delete (from (SProxy :: _ "layers")) thisTrack

class GetLayerConfig
  (totalConfig :: # Type)
  (layer :: # Type)
  (trackName :: Symbol)
  (layerName :: Symbol)
  | totalConfig trackName layerName -> layer where
    getLayerConfigImpl :: Record totalConfig
                       -> SProxy trackName
                       -> SProxy layerName
                       -> Record layer

instance getLayerConfig ::
  ( IsSymbol sTracks
  , TypeEquals (SProxy sTracks) (SProxy "tracks")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")
  , IsSymbol trackName
  , IsSymbol layerName

  , Row.Cons sTracks (Record tracks) totalConfig' totalConfig
  , Row.Lacks sTracks totalConfig'

  , Row.Cons trackName (Record thisTrack) tracks' tracks
  , Row.Lacks trackName tracks'

  , Row.Cons sLayers (Record layers) thisTrack' thisTrack
  , Row.Lacks sLayers thisTrack

  , Row.Cons layerName (Record thisLayer) layers' layers
  , Row.Lacks layerName layers'
  ) => GetLayerConfig totalConfig thisLayer trackName layerName where
    getLayerConfigImpl total _ _ =
      let tracks' :: Record tracks
          tracks' = get (from (SProxy :: _ "tracks")) total

          thisTrack :: Record thisTrack
          thisTrack = get (from (SProxy :: _ trackName)) tracks'

          layers :: Record layers
          layers = get (from (SProxy :: _ "layers")) thisTrack

      in get (from (SProxy :: _ layerName)) layers

newtype LayerDef browser track layer a
  = LayerDef ({ browserConfig :: Record browser
              , trackConfig :: Record track
              , layerConfig :: Record layer }
              -> a)

class ApplyLayerDef
  (browser :: # Type)
  (track :: # Type)
  (layer :: # Type)
  (totalConfig :: # Type)
  (trackName :: Symbol)
  (layerName :: Symbol)
  a
  | trackName layerName totalConfig -> track layer where
    applyLayerDefImpl :: LayerDef browser track layer a
                      -> SProxy trackName
                      -> SProxy layerName
                      -> Record totalConfig
                      -> a

instance applyLayerDefInst ::
  ( IsSymbol trackName
  , IsSymbol layerName
  , GetBrowserConfig totalConfig browser
  , GetTrackConfig totalConfig track trackName
  , GetLayerConfig totalConfig layer trackName layerName
  ) => ApplyLayerDef browser track layer totalConfig trackName layerName a where
    applyLayerDefImpl (LayerDef f) trackName layerName total =
      let browserConfig = getBrowserConfigImpl total
          trackConfig = getTrackConfigImpl total trackName
          layerConfig = getLayerConfigImpl total trackName layerName
      in f { browserConfig, trackConfig, layerConfig }

applyLayerDef :: ∀ browser track layer trackName layerName config a.
                 IsSymbol trackName
              => IsSymbol layerName
              => ApplyLayerDef browser track layer config trackName layerName a
              => LayerDef browser track layer a
              -> SProxy trackName
              -> SProxy layerName
              -> Record config
              -> a
applyLayerDef = applyLayerDefImpl

-- | Class for checking if a RowList has a "conflict" with a
-- | given label and type. If the list lacks the label, or
-- | has the label with the same type, return False; if it
-- | has the label, but with a different type, return True.
class ConflictsWith
  (list :: RowList)
  (label :: Symbol)
  (t :: Type)
  (result :: Boolean)
  | list label t -> result

-- no conflict base case
instance conflictsWithNil ::
  ConflictsWith Nil label t False

-- same label and type, no conflict, recurse
instance conflictsWithCons1 ::
  ( ConflictsWith tail label t tailResult
  ) => ConflictsWith (Cons label  t  tail) label t tailResult

-- found conflict base case
else instance conflictsWithCons3 ::
  ConflictsWith (Cons label  t' tail) label t True

-- different label, same or different type, recurse
else instance conflictsWithCons2 ::
  ( ConflictsWith tail label t tailResult
  ) =>  ConflictsWith (Cons label' t' tail) label t tailResult

-- | Returns True if there are duplicates of any label with different types
class ConflictingList
  (list :: RowList)
  (result :: Boolean)
  | list -> result

instance conflictingListNil :: ConflictingList Nil False

instance conflictingListCons ::
  ( ConflictsWith tail label t conflicts
  , ConflictingList tail tailResult
  , Boolean.Or conflicts tailResult result
  ) => ConflictingList (Cons label t tail) result

class UnionConflict (left :: # Type) (right :: # Type) (fail :: Boolean)

instance unionConflictFail ::
  ( Fail (Above
          (Text "Tried to take the union of conflicting rows:\n")
          (Above (Quote (Record left))
                 (Beside (Text "\n")
                         (Quote (Record right)))))
  ) => UnionConflict left right True

else instance unionConflictSuccess ::
  UnionConflict left right False

-- | Takes the union of two rows, except it errors if there are
-- | overlapping labels of different types, and it removes the
-- | redundant entries.
class SafeUnion
  (left :: # Type)
  (right :: # Type)
  (union :: # Type)
  | left right -> union

instance safeUnion ::
  ( UnionConflict left right conflicting
  , Row.Union left right union
  , RowToList union list
  , ConflictingList list conflicting
  , Row.Nub union nubbed
  ) => SafeUnion left right nubbed

module Genetics.Browser.Track
       ( class TrackRecord
       , buildTrack
       , makeTrack
       , TrackConfigRecord
       , class TrackConfig
       , makeContainersImpl
       , makeContainers
       , class TrackData
       , fetchDataImpl
       , fetchData
       , class CombineFuns
       , combineFunsImpl
       , combineFuns
       ) where

import Prelude

import Data.Foldable (foldMap)
import Data.Maybe (Maybe)
import Data.Pair (Pair)
import Effect (Effect)
import Effect.Aff (Aff)
import Genetics.Browser.Canvas (TrackContainer, trackContainer, withLoadingIndicator)
import Genetics.Browser.Coordinates (CoordSysView)
import Genetics.Browser.Layer (TrackPadding)
import Genetics.Browser.Types (Point)
import Prim.Boolean (False, True, kind Boolean)
import Prim.Row as Row
import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
import Prim.TypeError (class Fail, Text)
import Record (delete, get, insert)
import Type.Data.Boolean as Boolean
import Type.Data.Symbol as Symbol
import Type.Prelude (class IsSymbol, class TypeEquals, Proxy(..), RLProxy(..), RProxy(..), SProxy(..), from)
import Unsafe.Coerce (unsafeCoerce)

type TrackInterface a =
  { render   :: Pair Number -> CoordSysView -> Aff Unit
  , hotspots :: Aff (Number -> Point -> Array a) }

class TrackRecord
      (trackList :: RowList)
      (trackRow :: # Type)
      a
      | trackList -> trackRow
      , trackList -> a where
  buildTrack :: RLProxy trackList
             -> Record trackRow
             -> TrackContainer
             -> Aff { render   :: Pair Number -> CoordSysView -> Aff Unit
                    , hotspots :: Aff (Number -> Point -> Array a) }

instance trackRecordRender ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Pair Number -> CoordSysView -> Aff Unit) trackRow' trackRow
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Pair Number -> CoordSysView -> Aff Unit) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let rLayer p c = (get name r) p c

    pure { render:   rLayer <> rest.render
         , hotspots: rest.hotspots }

instance trackRecordUI ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Aff Unit) trackRow' trackRow
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Aff Unit) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let rLayer _ _ = (get name r)

    pure { render:   rLayer <> rest.render
         , hotspots: rest.hotspots }

instance trackRecordHotspots ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Aff (Number -> pt -> Array a)) trackRow' trackRow
  , TypeEquals pt Point
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Aff (Number -> pt -> Array a)) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let hotspots = ado
          h  <- get name r
          h' <- rest.hotspots
          in \rad p -> h rad (from p) <> h' rad p

    pure { render: rest.render, hotspots }

instance trackRecordNil ::
  ( TypeEquals (Record trackRow) {}
  ) => TrackRecord Nil trackRow a where
  buildTrack _ _ _ = mempty

makeTrack :: ∀ row list a.
             RowToList row list
          => TrackRecord list row a
          => Record row
          -> TrackContainer
          -> Aff (TrackInterface a)
makeTrack r c = buildTrack (RLProxy :: RLProxy list) r c

type TrackConfigRecord r =
  { trackHeight :: Number
  , padding :: TrackPadding | r }

class TrackConfig
  (confList :: RowList)
  (confRow  :: # Type)
  (trackRow :: # Type)
  | confList -> confRow trackRow
  where
  makeContainersImpl :: RLProxy confList
                     -> Number
                     -> Record confRow
                     -> Effect (Record trackRow)

instance trackConfigNil ::
  ( TypeEquals (Record tr) {}
  ) => TrackConfig Nil cr tr where
  makeContainersImpl _ _ _ = pure $ from {}

instance trackConfigCons ::
  ( IsSymbol name
  , TrackConfig tail confRow' trackRow'
  , Row.Cons name c confRow' confRow
  , Row.Lacks name confRow'
  , Row.Cons name TrackContainer trackRow' trackRow
  , Row.Lacks name trackRow'
  , TypeEquals (TrackConfigRecord we) c
  ) => TrackConfig (Cons name c tail) confRow trackRow where
  makeContainersImpl _ width r = do
    let n = SProxy :: SProxy name

        c :: TrackConfigRecord we
        c = from $ get n r

    cont <- trackContainer
              {width, height: c.trackHeight}
              c.padding
              (Symbol.reflectSymbol n)

    rest <- makeContainersImpl
              (RLProxy :: RLProxy tail)
              width
              (delete n $ from r)

    pure $ insert n cont rest

makeContainers :: ∀ cl cr tr.
                  RowToList cr cl
               => TrackConfig cl cr tr
               => Number
               -> Record cr
               -> Effect (Record tr)
makeContainers = makeContainersImpl (RLProxy :: RLProxy cl)

class TrackData
      (fetcherList :: RowList)
      (fetcherRow :: # Type)
      (urlRow :: # Type)
      (dataRow :: # Type)
      | fetcherList -> fetcherRow
      , fetcherList -> urlRow
      , fetcherList -> dataRow where
  fetchDataImpl :: RLProxy fetcherList
            -> Record fetcherRow
            -> Record urlRow
            -> Aff (Record dataRow)

instance trackDataCons ::
  ( IsSymbol  name
  , Row.Lacks name fetcherRow'
  , Row.Cons  name (String -> Aff x) fetcherRow' fetcherRow
  , Monoid x
  , Row.Cons  name (Maybe String) urlRow' urlRow
  , Row.Lacks name dataRow'
  , Row.Cons  name x dataRow' dataRow
  , TrackData fetcherTail fetcherRow' urlRow dataRow'
  ) => TrackData (Cons name (String -> Aff x) fetcherTail)
                 fetcherRow
                 urlRow
                 dataRow where
  fetchDataImpl _ fetchers urls = do
    let name = SProxy :: _ name

    rest <- fetchDataImpl (RLProxy :: _ fetcherTail)
                          (delete name fetchers)
                          urls

    dataset <- foldMap (get name fetchers) (get name urls)

    pure $ insert name dataset rest

instance trackDataNil ::
  ( TypeEquals (Record dataRow) {}
  ) => TrackData Nil () urlRow dataRow where
  fetchDataImpl _ _ _ = pure $ from {}

-- | `fetchData` puts a loading indicator in the provided TrackContainer,
-- | fetches the data in the provided `urlRow` record, and parses it
-- | using the parsers in the provided `parserRow` record.
fetchData :: ∀ fetcherRow fetcherList urlRow urlList dataRow.
             RowToList fetcherRow fetcherList
          => RowToList urlRow urlList
          => TrackData fetcherList fetcherRow urlRow dataRow
          => TrackContainer
          -> Record fetcherRow
          -> Record urlRow
          -> Aff (Record dataRow)
fetchData tc fs urls = withLoadingIndicator tc
                       $ fetchDataImpl (RLProxy :: _ fetcherList)
                                       fs
                                       urls

-- | Combine a record of functions from records,
-- | into a function from a record of their union,
-- | to a record of their outputs.
-- | E.g. `{f :: Record r1 -> a, g :: Record r2 -> b}`
-- | into `Record (r1 + r2) -> { f :: a, g :: b }`
class CombineFuns
  (funsList :: RowList)
  (funsRow :: # Type)
  (argRow :: # Type)
  (outRow :: # Type)
  | funsList -> funsRow
  , funsList -> argRow
  , funsList -> outRow where
  combineFunsImpl :: RLProxy funsList
              -> Record funsRow
              -> Record argRow
              -> Record outRow

instance combineFunCons ::
  ( IsSymbol  name
  , Row.Lacks name funsRow'
  , Row.Cons  name (Record r -> a) funsRow' funsRow
  , Row.Union argRow' r argRowUnion
  , Row.Nub   argRowUnion argRowNubbed
  , Row.Lacks name outRow'
  , Row.Cons  name a outRow' outRow
  , CombineFuns funsTail funsRow' argRow' outRow'
  ) => CombineFuns (Cons name (Record r -> a) funsTail)
                  funsRow
                  argRowNubbed
                  outRow where
  combineFunsImpl _ funs args =
    let name = SProxy :: _ name

        thoseArgs :: Record argRow'
        thoseArgs = unsafeCoerce args

        theseArgs :: Record r
        theseArgs = unsafeCoerce args

        rest = combineFunsImpl (RLProxy :: _ funsTail)
                               (delete name funs)
                               thoseArgs
        fn = (get name funs)

    in (insert name (fn theseArgs) rest)

instance combineFunNil ::
  ( TypeEquals (Record outRow) {}
  ) => CombineFuns Nil () () outRow where
  combineFunsImpl _ _ _ = from {}

-- | Note! this isn't actually type safe yet.
-- | If two functions use arguments with the same label
-- | but different types, things break...
combineFuns :: ∀ funsList funsRow argRow outRow.
               RowToList funsRow funsList
            => CombineFuns funsList funsRow argRow outRow
            => Record funsRow
            -> Record argRow
            -> Record outRow
combineFuns funs args = combineFunsImpl (RLProxy :: _ funsList) funs args

class BuildLayers
  (layers :: # Type)
  (output :: # Type)
  | layers -> output

class GetBrowserConfig
  (totalConfig :: # Type)
  (browser :: # Type)
  | totalConfig -> browser where
    getBrowserConfigImpl :: Record totalConfig
                         -> Record browser

instance getBrowserConfig ::
  ( IsSymbol sBrowser
  , TypeEquals (SProxy sBrowser) (SProxy "browser")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")

  , Row.Cons sBrowser (Record browser') totalConfig' totalConfig
  , Row.Lacks sBrowser totalConfig'

  , Row.Cons sLayers layers browser browser'
  , Row.Lacks sLayers browser
  ) => GetBrowserConfig totalConfig browser where
  getBrowserConfigImpl total =
    let browser' :: Record browser'
        browser' = get (from (SProxy :: _ "browser")) total
    in delete (from (SProxy :: _ "layers")) browser'

class GetTrackConfig
  (totalConfig :: # Type)
  (track :: # Type)
  (trackName :: Symbol)
  | totalConfig trackName -> track where
    getTrackConfigImpl :: Record totalConfig
                       -> SProxy trackName
                       -> Record track

instance getTrackConfig ::
  ( IsSymbol sTracks
  , TypeEquals (SProxy sTracks) (SProxy "tracks")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")
  , IsSymbol trackName

  , Row.Cons sTracks (Record tracks) totalConfig' totalConfig
  , Row.Lacks sTracks totalConfig'

  , Row.Cons trackName (Record thisTrack') tracks' tracks
  , Row.Lacks trackName tracks'

  , Row.Cons sLayers layers thisTrack thisTrack'
  , Row.Lacks sLayers thisTrack

  ) => GetTrackConfig totalConfig thisTrack trackName where
    getTrackConfigImpl total _ =
      let tracks' :: Record tracks
          tracks' = get (from (SProxy :: _ "tracks")) total

          thisTrack :: Record thisTrack'
          thisTrack = get (from (SProxy :: _ trackName)) tracks'

      in delete (from (SProxy :: _ "layers")) thisTrack

class GetLayerConfig
  (totalConfig :: # Type)
  (layer :: # Type)
  (trackName :: Symbol)
  (layerName :: Symbol)
  | totalConfig trackName layerName -> layer where
    getLayerConfigImpl :: Record totalConfig
                       -> SProxy trackName
                       -> SProxy layerName
                       -> Record layer

instance getLayerConfig ::
  ( IsSymbol sTracks
  , TypeEquals (SProxy sTracks) (SProxy "tracks")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")
  , IsSymbol trackName
  , IsSymbol layerName

  , Row.Cons sTracks (Record tracks) totalConfig' totalConfig
  , Row.Lacks sTracks totalConfig'

  , Row.Cons trackName (Record thisTrack) tracks' tracks
  , Row.Lacks trackName tracks'

  , Row.Cons sLayers (Record layers) thisTrack' thisTrack
  , Row.Lacks sLayers thisTrack

  , Row.Cons layerName (Record thisLayer) layers' layers
  , Row.Lacks layerName layers'
  ) => GetLayerConfig totalConfig thisLayer trackName layerName where
    getLayerConfigImpl total _ _ =
      let tracks' :: Record tracks
          tracks' = get (from (SProxy :: _ "tracks")) total

          thisTrack :: Record thisTrack
          thisTrack = get (from (SProxy :: _ trackName)) tracks'

          layers :: Record layers
          layers = get (from (SProxy :: _ "layers")) thisTrack

      in get (from (SProxy :: _ layerName)) layers

newtype LayerDef browser track layer a
  = LayerDef ({ browserConfig :: Record browser
              , trackConfig :: Record track
              , layerConfig :: Record layer }
              -> a)

class ApplyLayerDef
  (browser :: # Type)
  (track :: # Type)
  (layer :: # Type)
  (totalConfig :: # Type)
  (trackName :: Symbol)
  (layerName :: Symbol)
  a
  | trackName layerName totalConfig -> track layer where
    applyLayerDefImpl :: LayerDef browser track layer a
                      -> SProxy trackName
                      -> SProxy layerName
                      -> Record totalConfig
                      -> a

instance applyLayerDefInst ::
  ( IsSymbol trackName
  , IsSymbol layerName
  , GetBrowserConfig totalConfig browser
  , GetTrackConfig totalConfig track trackName
  , GetLayerConfig totalConfig layer trackName layerName
  ) => ApplyLayerDef browser track layer totalConfig trackName layerName a where
    applyLayerDefImpl (LayerDef f) trackName layerName total =
      let browserConfig = getBrowserConfigImpl total
          trackConfig = getTrackConfigImpl total trackName
          layerConfig = getLayerConfigImpl total trackName layerName
      in f { browserConfig, trackConfig, layerConfig }

applyLayerDef :: ∀ browser track layer trackName layerName config a.
                 IsSymbol trackName
              => IsSymbol layerName
              => ApplyLayerDef browser track layer config trackName layerName a
              => LayerDef browser track layer a
              -> SProxy trackName
              -> SProxy layerName
              -> Record config
              -> a
applyLayerDef = applyLayerDefImpl

-- | Class for checking if a RowList has a "conflict" with a
-- | given label and type. If the list lacks the label, or
-- | has the label with the same type, return False; if it
-- | has the label, but with a different type, return True.
class ConflictsWith
  (list :: RowList)
  (label :: Symbol)
  (t :: Type)
  (result :: Boolean)
  | list label t -> result

-- no conflict base case
instance conflictsWithNil ::
  ConflictsWith Nil label t False

-- same label and type, no conflict, recurse
instance conflictsWithCons1 ::
  ( ConflictsWith tail label t tailResult
  ) => ConflictsWith (Cons label  t  tail) label t tailResult

-- found conflict base case
else instance conflictsWithCons3 ::
  ConflictsWith (Cons label  t' tail) label t True

-- different label, same or different type, recurse
else instance conflictsWithCons2 ::
  ( ConflictsWith tail label t tailResult
  ) =>  ConflictsWith (Cons label' t' tail) label t tailResult

hasConflict :: ∀ row list l a .
                 RowToList row list
              => IsSymbol l
              => ConflictsWith list l a True
              => RProxy row
              -> SProxy l
              -> Proxy a
              -> Unit
hasConflict _ _ _ = unit

noConflict :: ∀ row list l a .
                 RowToList row list
              => IsSymbol l
              => ConflictsWith list l a False
              => RProxy row
              -> SProxy l
              -> Proxy a
              -> Unit
noConflict _ _ _ = unit

-- | Returns True if there are duplicates of any label with different types
class ConflictingList
  (list :: RowList)
  (result :: Boolean)
  | list -> result

instance conflictingListNil :: ConflictingList Nil False

instance conflictingListCons ::
  ( ConflictsWith tail label t conflicts
  , ConflictingList tail tailResult
  , Boolean.Or conflicts tailResult result
  ) => ConflictingList (Cons label t tail) result

doesConflict :: ∀ row list.
                RowToList row list
             => ConflictingList list True
             => RProxy row
             -> Unit
doesConflict _ = unit

class ConflictingRow
  (row :: # Type)
  (result :: Boolean)
  | row -> result

instance conflictingRow ::
  ( RowToList row list
  , ConflictingList list result
  ) => ConflictingRow row result

class UnionConflict (fail :: Boolean)

instance unionConflictFail ::
  ( Fail (Text "Tried to take union of conflicting rows")
  ) => UnionConflict True

instance unionConflictSuccess ::
  UnionConflict False

-- | Takes the union of two rows, except it errors if there are
-- | overlapping labels of different types, and it removes the
-- | redundant entries.
class SafeUnion
  (left :: # Type)
  (right :: # Type)
  (union :: # Type)
  | left right -> union

instance safeUnion ::
  ( UnionConflict conflicting
  , Row.Union left right union
  , RowToList union list
  , ConflictingList list conflicting
  , Row.Nub union nubbed
  ) => SafeUnion left right nubbed

rowUnion :: ∀ left right union.
            SafeUnion left right union
         => RProxy left
         -> RProxy right
         -> RProxy union
         -> Unit
rowUnion _ _ _ = unit

check = rowUnion (RProxy :: _ (a :: Int, b :: String))
                 (RProxy :: _ (b :: String))
                 (RProxy :: _ _)


polish baby station view

polish baby station view

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

view :: forall ps. Props ps -> State -> Html Action
view props state = H.div [ A.className "jumbotron" ]
       [ if state.isAvailable
         then viewOnline props state
         else viewOffline props state
       ]

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

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

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

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

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

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

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

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

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

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

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

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

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

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


Use Node.FS, resolves #27

Use Node.FS, resolves #27

module Control.Monad.Eff.FS where

import Control.Monad.Eff
import Data.Date
import Data.Either
import Global
import Node.Encoding
import Node.FS
import Node.FS.Stats
import Node.FS.Sync (readTextFile, writeTextFile, stat)
import Node.Path

readFile :: forall eff r. FilePath -> (String -> r) -> (Error -> r) -> Eff (fs :: FS | eff) r
readFile path f g = either g f <$> readTextFile UTF8 path

writeFile :: forall eff r. FilePath -> String -> (Unit -> r) -> (Error -> r) -> Eff (fs :: FS | eff) r
writeFile path content f g = either g f <$> writeTextFile UTF8 path content

doesFileExist :: forall eff r. FilePath -> (Boolean -> r) -> (Error -> r) -> Eff (fs :: FS | eff) r
doesFileExist path f g = either (f <<< const false) (f <<< const true) <$> stat path

getModificationTime :: forall eff r. FilePath -> (Number -> r) -> (Error -> r) -> Eff (fs :: FS | eff) r
getModificationTime path f g = either g (f <<< toEpochMilliseconds <<< modifiedTime) <$> stat path

foreign import mkdirp
  "function mkdirp(filename) {\
  \  return function(k) {\
  \    return function(fail) {\
  \      return function() {\
  \        try {\
  \          return k(require('mkdirp').sync(filename));\
  \        } catch(err) {\
  \          return fail(err);\
  \        }\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff r. FilePath -> (Unit -> r) -> (Error -> r) -> Eff (fs :: FS | eff) r

module Control.Monad.Eff.FS where

import Control.Monad.Eff
import Global
import Node.FS

foreign import readFile
  "function readFile(filename) {\
  \  return function(k) {\
  \    return function(fail) {\
  \      return function() {\
  \        try {\
  \          return k(require('fs').readFileSync(filename, 'utf8'));\
  \        } catch(err) {\
  \          return fail(err);\
  \        }\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff r. String -> (String -> r) -> (Error -> r) -> Eff (fs :: FS | eff) r

foreign import writeFile
  "function writeFile(filename) {\
  \  return function(data) {\
  \    return function(k) {\
  \      return function(fail) {\
  \        return function() {\
  \          try {\
  \            return k(require('fs').writeFileSync(filename, data, 'utf8'));\
  \          } catch(err) {\
  \            return fail(err);\
  \          }\
  \        };\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff r. String -> String -> (Unit -> r) -> (Error -> r) -> Eff (fs :: FS | eff) r

foreign import doesFileExist
  "function doesFileExist(filename) {\
  \  return function(k) {\
  \    return function(fail) {\
  \      return function() {\
  \        try {\
  \          return k(require('fs').existsSync(filename));\
  \        } catch(err) {\
  \          return fail(err);\
  \        }\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff r. String -> (Boolean -> r) -> (Error -> r) -> Eff (fs :: FS | eff) r

foreign import getModificationTime
  "function getModificationTime(filename) {\
  \  return function(k) {\
  \    return function(fail) {\
  \      return function() {\
  \        try {\
  \          var stat = require('fs').statSync(filename);\
  \          return k(stat.mtime.getTime());\
  \        } catch(err) {\
  \          return fail(err);\
  \        }\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff r. String -> (Number -> r) -> (Error -> r) -> Eff (fs :: FS | eff) r

foreign import mkdirp
  "function mkdirp(filename) {\
  \  return function(k) {\
  \    return function(fail) {\
  \      return function() {\
  \        try {\
  \          return k(require('mkdirp').sync(filename));\
  \        } catch(err) {\
  \          return fail(err);\
  \        }\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff r. String -> (Unit -> r) -> (Error -> r) -> Eff (fs :: FS | eff) r


textAlign

textAlign

module Graphics.Canvas.Free
  ( Graphics()
  , GraphicsF()

  , setLineWidth
  , setFillStyle
  , setStrokeStyle
  , setShadowColor
  , setShadowBlur
  , setShadowOffsetX
  , setShadowOffsetY
  , setLineCap
  , setComposite
  , setAlpha

  , beginPath
  , stroke
  , fill
  , clip
  , lineTo
  , moveTo
  , closePath

  , arc
  , rect
  , clearRect

  , scale
  , rotate
  , translate
  , transform

  , textAlign
  , setTextAlign
  , setFont
  , fillText
  , strokeText
  , measureText

  , save
  , restore

  , getImageData
  , putImageData
  , putImageDataFull
  , createImageData
  , createImageDataCopy

  , runGraphics
  ) where

import Control.Monad.Eff
import Control.Monad.Free
import Data.Coyoneda

import qualified Graphics.Canvas as C

data GraphicsF more
  = SetLineWidth         Number      more
  | SetFillStyle         String      more
  | SetStrokeStyle       String      more
  | SetShadowColor       String      more
  | SetShadowBlur        Number      more
  | SetShadowOffsetX     Number      more
  | SetShadowOffsetY     Number      more
  | SetLineCap           C.LineCap   more
  | SetComposite         C.Composite more
  | SetAlpha             Number      more
  | BeginPath            more
  | Stroke               more
  | Fill                 more
  | Clip                 more
  | LineTo               Number      Number      more
  | MoveTo               Number      Number      more
  | ClosePath            more
  | Arc                  C.Arc       more
  | Rect                 C.Rectangle more
  | ClearRect            C.Rectangle more
  | Scale                Number      Number      more
  | Rotate               Number      more
  | Translate            Number      Number      more
  | Transform            C.Transform more
  | TextAlign            (C.TextAlign -> more)
  | SetTextAlign         C.TextAlign more
  | SetFont              String      more
  | FillText             String      Number      Number    more
  | StrokeText           String      Number      Number    more
  | MeasureText          String      (C.TextMetrics -> more)
  | Save                 more
  | Restore              more
  | GetImageData         Number      Number      Number    Number   (C.ImageData -> more)
  | PutImageData         C.ImageData Number      Number    more
  | PutImageDataFull     C.ImageData Number      Number    Number   Number  Number  Number  more
  | CreateImageData      Number      Number      more
  | CreateImageDataCopy  C.ImageData (C.ImageData -> more)

type Graphics a = FreeC GraphicsF a

setLineWidth :: Number -> Graphics Unit
setLineWidth w = liftFC $ SetLineWidth w unit

setFillStyle :: String -> Graphics Unit
setFillStyle s = liftFC $ SetFillStyle s unit

setStrokeStyle :: String -> Graphics Unit
setStrokeStyle s = liftFC $ SetStrokeStyle s unit

setShadowColor :: String -> Graphics Unit
setShadowColor c = liftFC $ SetShadowColor c unit

setShadowBlur :: Number -> Graphics Unit
setShadowBlur n = liftFC $ SetShadowBlur n unit

setShadowOffsetX :: Number -> Graphics Unit
setShadowOffsetX n = liftFC $ SetShadowOffsetX n unit

setShadowOffsetY :: Number -> Graphics Unit
setShadowOffsetY n = liftFC $ SetShadowOffsetY n unit

setLineCap :: C.LineCap -> Graphics Unit
setLineCap lc = liftFC $ SetLineCap lc unit

setComposite :: C.Composite -> Graphics Unit
setComposite c = liftFC $ SetComposite c unit

setAlpha :: Number -> Graphics Unit
setAlpha a = liftFC $ SetAlpha a unit

beginPath :: Graphics Unit
beginPath = liftFC $ BeginPath unit

stroke :: Graphics Unit
stroke = liftFC $ Stroke unit

fill :: Graphics Unit
fill = liftFC $ Fill unit

clip :: Graphics Unit
clip = liftFC $ Clip unit

lineTo :: Number -> Number -> Graphics Unit
lineTo x y = liftFC $ LineTo x y unit

moveTo :: Number -> Number -> Graphics Unit
moveTo x y = liftFC $ MoveTo x y unit

closePath :: Graphics Unit
closePath = liftFC $ ClosePath unit

arc :: C.Arc -> Graphics Unit
arc a = liftFC $ Arc a unit

rect :: C.Rectangle -> Graphics Unit
rect r = liftFC $ Rect r unit

clearRect :: C.Rectangle -> Graphics Unit
clearRect r = liftFC $ ClearRect r unit

scale :: Number -> Number -> Graphics Unit
scale sx sy = liftFC $ Scale sx sy unit

rotate :: Number -> Graphics Unit
rotate th = liftFC $ Rotate th unit

translate :: Number -> Number -> Graphics Unit
translate tx ty = liftFC $ Translate tx ty unit

transform :: C.Transform -> Graphics Unit
transform tx = liftFC $ Transform tx unit

textAlign :: Graphics C.TextAlign
textAlign = liftFC $ TextAlign id

setTextAlign :: C.TextAlign -> Graphics Unit
setTextAlign ta = liftFC $ SetTextAlign ta unit

setFont :: String -> Graphics Unit
setFont f = liftFC $ SetFont f unit

fillText :: String -> Number -> Number -> Graphics Unit
fillText s x y = liftFC $ FillText s x y unit

strokeText :: String -> Number -> Number -> Graphics Unit
strokeText s x y = liftFC $ StrokeText s x y unit

measureText :: String -> Graphics C.TextMetrics
measureText s = liftFC $ MeasureText s id

save :: Graphics Unit
save = liftFC $ Save unit

restore :: Graphics Unit
restore = liftFC $ Restore unit

getImageData :: Number -> Number -> Number -> Number -> Graphics C.ImageData
getImageData x y w h = liftFC $ GetImageData x y w h id

putImageData :: C.ImageData -> Number -> Number -> Graphics Unit
putImageData d x y = liftFC $ PutImageData d x y unit

putImageDataFull :: C.ImageData -> Number -> Number -> Number -> Number -> Number -> Number -> Graphics Unit
putImageDataFull d x y dx dy dw dh = liftFC $ PutImageDataFull d x y dx dy dw dh unit

createImageData :: Number -> Number -> Graphics Unit
createImageData w h = liftFC $ CreateImageData w h unit

createImageDataCopy :: C.ImageData -> Graphics C.ImageData
createImageDataCopy d = liftFC $ CreateImageDataCopy d id

runGraphics :: forall a eff. C.Context2D -> Graphics a -> Eff (canvas :: C.Canvas | eff) a
runGraphics ctx = runFreeCM interp
  where
  interp :: forall eff. Natural GraphicsF (Eff (canvas :: C.Canvas | eff))
  interp (SetLineWidth w a)                     = const a <$> C.setLineWidth w ctx
  interp (SetFillStyle s a)                     = const a <$> C.setFillStyle s ctx
  interp (SetStrokeStyle s a)                   = const a <$> C.setStrokeStyle s ctx
  interp (SetShadowColor c a)                   = const a <$> C.setShadowColor c ctx
  interp (SetShadowBlur n a)                    = const a <$> C.setShadowBlur n ctx
  interp (SetShadowOffsetX n a)                 = const a <$> C.setShadowOffsetX n ctx
  interp (SetShadowOffsetY n a)                 = const a <$> C.setShadowOffsetY n ctx
  interp (SetLineCap lc a)                      = const a <$> C.setLineCap lc ctx
  interp (SetComposite c a)                     = const a <$> C.setGlobalCompositeOperation ctx c
  interp (SetAlpha s a)                         = const a <$> C.setGlobalAlpha ctx s
  interp (BeginPath a)                          = const a <$> C.beginPath ctx
  interp (Stroke a)                             = const a <$> C.stroke ctx
  interp (Fill a)                               = const a <$> C.fill ctx
  interp (Clip a)                               = const a <$> C.clip ctx
  interp (LineTo x y a)                         = const a <$> C.lineTo ctx x y
  interp (MoveTo x y a)                         = const a <$> C.moveTo ctx x y
  interp (ClosePath a)                          = const a <$> C.closePath ctx
  interp (Arc arc a)                            = const a <$> C.arc ctx arc
  interp (Rect r a)                             = const a <$> C.rect ctx r
  interp (ClearRect r a)                        = const a <$> C.clearRect ctx r
  interp (Scale sx sy a)                        = const a <$> C.scale { scaleX: sx, scaleY: sy } ctx
  interp (Rotate th a)                          = const a <$> C.rotate th ctx
  interp (Translate tx ty a)                    = const a <$> C.translate { translateX: tx, translateY: ty } ctx
  interp (Transform tx a)                       = const a <$> C.transform tx ctx
  interp (TextAlign k)                          = k <$> C.textAlign ctx
  interp (SetTextAlign ta a)                    = const a <$> C.setTextAlign ctx ta
  interp (SetFont f a)                          = const a <$> C.setFont f ctx
  interp (FillText s x y a)                     = const a <$> C.fillText ctx s x y
  interp (StrokeText s x y a)                   = const a <$> C.strokeText ctx s x y
  interp (MeasureText s k)                      = k <$> C.measureText ctx s
  interp (Save a)                               = const a <$> C.save ctx
  interp (Restore a)                            = const a <$> C.restore ctx
  interp (GetImageData x y w h k)               = k <$> C.getImageData ctx x y w h
  interp (PutImageData d x y a)                 = const a <$> C.putImageData ctx d x y
  interp (PutImageDataFull d x y dx dy dw dh a) = const a <$> C.putImageDataFull ctx d x y dx dy dw dh
  interp (CreateImageData w h a)                = const a <$> C.createImageData ctx w h
  interp (CreateImageDataCopy d k)              = k <$> C.createImageDataCopy ctx d

module Graphics.Canvas.Free
  ( Graphics()
  , GraphicsF()

  , setLineWidth
  , setFillStyle
  , setStrokeStyle
  , setShadowColor
  , setShadowBlur
  , setShadowOffsetX
  , setShadowOffsetY
  , setLineCap
  , setComposite
  , setAlpha

  , beginPath
  , stroke
  , fill
  , clip
  , lineTo
  , moveTo
  , closePath

  , arc
  , rect
  , clearRect

  , scale
  , rotate
  , translate
  , transform

  , setTextAlign
  , setFont
  , fillText
  , strokeText
  , measureText

  , save
  , restore

  , getImageData
  , putImageData
  , putImageDataFull
  , createImageData
  , createImageDataCopy

  , runGraphics
  ) where

import Control.Monad.Eff
import Control.Monad.Free
import Data.Coyoneda

import qualified Graphics.Canvas as C

data GraphicsF more
  = SetLineWidth         Number      more
  | SetFillStyle         String      more
  | SetStrokeStyle       String      more
  | SetShadowColor       String      more
  | SetShadowBlur        Number      more
  | SetShadowOffsetX     Number      more
  | SetShadowOffsetY     Number      more
  | SetLineCap           C.LineCap   more
  | SetComposite         C.Composite more
  | SetAlpha             Number      more
  | BeginPath            more
  | Stroke               more
  | Fill                 more
  | Clip                 more
  | LineTo               Number      Number      more
  | MoveTo               Number      Number      more
  | ClosePath            more
  | Arc                  C.Arc       more
  | Rect                 C.Rectangle more
  | ClearRect            C.Rectangle more
  | Scale                Number      Number      more
  | Rotate               Number      more
  | Translate            Number      Number      more
  | Transform            C.Transform more
  | SetTextAlign         C.TextAlign more
  | SetFont              String      more
  | FillText             String      Number      Number    more
  | StrokeText           String      Number      Number    more
  | MeasureText          String      (C.TextMetrics -> more)
  | Save                 more
  | Restore              more
  | GetImageData         Number      Number      Number    Number   (C.ImageData -> more)
  | PutImageData         C.ImageData Number      Number    more
  | PutImageDataFull     C.ImageData Number      Number    Number   Number  Number  Number  more
  | CreateImageData      Number      Number      more
  | CreateImageDataCopy  C.ImageData (C.ImageData -> more)

type Graphics a = FreeC GraphicsF a

setLineWidth :: Number -> Graphics Unit
setLineWidth w = liftFC $ SetLineWidth w unit

setFillStyle :: String -> Graphics Unit
setFillStyle s = liftFC $ SetFillStyle s unit

setStrokeStyle :: String -> Graphics Unit
setStrokeStyle s = liftFC $ SetStrokeStyle s unit

setShadowColor :: String -> Graphics Unit
setShadowColor c = liftFC $ SetShadowColor c unit

setShadowBlur :: Number -> Graphics Unit
setShadowBlur n = liftFC $ SetShadowBlur n unit

setShadowOffsetX :: Number -> Graphics Unit
setShadowOffsetX n = liftFC $ SetShadowOffsetX n unit

setShadowOffsetY :: Number -> Graphics Unit
setShadowOffsetY n = liftFC $ SetShadowOffsetY n unit

setLineCap :: C.LineCap -> Graphics Unit
setLineCap lc = liftFC $ SetLineCap lc unit

setComposite :: C.Composite -> Graphics Unit
setComposite c = liftFC $ SetComposite c unit

setAlpha :: Number -> Graphics Unit
setAlpha a = liftFC $ SetAlpha a unit

beginPath :: Graphics Unit
beginPath = liftFC $ BeginPath unit

stroke :: Graphics Unit
stroke = liftFC $ Stroke unit

fill :: Graphics Unit
fill = liftFC $ Fill unit

clip :: Graphics Unit
clip = liftFC $ Clip unit

lineTo :: Number -> Number -> Graphics Unit
lineTo x y = liftFC $ LineTo x y unit

moveTo :: Number -> Number -> Graphics Unit
moveTo x y = liftFC $ MoveTo x y unit

closePath :: Graphics Unit
closePath = liftFC $ ClosePath unit

arc :: C.Arc -> Graphics Unit
arc a = liftFC $ Arc a unit

rect :: C.Rectangle -> Graphics Unit
rect r = liftFC $ Rect r unit

clearRect :: C.Rectangle -> Graphics Unit
clearRect r = liftFC $ ClearRect r unit

scale :: Number -> Number -> Graphics Unit
scale sx sy = liftFC $ Scale sx sy unit

rotate :: Number -> Graphics Unit
rotate th = liftFC $ Rotate th unit

translate :: Number -> Number -> Graphics Unit
translate tx ty = liftFC $ Translate tx ty unit

transform :: C.Transform -> Graphics Unit
transform tx = liftFC $ Transform tx unit

setTextAlign :: C.TextAlign -> Graphics Unit
setTextAlign ta = liftFC $ SetTextAlign ta unit

setFont :: String -> Graphics Unit
setFont f = liftFC $ SetFont f unit

fillText :: String -> Number -> Number -> Graphics Unit
fillText s x y = liftFC $ FillText s x y unit

strokeText :: String -> Number -> Number -> Graphics Unit
strokeText s x y = liftFC $ StrokeText s x y unit

measureText :: String -> Graphics C.TextMetrics
measureText s = liftFC $ MeasureText s id

save :: Graphics Unit
save = liftFC $ Save unit

restore :: Graphics Unit
restore = liftFC $ Restore unit

getImageData :: Number -> Number -> Number -> Number -> Graphics C.ImageData
getImageData x y w h = liftFC $ GetImageData x y w h id

putImageData :: C.ImageData -> Number -> Number -> Graphics Unit
putImageData d x y = liftFC $ PutImageData d x y unit

putImageDataFull :: C.ImageData -> Number -> Number -> Number -> Number -> Number -> Number -> Graphics Unit
putImageDataFull d x y dx dy dw dh = liftFC $ PutImageDataFull d x y dx dy dw dh unit

createImageData :: Number -> Number -> Graphics Unit
createImageData w h = liftFC $ CreateImageData w h unit

createImageDataCopy :: C.ImageData -> Graphics C.ImageData
createImageDataCopy d = liftFC $ CreateImageDataCopy d id

runGraphics :: forall a eff. C.Context2D -> Graphics a -> Eff (canvas :: C.Canvas | eff) a
runGraphics ctx = runFreeCM interp
  where
  interp :: forall eff. Natural GraphicsF (Eff (canvas :: C.Canvas | eff))
  interp (SetLineWidth w a)                     = const a <$> C.setLineWidth w ctx
  interp (SetFillStyle s a)                     = const a <$> C.setFillStyle s ctx
  interp (SetStrokeStyle s a)                   = const a <$> C.setStrokeStyle s ctx
  interp (SetShadowColor c a)                   = const a <$> C.setShadowColor c ctx
  interp (SetShadowBlur n a)                    = const a <$> C.setShadowBlur n ctx
  interp (SetShadowOffsetX n a)                 = const a <$> C.setShadowOffsetX n ctx
  interp (SetShadowOffsetY n a)                 = const a <$> C.setShadowOffsetY n ctx
  interp (SetLineCap lc a)                      = const a <$> C.setLineCap lc ctx
  interp (SetComposite c a)                     = const a <$> C.setGlobalCompositeOperation ctx c
  interp (SetAlpha s a)                         = const a <$> C.setGlobalAlpha ctx s
  interp (BeginPath a)                          = const a <$> C.beginPath ctx
  interp (Stroke a)                             = const a <$> C.stroke ctx
  interp (Fill a)                               = const a <$> C.fill ctx
  interp (Clip a)                               = const a <$> C.clip ctx
  interp (LineTo x y a)                         = const a <$> C.lineTo ctx x y
  interp (MoveTo x y a)                         = const a <$> C.moveTo ctx x y
  interp (ClosePath a)                          = const a <$> C.closePath ctx
  interp (Arc arc a)                            = const a <$> C.arc ctx arc
  interp (Rect r a)                             = const a <$> C.rect ctx r
  interp (ClearRect r a)                        = const a <$> C.clearRect ctx r
  interp (Scale sx sy a)                        = const a <$> C.scale { scaleX: sx, scaleY: sy } ctx
  interp (Rotate th a)                          = const a <$> C.rotate th ctx
  interp (Translate tx ty a)                    = const a <$> C.translate { translateX: tx, translateY: ty } ctx
  interp (Transform tx a)                       = const a <$> C.transform tx ctx
  interp (SetTextAlign ta a)                    = const a <$> C.setTextAlign ctx ta
  interp (SetFont f a)                          = const a <$> C.setFont f ctx
  interp (FillText s x y a)                     = const a <$> C.fillText ctx s x y
  interp (StrokeText s x y a)                   = const a <$> C.strokeText ctx s x y
  interp (MeasureText s k)                      = k <$> C.measureText ctx s
  interp (Save a)                               = const a <$> C.save ctx
  interp (Restore a)                            = const a <$> C.restore ctx
  interp (GetImageData x y w h k)               = k <$> C.getImageData ctx x y w h
  interp (PutImageData d x y a)                 = const a <$> C.putImageData ctx d x y
  interp (PutImageDataFull d x y dx dy dw dh a) = const a <$> C.putImageDataFull ctx d x y dx dy dw dh
  interp (CreateImageData w h a)                = const a <$> C.createImageData ctx w h
  interp (CreateImageDataCopy d k)              = k <$> C.createImageDataCopy ctx d


Don't modify the conn when requiring authentication

module Hyper.Node.BasicAuth where

import Data.StrMap as StrMap
import Node.Buffer as Buffer
import Control.Applicative (pure)
import Control.Bind (bind)
import Control.Monad (class Monad, (>>=))
import Control.Monad.Eff.Class (liftEff, class MonadEff)
import Data.Function ((#))
import Data.Functor (map, (<$>))
import Data.Maybe (Maybe(Nothing, Just))
import Data.StrMap (StrMap)
import Data.String (Pattern(Pattern), split)
import Data.Tuple (Tuple(Tuple))
import Data.Unit (Unit)
import Hyper.Authentication (setAuthentication)
import Hyper.Core (class ResponseWriter, ResponseEnded, StatusLineOpen, Conn, Middleware, closeHeaders, writeHeader, writeStatus)
import Hyper.Response (respond)
import Node.Buffer (BUFFER)
import Node.Encoding (Encoding(ASCII, Base64))

withAuthentication
  :: forall m e req res c t.
     MonadEff (buffer :: BUFFER | e) m =>
     (Tuple String String -> m (Maybe t))
  -> Middleware
     m
     (Conn { headers :: StrMap String | req } res { authentication :: Unit | c })
     (Conn { headers :: StrMap String | req } res { authentication :: Maybe t | c })
withAuthentication mapper conn = do
  auth <- getAuth
  pure (setAuthentication auth conn)
  where
    decodeBase64 encoded =
      liftEff (Buffer.fromString encoded Base64 >>= Buffer.toString ASCII)
    splitPair s =
      case split (Pattern ":") s of
        [username, password] -> Just (Tuple username password)
        _ -> Nothing
    getAuth =
      case StrMap.lookup "authorization" conn.request.headers of
        Nothing -> pure Nothing
        Just header -> do
          case split (Pattern " ") header of
            ["Basic", encoded] -> do
              decoded <- splitPair <$> decodeBase64 encoded
              case decoded of
                Just auth -> mapper auth
                Nothing -> pure Nothing
            parts -> pure Nothing

authenticated
  :: forall m req res c rw t.
     (Monad m, ResponseWriter rw m) =>
     Middleware
      m
      (Conn
       req
       { writer :: rw StatusLineOpen | res }
       { authentication :: t | c })
      (Conn
       req
       { writer :: rw ResponseEnded | res }
       { authentication :: t | c })
  -> Middleware
    m
    (Conn
      req
      { writer :: rw StatusLineOpen | res }
      { authentication :: Maybe t | c })
    (Conn
      req
      { writer :: rw ResponseEnded | res }
      { authentication :: Maybe t | c })
authenticated mw conn =
  case conn.components.authentication of
    Nothing ->
      writeStatus (Tuple 401 "Unauthorized") conn
      >>= writeHeader (Tuple "WWW-Authenticate" "Basic realm=\"Hyper Authentication Example\"")
      >>= closeHeaders
      >>= respond "Please authenticate."
    Just auth ->
      setAuthentication auth conn
      # mw
      # map (setAuthentication (Just auth))

module Hyper.Node.BasicAuth where

import Data.StrMap as StrMap
import Node.Buffer as Buffer
import Control.Applicative (pure)
import Control.Bind (bind)
import Control.Monad (class Monad, (>>=))
import Control.Monad.Eff.Class (liftEff, class MonadEff)
import Data.Function ((#))
import Data.Functor (map, (<$>))
import Data.Maybe (Maybe(Nothing, Just))
import Data.StrMap (StrMap)
import Data.String (Pattern(Pattern), split)
import Data.Tuple (Tuple(Tuple))
import Data.Unit (Unit, unit)
import Hyper.Authentication (setAuthentication)
import Hyper.Core (class ResponseWriter, ResponseEnded, StatusLineOpen, Conn, Middleware, closeHeaders, writeHeader, writeStatus)
import Hyper.Response (respond)
import Node.Buffer (BUFFER)
import Node.Encoding (Encoding(ASCII, Base64))

withAuthentication
  :: forall m e req res c t.
     MonadEff (buffer :: BUFFER | e) m =>
     (Tuple String String -> m (Maybe t))
  -> Middleware
     m
     (Conn { headers :: StrMap String | req } res { authentication :: Unit | c })
     (Conn { headers :: StrMap String | req } res { authentication :: Maybe t | c })
withAuthentication mapper conn = do
  auth <- getAuth
  pure (setAuthentication auth conn)
  where
    decodeBase64 encoded =
      liftEff (Buffer.fromString encoded Base64 >>= Buffer.toString ASCII)
    splitPair s =
      case split (Pattern ":") s of
        [username, password] -> Just (Tuple username password)
        _ -> Nothing
    getAuth =
      case StrMap.lookup "authorization" conn.request.headers of
        Nothing -> pure Nothing
        Just header -> do
          case split (Pattern " ") header of
            ["Basic", encoded] -> do
              decoded <- splitPair <$> decodeBase64 encoded
              case decoded of
                Just auth -> mapper auth
                Nothing -> pure Nothing
            parts -> pure Nothing

authenticated
  :: forall m req res c rw t.
     (Monad m, ResponseWriter rw m) =>
     Middleware
      m
      (Conn
       req
       { writer :: rw StatusLineOpen | res }
       { authentication :: t | c })
      (Conn
       req
       { writer :: rw ResponseEnded | res }
       { authentication :: t | c })
  -> Middleware
    m
    (Conn
      req
      { writer :: rw StatusLineOpen | res }
      { authentication :: Maybe t | c })
    (Conn
      req
      { writer :: rw ResponseEnded | res }
      { authentication :: Unit | c })
authenticated mw conn =
  case conn.components.authentication of
    Nothing ->
      writeStatus (Tuple 401 "Unauthorized") (setAuthentication unit conn)
      >>= writeHeader (Tuple "WWW-Authenticate" "Basic realm=\"Hyper Authentication Example\"")
      >>= closeHeaders
      >>= respond "Please authenticate."
    Just auth ->
      setAuthentication auth conn
      # mw
      # map (setAuthentication unit)


Remove dead code

Remove dead code

-- | A part of the `HalogenF` algebra that replicates a `MonadState`-like
-- | interface.
module Halogen.Query.StateF where

import Prelude

-- | The state algebra.
data StateF s a
  = Get (s -> a)
  | Modify (s -> s) a

instance functorStateF :: Functor (StateF s) where
  map f (Get k) = Get (f <<< k)
  map f (Modify g next) = Modify g (f next)

-- | A part of the `HalogenF` algebra that replicates a `MonadState`-like
-- | interface.
module Halogen.Query.StateF
  ( StateF(..)
  , mapState
  , stateN
  ) where

import Prelude

import Control.Monad.State as CMS

-- | The state algebra.
data StateF s a
  = Get (s -> a)
  | Modify (s -> s) a

instance functorStateF :: Functor (StateF s) where
  map f (Get k) = Get (f <<< k)
  map f (Modify g next) = Modify g (f next)

-- | Map over the state value using a function to extract the new state value
-- | from the old state, and a function for modifying the state.
mapState :: forall s t a. (t -> s) -> ((s -> s) -> t -> t) -> StateF s a -> StateF t a
mapState f _ (Get k) = Get (k <<< f)
mapState _ f (Modify g next) = Modify (f g) next

-- | A natural transformation for interpreting the state algebra as some
-- | `MonadState`-supporting monad. Used internally by Halogen.
stateN :: forall s m. (Monad m, CMS.MonadState s m) => StateF s ~> m
stateN (Get k) = CMS.get >>= pure <<< k
stateN (Modify f next) = CMS.modify f $> next


Removed waiter combinator

Removed waiter combinator

module Selenium.Combinators where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Trans (lift)
import Data.Maybe (Maybe(), isJust, maybe)
import Data.Maybe.Unsafe (fromJust)
import Data.Either (Either(..), isRight, either)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Eff.Exception (error, Error())
import Selenium.Monad
import Selenium.Types

-- | Retry computation until it successed but not more then `n` times
retry :: forall e o a. Int -> Selenium e o a -> Selenium e o a
retry n action = do
  res <- attempt action
  case res of
    Left e -> if n > one
              then retry (n - one) action
              else lift $ throwError $ error "To many retries"
    Right r -> pure r

-- | Tries to find element by string checks: css, xpath, id, name and classname
tryFind :: forall e o. String -> Selenium e o Element
tryFind probablyLocator =
  (byCss probablyLocator >>= findExact) <|>
  (byXPath probablyLocator >>= findExact) <|>
  (byId probablyLocator >>= findExact) <|>
  (byName probablyLocator >>= findExact) <|>
  (byClassName probablyLocator >>= findExact)

waitUntilJust :: forall e o a. Selenium e o (Maybe a) -> Int -> Selenium e o a
waitUntilJust check time = do
  wait (checker $ isJust <$> check) time
  fromJust <$> check

-- Tries to evaluate `Selenium` if it returns `false` after 500ms
checker :: forall e o a. Selenium e o Boolean -> Selenium e o Boolean
checker check = do
  res <- check
  if res
    then pure true
    else later 500 $ checker check

getElementByCss :: forall e o. String -> Selenium e o Element
getElementByCss cls =
  byCss cls
    >>= findElement
    >>= maybe (throwError $ error $ "There is no element matching css: " <> cls) pure

checkNotExistsByCss :: forall e o. String -> Selenium e o Unit
checkNotExistsByCss = contra <<< getElementByCss

contra :: forall e o a. Selenium e o a -> Selenium e o Unit
contra check = do
  eR <- attempt check
  either
    (const $ pure unit)
    (const $ throwError $ error "check successed in contra") eR

-- | Repeatedly tries to evaluate check (third arg) for timeout ms (first arg)
-- | finishes when check evaluates to true.
-- | If there is an error during check or it constantly returns `false`
-- | throws error with message (second arg)
await :: forall e o. Int -> Selenium e o Boolean -> Selenium e o Unit
await timeout check = do
  ei <- attempt $ wait (checker check) timeout
  case ei of
    Left _ -> throwError $ error "await has no success"
    Right _ -> pure unit

awaitUrlChanged :: forall e o. String -> Selenium e o Boolean
awaitUrlChanged oldURL = checker $ (oldURL /=) <$> getCurrentUrl

module Selenium.Combinators where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Trans (lift)
import Data.Maybe (Maybe(), isJust, maybe)
import Data.Maybe.Unsafe (fromJust)
import Data.Either (Either(..), isRight, either)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Eff.Exception (error, Error())
import Selenium.Monad
import Selenium.Types

-- | Retry computation until it successed but not more then `n` times
retry :: forall e o a. Int -> Selenium e o a -> Selenium e o a
retry n action = do
  res <- attempt action
  case res of
    Left e -> if n > one
              then retry (n - one) action
              else lift $ throwError $ error "To many retries"
    Right r -> pure r

-- | Tries to find element by string checks: css, xpath, id, name and classname
tryFind :: forall e o. String -> Selenium e o Element
tryFind probablyLocator =
  (byCss probablyLocator >>= findExact) <|>
  (byXPath probablyLocator >>= findExact) <|>
  (byId probablyLocator >>= findExact) <|>
  (byName probablyLocator >>= findExact) <|>
  (byClassName probablyLocator >>= findExact)

waitUntilJust :: forall e o a. Selenium e o (Maybe a) -> Int -> Selenium e o a
waitUntilJust check time = do
  wait (checker $ isJust <$> check) time
  fromJust <$> check

-- Tries to evaluate `Selenium` if it returns `false` after 500ms
checker :: forall e o a. Selenium e o Boolean -> Selenium e o Boolean
checker check = do
  res <- check
  if res
    then pure true
    else later 500 $ checker check

getElementByCss :: forall e o. String -> Selenium e o Element
getElementByCss cls =
  byCss cls
    >>= findElement
    >>= maybe (throwError $ error $ "There is no element matching css: " <> cls) pure

checkNotExistsByCss :: forall e o. String -> Selenium e o Unit
checkNotExistsByCss = contra <<< getElementByCss

contra :: forall e o a. Selenium e o a -> Selenium e o Unit
contra check = do
  eR <- attempt check
  either
    (const $ pure unit)
    (const $ throwError $ error "check successed in contra") eR

-- | takes value and repeatedly tries to evaluate it for timeout of ms (second arg)
-- | if it evaluates w/o error returns its value
-- | else throws error
waiter :: forall e o a. Selenium e o a -> Int -> Selenium e o a
waiter getter timeout = do
  wait (checker $ (isRight <$> attempt getter)) timeout
  getter

waitExistentCss :: forall e o. String -> Int -> Selenium e o Element
waitExistentCss css timeout =
  waiter (getElementByCss css) timeout

waitNotExistentCss :: forall e o. String -> Int -> Selenium e o Unit
waitNotExistentCss css timeout =
  waiter (checkNotExistsByCss css) timeout

-- | Repeatedly tries to evaluate check (third arg) for timeout ms (first arg)
-- | finishes when check evaluates to true.
-- | If there is an error during check or it constantly returns `false`
-- | throws error with message (second arg)
await :: forall e o. Int -> Selenium e o Boolean -> Selenium e o Unit
await timeout check = do
  ei <- attempt $ wait (checker check) timeout
  case ei of
    Left _ -> throwError $ error "await has no success"
    Right _ -> pure unit

awaitUrlChanged :: forall e o. String -> Selenium e o Boolean
awaitUrlChanged oldURL = checker $ (oldURL /=) <$> getCurrentUrl