Add export for 'onNewWindow'

Add export for 'onNewWindow'

module Electron.BrowserWindow
  ( BrowserWindowOption(..)
  , WebPreference(..)
  , BrowserWindowOptions(..)
  , BrowserWindow()
  , newBrowserWindow
  , onClose
  , loadURL
  , WebContents(..)
  , webContents
  , openDevTools
  , DevToolOption(..)
  , DevToolOptions(..)
  , send
  , onDidFinishLoad
  , onNewWindow
  ) where

import Prelude

import Control.Monad.Eff

import Data.Argonaut.Core (Json())
import Data.Generic

import Electron
import Electron.Options
import Electron.Event

data BrowserWindowOption
  = Width Int
  | Height Int
  | WebPreferences (Array WebPreference)

type BrowserWindowOptions = Array BrowserWindowOption

data WebPreference
  = ZoomFactor Number
  | AllowDisplayingInsecureContent Boolean
  | AllowRunningInsecureContent Boolean
  | OverlayScrollbars Boolean

derive instance genericBrowserWindowOption :: Generic BrowserWindowOption

derive instance genericWebPreference :: Generic WebPreference

foreign import data BrowserWindow :: *

newBrowserWindow :: forall eff
   . BrowserWindowOptions
  -> Eff (electron :: ELECTRON | eff) BrowserWindow
newBrowserWindow = encodeOptions >>> newBrowserWindowImpl

foreign import newBrowserWindowImpl :: forall eff
   . Json
  -> Eff (electron :: ELECTRON | eff) BrowserWindow

foreign import loadURL :: forall eff
   . BrowserWindow
  -> String
  -> Eff (electron :: ELECTRON | eff) Unit

foreign import onClose :: forall eff
   . BrowserWindow
  -> Eff (electron :: ELECTRON | eff) Unit
  -> Eff (electron :: ELECTRON | eff) Unit

foreign import data WebContents :: *

foreign import webContents :: forall eff
   . BrowserWindow
  -> Eff (electron :: ELECTRON | eff) WebContents

-- | Opens the devtools.
-- |
-- | [Official Electron documentation](http://electron.atom.io/docs/all/#webcontents-opendevtools-options)
openDevTools :: forall eff
   . WebContents
  -> DevToolOptions
  -> Eff (electron :: ELECTRON | eff) Unit
openDevTools wc = encodeOptions >>> openDevToolsImpl wc

foreign import openDevToolsImpl :: forall eff
   . WebContents
  -> Json
  -> Eff (electron :: ELECTRON | eff) Unit

data DevToolOption
  = Detach Boolean

type DevToolOptions = Array DevToolOption

derive instance genericDevToolOption :: Generic DevToolOption

foreign import send :: forall a eff
   . WebContents
  -> String
  -> a
  -> Eff (electron :: ELECTRON | eff) Unit

foreign import onDidFinishLoad :: forall eff
   . WebContents
  -> Eff (electron :: ELECTRON | eff) Unit
  -> Eff (electron :: ELECTRON | eff) Unit

foreign import onNewWindow :: forall eff
   . WebContents
  -> (Event -> String -> Eff (electron :: ELECTRON | eff) Unit)
  -> Eff (electron :: ELECTRON | eff) Unit

module Electron.BrowserWindow
  ( BrowserWindowOption(..)
  , WebPreference(..)
  , BrowserWindowOptions(..)
  , BrowserWindow()
  , newBrowserWindow
  , onClose
  , loadURL
  , WebContents(..)
  , webContents
  , openDevTools
  , DevToolOption(..)
  , DevToolOptions(..)
  , send
  , onDidFinishLoad
  ) where

import Prelude

import Control.Monad.Eff

import Data.Argonaut.Core (Json())
import Data.Generic

import Electron
import Electron.Options
import Electron.Event

data BrowserWindowOption
  = Width Int
  | Height Int
  | WebPreferences (Array WebPreference)

type BrowserWindowOptions = Array BrowserWindowOption

data WebPreference
  = ZoomFactor Number
  | AllowDisplayingInsecureContent Boolean
  | AllowRunningInsecureContent Boolean
  | OverlayScrollbars Boolean

derive instance genericBrowserWindowOption :: Generic BrowserWindowOption

derive instance genericWebPreference :: Generic WebPreference

foreign import data BrowserWindow :: *

newBrowserWindow :: forall eff
   . BrowserWindowOptions
  -> Eff (electron :: ELECTRON | eff) BrowserWindow
newBrowserWindow = encodeOptions >>> newBrowserWindowImpl

foreign import newBrowserWindowImpl :: forall eff
   . Json
  -> Eff (electron :: ELECTRON | eff) BrowserWindow

foreign import loadURL :: forall eff
   . BrowserWindow
  -> String
  -> Eff (electron :: ELECTRON | eff) Unit

foreign import onClose :: forall eff
   . BrowserWindow
  -> Eff (electron :: ELECTRON | eff) Unit
  -> Eff (electron :: ELECTRON | eff) Unit

foreign import data WebContents :: *

foreign import webContents :: forall eff
   . BrowserWindow
  -> Eff (electron :: ELECTRON | eff) WebContents

-- | Opens the devtools.
-- |
-- | [Official Electron documentation](http://electron.atom.io/docs/all/#webcontents-opendevtools-options)
openDevTools :: forall eff
   . WebContents
  -> DevToolOptions
  -> Eff (electron :: ELECTRON | eff) Unit
openDevTools wc = encodeOptions >>> openDevToolsImpl wc

foreign import openDevToolsImpl :: forall eff
   . WebContents
  -> Json
  -> Eff (electron :: ELECTRON | eff) Unit

data DevToolOption
  = Detach Boolean

type DevToolOptions = Array DevToolOption

derive instance genericDevToolOption :: Generic DevToolOption

foreign import send :: forall a eff
   . WebContents
  -> String
  -> a
  -> Eff (electron :: ELECTRON | eff) Unit

foreign import onDidFinishLoad :: forall eff
   . WebContents
  -> Eff (electron :: ELECTRON | eff) Unit
  -> Eff (electron :: ELECTRON | eff) Unit

foreign import onNewWindow :: forall eff
   . WebContents
  -> (Event -> String -> Eff (electron :: ELECTRON | eff) Unit)
  -> Eff (electron :: ELECTRON | eff) Unit


Added AJAX request

Added AJAX request

module Flag.App (Event, Country(..), init, foldp, view) where

import Data.Array (length, uncons, head, take)
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_)
import Data.Argonaut (class DecodeJson, decodeJson, Json, (.?))
import Data.Either (Either(..))
import Data.Tuple (Tuple(..))
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Control.Monad.Aff (Aff)
import Network.HTTP.Affjax (AJAX, get)
import Prelude hiding (div)

answers :: Int
answers = 4

type State = { all :: Countries, current :: Array String, correct :: Int, incorrect :: Int }
type Countries = Array Country
data Event = RequestCountries | ReceiveCountries (Tuple Countries (Array String)) | GuessCountry String
newtype Country = Country { name :: String, flag :: String }

derive instance newtypeCountry :: Newtype Country _

instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

instance decodeJsonCountry :: DecodeJson Country where
  decodeJson json = do
    obj <- decodeJson json
    name <- obj .? "name"
    flag <- obj .? "flag"
    pure $ Country { name, flag }

init :: State
init = { all: [], current: [], correct: 0, incorrect: 0 }

decode ∷ ∀ r. { response :: Json | r } → Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch :: forall e. Aff (ajax :: AJAX | e) (Tuple Countries (Array String))
fetch = get "/countries.json" >>= \xs -> case decode xs of
  Left _          -> pure $ Tuple [] []
  Right countries -> pure $ Tuple countries (take answers $ _.name <<< unwrap <$> countries)

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX)
foldp (GuessCountry name) state = case (_ == name) <<< maybe "" (_.name <<< unwrap) $ head state.all of
  true -> noEffects state { correct = state.correct + 1 }
  _    -> noEffects state { incorrect = state.incorrect + 1 }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, current = current }
foldp (RequestCountries) state = {
  state: state { correct = 0, incorrect = 0 },
  effects: [Just <<< ReceiveCountries <$> fetch]
}

view :: State → HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.all)
    div ! className "correct" $ text $ show state.correct
    div ! className "incorrect" $ text $ show state.incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.all) of
    Just { head } -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ state.current $ \name -> li #! onClick (const $ GuessCountry name) $ text name
    Nothing       -> div $ text "..."

module Flag.App (Event, Country(..), init, foldp, view) where

import Data.Array (length, uncons, head)
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Network.HTTP.Affjax (AJAX)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

type State = { all :: Countries, current :: Array String, correct :: Int, incorrect :: Int }
type Countries = Array Country

data Event = RequestCountries | ReceiveCountries (Tuple Countries (Array String)) | GuessCountry String

newtype Country = Country { name :: String, flag :: String }
derive instance newtypeCountry :: Newtype Country _
instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

init :: State
init = { all: [], current: [], correct: 0, incorrect: 0 }

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX)
foldp (GuessCountry name) state = case (_ == name) <<< maybe "" (_.name <<< unwrap) $ head state.all of
  true -> noEffects state { correct = state.correct + 1 }
  _    -> noEffects state { incorrect = state.incorrect + 1 }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, current = current }
foldp (RequestCountries) state = {
  state: state { correct = 0, incorrect = 0 },
  effects: [ do
    pure $ Just(ReceiveCountries $ Tuple
      [Country { name: "Ecuador", flag: "ecuador.svg" }]
      ["Ecuador", "Slovenia", "Aruba", "Indonesia"]
    )
  ]
}

view :: State → HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.all)
    div ! className "correct" $ text $ show state.correct
    div ! className "incorrect" $ text $ show state.incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.all) of
    Just { head } -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ state.current $ \name -> li #! onClick (const $ GuessCountry name) $ text name
    Nothing       -> div $ text "..."


Ace should show 4 lines minimum

Ace should show 4 lines minimum

Otherwise the buttons overlap.

module App.Notebook.Ace (acePostRender, AceSessions()) where

import Global (infinity)
import Input.Notebook (CellResultContent(..), Input(..), cellContent)

import Control.Bind ((>=>))
import Control.Monad (when)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Ref (RefVal(), readRef, modifyRef)

import Data.Date (Now(), now)
import Data.Either (Either(..), either)
import Data.Foldable (for_)
import Data.Maybe (Maybe(..), isNothing, maybe)
import Data.Tuple

import qualified Data.Map as M

import DOM
import Data.DOM.Simple.Element
import Data.DOM.Simple.Types

import Halogen

import Ace
import qualified Ace.Config as AceConfig
import Ace.EditSession (getValue, setMode)
import Ace.Selection (getRange)
import Ace.Types (EditSession(), ACE(), Editor(), TextMode(..))
import qualified Ace.Editor as Editor

import Model.Notebook
import Model.Notebook.Cell (CellId(), string2cellId, _cellId, _content)

import Optic.Core
import Optic.Refractor.Lens

type AceSessions = M.Map CellId EditSession

markdownMode :: TextMode
markdownMode = TextMode "ace/mode/markdown"

sqlMode :: TextMode
sqlMode = TextMode "ace/mode/sql"

plainTextMode :: TextMode
plainTextMode = TextMode "ace/mode/plain_text"

modeByCellTag :: String -> TextMode
modeByCellTag tag = case tag of
  "markdown" -> markdownMode
  "query" -> sqlMode
  _ -> plainTextMode

dataCellId :: String
dataCellId = "data-cell-id"

dataCellType :: String
dataCellType = "data-cell-type"

-- TODO: Put this in purescript-ace and fix parametricity.
foreign import aceSetOption """
  function aceSetOption (s) {
    return function (a) {
      return function (editor) {
        return function () {
          editor.setOption(s, a);
        };
      };
    };
  }
  """ :: forall a eff. String -> a -> Editor -> Eff (ace :: ACE | eff) Unit

initialize :: forall eff. RefVal AceSessions -> HTMLElement ->
              Driver Input (ace :: ACE | eff) ->
              Eff (HalogenEffects (ace :: ACE | eff)) Unit
initialize m b d = do
  AceConfig.set AceConfig.basePath (Config.baseUrl ++ "js/ace")
  els <- getElementsByClassName "ace-container" b
  mr <- readRef m
  for_ els \el -> do
    cellId <- string2cellId <$> getAttribute dataCellId el
    flip (either (const $ pure unit)) cellId \cid -> do
      mode <- modeByCellTag <$> getAttribute dataCellType el
      editor <- Ace.editNode el ace

      aceSetOption "minLines" 4 editor
      aceSetOption "maxLines" infinity editor
      aceSetOption "autoScrollEditorIntoView" true editor

      Editor.setTheme "ace/theme/chrome" editor
      maybe (initialize' mode editor cid) (reinit editor) $ M.lookup cid mr
  where
  initialize' :: _ -> _ -> CellId -> Eff _ Unit
  initialize' mode editor cid = do
    session <- createEditSession "" mode ace
    Editor.focus editor
    modifyRef m (M.insert cid session)
    Editor.onFocus editor do
      d $ WithState (_activeCellId .~ cid)

  reinit :: Editor -> EditSession -> Eff _ Unit
  reinit editor session = do
    Editor.setSession session editor

handleInput :: forall eff. RefVal AceSessions
                        -> Input
                        -> Driver Input (now :: Now, ace :: ACE | eff)
                        -> Eff (HalogenEffects (now :: Now, ace :: ACE | eff)) Unit
handleInput m (RequestCellContent cell) d = do
  m' <- readRef m
  now' <- now
  let cellId = cell ^. _cellId
  let updateCell c = cellContent (Right $ AceContent c) cell
  maybe (return unit) (getValue >=> d <<< ReceiveCellContent <<< updateCell) $
    M.lookup cellId m'
handleInput m (TrashCell cellId) _ = do
  modifyRef m (M.delete cellId)
handleInput _ _ _ = return unit

acePostRender :: forall eff. RefVal AceSessions -> Input ->
                 HTMLElement -> Driver Input (now :: Now, ace :: ACE | eff) -> Eff (HalogenEffects (now :: Now, ace :: ACE | eff)) Unit
acePostRender m i b d = do
  initialize m b d
  handleInput m i d

module App.Notebook.Ace (acePostRender, AceSessions()) where

import Global (infinity)
import Input.Notebook (CellResultContent(..), Input(..), cellContent)

import Control.Bind ((>=>))
import Control.Monad (when)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Ref (RefVal(), readRef, modifyRef)

import Data.Date (Now(), now)
import Data.Either (Either(..), either)
import Data.Foldable (for_)
import Data.Maybe (Maybe(..), isNothing, maybe)
import Data.Tuple

import qualified Data.Map as M

import DOM
import Data.DOM.Simple.Element
import Data.DOM.Simple.Types

import Halogen

import Ace
import qualified Ace.Config as AceConfig
import Ace.EditSession (getValue, setMode)
import Ace.Selection (getRange)
import Ace.Types (EditSession(), ACE(), Editor(), TextMode(..))
import qualified Ace.Editor as Editor

import Model.Notebook
import Model.Notebook.Cell (CellId(), string2cellId, _cellId, _content)

import Optic.Core
import Optic.Refractor.Lens

type AceSessions = M.Map CellId EditSession

markdownMode :: TextMode
markdownMode = TextMode "ace/mode/markdown"

sqlMode :: TextMode
sqlMode = TextMode "ace/mode/sql"

plainTextMode :: TextMode
plainTextMode = TextMode "ace/mode/plain_text"

modeByCellTag :: String -> TextMode
modeByCellTag tag = case tag of
  "markdown" -> markdownMode
  "query" -> sqlMode
  _ -> plainTextMode

dataCellId :: String
dataCellId = "data-cell-id"

dataCellType :: String
dataCellType = "data-cell-type"

-- TODO: Put this in purescript-ace and fix parametricity.
foreign import aceSetOption """
  function aceSetOption (s) {
    return function (a) {
      return function (editor) {
        return function () {
          editor.setOption(s, a);
        };
      };
    };
  }
  """ :: forall a eff. String -> a -> Editor -> Eff (ace :: ACE | eff) Unit

initialize :: forall eff. RefVal AceSessions -> HTMLElement ->
              Driver Input (ace :: ACE | eff) ->
              Eff (HalogenEffects (ace :: ACE | eff)) Unit
initialize m b d = do
  AceConfig.set AceConfig.basePath (Config.baseUrl ++ "js/ace")
  els <- getElementsByClassName "ace-container" b
  mr <- readRef m
  for_ els \el -> do
    cellId <- string2cellId <$> getAttribute dataCellId el
    flip (either (const $ pure unit)) cellId \cid -> do
      mode <- modeByCellTag <$> getAttribute dataCellType el
      editor <- Ace.editNode el ace

      aceSetOption "maxLines" infinity editor
      aceSetOption "autoScrollEditorIntoView" true editor

      Editor.setTheme "ace/theme/chrome" editor
      maybe (initialize' mode editor cid) (reinit editor) $ M.lookup cid mr
  where
  initialize' :: _ -> _ -> CellId -> Eff _ Unit
  initialize' mode editor cid = do
    session <- createEditSession "" mode ace
    Editor.focus editor
    modifyRef m (M.insert cid session)
    Editor.onFocus editor do
      d $ WithState (_activeCellId .~ cid)

  reinit :: Editor -> EditSession -> Eff _ Unit
  reinit editor session = do
    Editor.setSession session editor

handleInput :: forall eff. RefVal AceSessions
                        -> Input
                        -> Driver Input (now :: Now, ace :: ACE | eff)
                        -> Eff (HalogenEffects (now :: Now, ace :: ACE | eff)) Unit
handleInput m (RequestCellContent cell) d = do
  m' <- readRef m
  now' <- now
  let cellId = cell ^. _cellId
  let updateCell c = cellContent (Right $ AceContent c) cell
  maybe (return unit) (getValue >=> d <<< ReceiveCellContent <<< updateCell) $
    M.lookup cellId m'
handleInput m (TrashCell cellId) _ = do
  modifyRef m (M.delete cellId)
handleInput _ _ _ = return unit

acePostRender :: forall eff. RefVal AceSessions -> Input ->
                 HTMLElement -> Driver Input (now :: Now, ace :: ACE | eff) -> Eff (HalogenEffects (now :: Now, ace :: ACE | eff)) Unit
acePostRender m i b d = do
  initialize m b d
  handleInput m i d


Change logo link to /

Change logo link to /

module Config where

uploadUrl :: String
uploadUrl = "/upload"

metadataUrl :: String
metadataUrl = "/metadata/fs/"

dataUrl :: String
dataUrl = "/data/fs/"

notebookUrl :: String
notebookUrl = "/notebook.html"

searchTimeout :: Number
searchTimeout = 500

slamDataHome :: String
slamDataHome = "/"

userEnabled :: Boolean
userEnabled = false

newFolderName :: String
newFolderName = "Untitled Folder"

notebookExtension :: String
notebookExtension = ".slam"

newNotebookName :: String
newNotebookName = "Untitled Notebook" <> notebookExtension

homeHash :: String
homeHash = "#?sort=asc&q=path%3A%2F&salt="

module Config where

uploadUrl :: String
uploadUrl = "/upload"

metadataUrl :: String
metadataUrl = "/metadata/fs/"

dataUrl :: String
dataUrl = "/data/fs/"

notebookUrl :: String
notebookUrl = "/notebook.html"

searchTimeout :: Number
searchTimeout = 500

slamDataHome :: String
slamDataHome = "http://slamdata.com"

userEnabled :: Boolean
userEnabled = false

newFolderName :: String
newFolderName = "Untitled Folder"

notebookExtension :: String
notebookExtension = ".slam"

newNotebookName :: String
newNotebookName = "Untitled Notebook" <> notebookExtension

homeHash :: String
homeHash = "#?sort=asc&q=path%3A%2F&salt="


More parsing

More parsing

-- | A basic wrapper for the `webidl2` library, and some ADT sugar on top.

module WebIDL
  ( NodeView(..)
  , Type(..)
  , parse
  , toView
  , toViewWith
  ) where

import Prelude

import Data.Maybe
import Data.Either
import Data.Generic
import Data.Foreign
import Data.Foreign.Class
import Data.Foreign.NullOrUndefined

import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)

-- | Parse a WebIDL string. This function can throw exceptions.
foreign import parse :: String -> Foreign

newtype Type = Type
  { idlType   :: String
  , sequence  :: Boolean
  , generic   :: Maybe String
  , nullable  :: Boolean
  , array     :: Boolean
  , union     :: Boolean
  }

instance isForeignType :: IsForeign Type where
  read f = do
    idlType   <- readProp "idlType" f
    sequence  <- readProp "sequence" f
    generic   <- runNullOrUndefined <$> readProp "generic" f
    nullable  <- readProp "nullable" f
    array     <- readProp "array" f
    union     <- readProp "union" f
    return $ Type { idlType, sequence, generic, nullable, array, union }

derive instance genericType :: Generic Type

instance showType :: Show Type where
  show = gShow

-- | A node represented as a PureScript data type.
data NodeView node
  = InterfaceNode
    { name        :: String
    , partial     :: Boolean
    , members     :: Array node
    , inheritance :: Maybe String
    }
  | ImplementsNode
    { target      :: String
    , implements  :: String
    }
  | TypeDefNode
  | CallbackNode
  | DictionaryNode
  | ExceptionNode
  | OperationMember
    { name            :: String
    , arguments       :: Array node
    , idlType         :: Type
    , getter          :: Boolean
    , setter          :: Boolean
    , creator         :: Boolean
    , deleter         :: Boolean
    , legacycaller    :: Boolean
    , static          :: Boolean
    , stringifier     :: Boolean
    }
  | ArgumentMember
    { name           :: String
    , idlType        :: Type
    , static         :: Boolean
    , stringifier    :: Boolean
    , inherit        :: Boolean
    , readonly       :: Boolean
    }
  | ConstantMember
  | SerializerMember
  | IteratorMember
  | OtherNode String

derive instance genericNodeView :: (Generic node) => Generic (NodeView node)

instance showNodeView :: (Generic node) => Show (NodeView node) where
  show = gShow

-- | Unwrap the top level of a node.
toView :: Foreign -> NodeView Foreign
toView = toViewWith id

-- | Unwrap the top level of a node.
toViewWith :: forall node. (Foreign -> node) -> Foreign -> NodeView node
toViewWith fromForeign = fromRight <<< readView <<< toForeign
  where
  readView :: Foreign -> F (NodeView node)
  readView f = do
    _type <- readProp "type" f
    case _type of
      "interface" -> do
        name          <- readProp "name" f
        partial       <- readProp "partial" f
        members       <- map fromForeign <$> readProp "members" f
        inheritance   <- runNullOrUndefined <$> readProp "inheritance" f
        return $ InterfaceNode { name, partial, members, inheritance }
      "implements" -> do
        target        <- readProp "target" f
        implements    <- readProp "implements" f
        return $ ImplementsNode { target, implements }
      "typedef" -> do
        return $ TypeDefNode
      "callback" -> do
        return $ CallbackNode
      "dictionary" -> do
        return $ DictionaryNode
      "exception" -> do
        return $ ExceptionNode
      "operation" -> do
        name          <- readProp "name" f
        arguments     <- map fromForeign <$> readProp "arguments" f
        idlType       <- readProp "idlType" f
        getter        <- readProp "getter" f
        setter        <- readProp "setter" f
        creator       <- readProp "creator" f
        deleter       <- readProp "deleter" f
        legacycaller  <- readProp "legacycaller" f
        static        <- readProp "static" f
        stringifier   <- readProp "stringifier" f
        return $ OperationMember { name, arguments, idlType, getter, setter, creator, deleter, legacycaller, static, stringifier }
      "argument" -> do
        name          <- readProp "name" f
        idlType       <- readProp "idlType" f
        static        <- readProp "static" f
        stringifier   <- readProp "stringifier" f
        inherit       <- readProp "inherit" f
        readonly      <- readProp "readonly" f
        return $ ArgumentMember { name, idlType, static, stringifier, inherit, readonly }
      "constant" -> do
        return ConstantMember
      "serializer" -> do
        return SerializerMember
      "iterator" -> do
        return IteratorMember
      _ -> return $ OtherNode _type

  fromRight (Right view) = view
  fromRight (Left err) = unsafeThrow $ "Unable to parse node: " <> show err

-- | A basic wrapper for the `webidl2` library, and some ADT sugar on top.

module WebIDL
  ( NodeView(..)
  , Type(..)
  , parse
  , toView
  , toViewWith
  ) where

import Prelude

import Data.Maybe
import Data.Either
import Data.Generic
import Data.Foreign
import Data.Foreign.Class
import Data.Foreign.NullOrUndefined

import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)

-- | Parse a WebIDL string. This function can throw exceptions.
foreign import parse :: String -> Foreign

newtype Type = Type
  { idlType   :: String
  , sequence  :: Boolean
  , generic   :: Maybe String
  , nullable  :: Boolean
  , array     :: Boolean
  , union     :: Boolean
  }

derive instance genericType :: Generic Type

instance showType :: Show Type where
  show = gShow

-- | A node represented as a PureScript data type.
data NodeView node
  = InterfaceNode
    { name        :: String
    , partial     :: Boolean
    , members     :: Array node
    , inheritance :: Maybe String
    }
  | ImplementsNode
    { target      :: String
    , implements  :: String
    }
  | TypeDefNode
  | CallbackNode
  | DictionaryNode
  | ExceptionNode
  | OperationMember
    { name            :: String
    , arguments       :: Array node
    , idlType         :: Type
    , getter          :: Boolean
    , setter          :: Boolean
    , creator         :: Boolean
    , deleter         :: Boolean
    , legacycaller    :: Boolean
    , static          :: Boolean
    , stringifier     :: Boolean
    }
  | ArgumentMember
    { name           :: String
    , idlType        :: Type
    , static         :: Boolean
    , stringifier    :: Boolean
    , inherit        :: Boolean
    , readonly       :: Boolean
    }
  | ConstantMember
  | SerializerMember
  | IteratorMember
  | OtherNode

derive instance genericNodeView :: (Generic node) => Generic (NodeView node)

instance showNodeView :: (Generic node) => Show (NodeView node) where
  show = gShow

-- | Unwrap the top level of a node.
toView :: Foreign -> NodeView Foreign
toView = toViewWith id

-- | Unwrap the top level of a node.
toViewWith :: forall node. (Foreign -> node) -> Foreign -> NodeView node
toViewWith fromForeign = fromRight <<< readView <<< toForeign
  where
  readView :: Foreign -> F (NodeView node)
  readView f = do
    _type <- readProp "type" f
    case _type of
      "interface" -> readInterfaceNode f
      _ -> pure OtherNode

  readInterfaceNode :: Foreign -> F (NodeView node)
  readInterfaceNode f = do
    name <- readProp "name" f
    partial <- readProp "partial" f
    members <- map fromForeign <$> readProp "members" f
    inheritance <- runNullOrUndefined <$> readProp "inheritance" f
    return $ InterfaceNode { name, partial, members, inheritance }

  fromRight (Right view) = view
  fromRight (Left err) = unsafeThrow $ "Unable to parse node: " <> show err


Add draftboard to next action card (#864)

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.CardType
  ( CardType(..)
  , AceMode(..)
  , cardName
  , cardGlyph
  , cardClasses
  , aceCardName
  , aceCardGlyph
  , aceCardClasses
  , aceMode
  , controllable
  , insertableCardTypes

  , blocking
  ) where

import SlamData.Prelude

import Control.Monad.Error.Class (throwError)

import Data.Argonaut (class EncodeJson, class DecodeJson, encodeJson, decodeJson)

import Halogen.HTML as H
import Halogen.HTML.Indexed as HH
import Halogen.Themes.Bootstrap3 as B
import Halogen.HTML.Properties.Indexed as HP

import SlamData.Render.Common (glyph)
import SlamData.Render.CSS as Rc

import Test.StrongCheck as SC

data CardType
  = Ace AceMode
  | Search
  | ChartOptions
  | Chart
  | Markdown
  | Table
  | Download
  | Variables
  | Troubleshoot
  | NextAction
  | Cache
  | Open
  | DownloadOptions
  | Draftboard
  | ErrorCard
  | PendingCard

insertableCardTypes ∷ Array CardType
insertableCardTypes =
  [ Ace SQLMode
  , Open
  , Search
  , Table
  , Variables
  , Ace MarkdownMode
  , Markdown
  , Download
  , DownloadOptions
  , ChartOptions
  , Chart
  , Draftboard
  , Troubleshoot
  , Cache
  ]

derive instance eqCardType ∷ Eq CardType
derive instance ordCardType ∷ Ord CardType

data AceMode
  = MarkdownMode
  | SQLMode

derive instance eqAceMode ∷ Eq AceMode
derive instance ordAceMode ∷ Ord AceMode

instance showAceMode ∷ Show AceMode where
  show MarkdownMode = "MarkdownMode"
  show SQLMode = "SQLMode"

instance arbitraryAceMode ∷ SC.Arbitrary AceMode where
  arbitrary = do
    b ← SC.arbitrary
    pure $ if b then MarkdownMode else SQLMode

instance encodeJsonCardType ∷ EncodeJson CardType where
  encodeJson =
    encodeJson ∘
      case _ of
        Ace MarkdownMode → "ace-markdown"
        Ace SQLMode → "ace-sql"
        Search → "search"
        ChartOptions → "chart-options"
        Chart → "chart"
        Markdown → "markdown"
        Table → "table"
        Download → "download"
        Variables → "variables"
        Troubleshoot → "troubleshoot"
        NextAction → "next-action"
        Cache → "cache"
        Open → "open"
        DownloadOptions → "download-options"
        Draftboard → "draftboard"
        ErrorCard → "error"
        PendingCard → "pending"

instance decodeJsonCardType ∷ DecodeJson CardType where
  decodeJson json = do
    str ← decodeJson json
    case str of
      "ace-markdown" → pure $ Ace MarkdownMode
      "ace-sql" → pure $ Ace SQLMode
      "search" → pure Search
      "chart-options" → pure ChartOptions
      "chart" → pure Chart
      "markdown" → pure Markdown
      "table" → pure Table
      "download" → pure Download
      "variables" → pure Variables
      "troubleshoot" → pure Troubleshoot
      "next-action" → pure NextAction
      "cache" → pure Cache
      "open" → pure Open
      "download-options" → pure DownloadOptions
      "draftboard" → pure Draftboard
      "error" → pure ErrorCard
      "pending" → pure PendingCard
      name → throwError $ "unknown card type '" ⊕ name ⊕ "'"

cardName ∷ CardType → String
cardName =
  case _ of
    Ace at → aceCardName at
    Search → "Search"
    ChartOptions → "Setup Chart"
    Chart → "Show Chart"
    Markdown → "Show Markdown"
    Table → "Show Table"
    Download → "Show Download"
    Variables → "Setup Variables"
    Troubleshoot → "Troubleshoot"
    NextAction → "Next Action"
    Cache → "Cache"
    Open → "Open"
    DownloadOptions → "Setup Download"
    Draftboard → "Setup Draftboard"
    ErrorCard → "Error"
    PendingCard → "Pending"

cardGlyph ∷ ∀ s f. CardType → H.HTML s f
cardGlyph =
  case _ of
    Ace at →glyph $ aceCardGlyph at
    Search → glyph B.glyphiconSearch
    ChartOptions → glyph B.glyphiconPicture
    Download → glyph B.glyphiconDownloadAlt
    Variables → glyph B.glyphiconOpenFile
    Troubleshoot → glyph B.glyphiconTasks
    Chart → HH.div [ HP.classes [ Rc.glyphImage, Rc.chartGlyph ] ] [ ]
    Markdown → HH.div [ HP.classes [ Rc.glyphImage, Rc.codeGlyph ] ] [ ]
    Table → glyph B.glyphiconThList
    NextAction → glyph B.glyphiconStop -- arbitrary
    Cache → glyph B.glyphiconFloppyDisk
    Open → glyph B.glyphiconFolderOpen
    DownloadOptions → glyph B.glyphiconDownload
    Draftboard → glyph B.glyphiconTh
    ErrorCard → glyph B.glyphiconAlert
    PendingCard → glyph B.glyphiconAlert --arbitrary

cardClasses ∷ CardType → Array H.ClassName
cardClasses =
  case _ of
    Ace at → [ H.className "sd-card-ace" ] <> aceCardClasses at
    Search → [ H.className "sd-card-search" ]
    ChartOptions → [ H.className "sd-card-chart-options" ]
    Chart → [ H.className "sd-card-chart" ]
    Markdown → [ H.className "sd-card-markdown" ]
    Table → [ H.className "sd-card-table" ]
    Download → [ H.className "sd-card-download" ]
    DownloadOptions → [ H.className "sd-card-download-options" ]
    Variables → [ H.className "sd-card-variables" ]
    Troubleshoot → [ H.className "sd-card-troubleshoot" ]
    NextAction → [ H.className "sd-card-next-action" ]
    Cache → [ H.className "sd-card-cache" ]
    Open → [ H.className "sd-card-open" ]
    Draftboard → [ H.className "sd-card-draftboard" ]
    ErrorCard → [ H.className "sd-card-error" ]
    PendingCard → [ H.className "sd-card-pending" ]

aceCardName ∷ AceMode → String
aceCardName MarkdownMode = "Setup Markdown"
aceCardName SQLMode = "Query"

aceCardGlyph ∷ AceMode → HH.ClassName
aceCardGlyph MarkdownMode = B.glyphiconEdit
aceCardGlyph SQLMode = B.glyphiconQuestionSign

aceCardClasses ∷ AceMode → Array H.ClassName
aceCardClasses MarkdownMode = [ H.className "sd-card-markdown" ]
aceCardClasses SQLMode = [ H.className "sd-card-sql" ]

aceMode ∷ AceMode → String
aceMode MarkdownMode = "ace/mode/markdown"
aceMode SQLMode = "ace/mode/sql"

controllable ∷ CardType → Boolean
controllable NextAction = false
controllable _ = true

blocking ∷ CardType → Boolean
blocking ErrorCard = true
blocking _ = false

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.CardType
  ( CardType(..)
  , AceMode(..)
  , cardName
  , cardGlyph
  , cardClasses
  , aceCardName
  , aceCardGlyph
  , aceCardClasses
  , aceMode
  , controllable
  , insertableCardTypes

  , blocking
  ) where

import SlamData.Prelude

import Control.Monad.Error.Class (throwError)

import Data.Argonaut (class EncodeJson, class DecodeJson, encodeJson, decodeJson)

import Halogen.HTML as H
import Halogen.HTML.Indexed as HH
import Halogen.Themes.Bootstrap3 as B
import Halogen.HTML.Properties.Indexed as HP

import SlamData.Render.Common (glyph)
import SlamData.Render.CSS as Rc

import Test.StrongCheck as SC

data CardType
  = Ace AceMode
  | Search
  | ChartOptions
  | Chart
  | Markdown
  | Table
  | Download
  | Variables
  | Troubleshoot
  | NextAction
  | Cache
  | Open
  | DownloadOptions
  | Draftboard
  | ErrorCard
  | PendingCard

insertableCardTypes ∷ Array CardType
insertableCardTypes =
  [ Ace SQLMode
  , Open
  , Search
  , Table
  , Variables
  , Ace MarkdownMode
  , Markdown
  , Download
  , DownloadOptions
  , ChartOptions
  , Chart
  , Troubleshoot
  , Cache
  ]

derive instance eqCardType ∷ Eq CardType
derive instance ordCardType ∷ Ord CardType

data AceMode
  = MarkdownMode
  | SQLMode

derive instance eqAceMode ∷ Eq AceMode
derive instance ordAceMode ∷ Ord AceMode

instance showAceMode ∷ Show AceMode where
  show MarkdownMode = "MarkdownMode"
  show SQLMode = "SQLMode"

instance arbitraryAceMode ∷ SC.Arbitrary AceMode where
  arbitrary = do
    b ← SC.arbitrary
    pure $ if b then MarkdownMode else SQLMode

instance encodeJsonCardType ∷ EncodeJson CardType where
  encodeJson =
    encodeJson ∘
      case _ of
        Ace MarkdownMode → "ace-markdown"
        Ace SQLMode → "ace-sql"
        Search → "search"
        ChartOptions → "chart-options"
        Chart → "chart"
        Markdown → "markdown"
        Table → "table"
        Download → "download"
        Variables → "variables"
        Troubleshoot → "troubleshoot"
        NextAction → "next-action"
        Cache → "cache"
        Open → "open"
        DownloadOptions → "download-options"
        Draftboard → "draftboard"
        ErrorCard → "error"
        PendingCard → "pending"

instance decodeJsonCardType ∷ DecodeJson CardType where
  decodeJson json = do
    str ← decodeJson json
    case str of
      "ace-markdown" → pure $ Ace MarkdownMode
      "ace-sql" → pure $ Ace SQLMode
      "search" → pure Search
      "chart-options" → pure ChartOptions
      "chart" → pure Chart
      "markdown" → pure Markdown
      "table" → pure Table
      "download" → pure Download
      "variables" → pure Variables
      "troubleshoot" → pure Troubleshoot
      "next-action" → pure NextAction
      "cache" → pure Cache
      "open" → pure Open
      "download-options" → pure DownloadOptions
      "draftboard" → pure Draftboard
      "error" → pure ErrorCard
      "pending" → pure PendingCard
      name → throwError $ "unknown card type '" ⊕ name ⊕ "'"

cardName ∷ CardType → String
cardName =
  case _ of
    Ace at → aceCardName at
    Search → "Search"
    ChartOptions → "Setup Chart"
    Chart → "Show Chart"
    Markdown → "Show Markdown"
    Table → "Show Table"
    Download → "Show Download"
    Variables → "Setup Variables"
    Troubleshoot → "Troubleshoot"
    NextAction → "Next Action"
    Cache → "Cache"
    Open → "Open"
    DownloadOptions → "Setup Download"
    Draftboard → "Draftboard"
    ErrorCard → "Error"
    PendingCard → "Pending"

cardGlyph ∷ ∀ s f. CardType → H.HTML s f
cardGlyph =
  case _ of
    Ace at →glyph $ aceCardGlyph at
    Search → glyph B.glyphiconSearch
    ChartOptions → glyph B.glyphiconPicture
    Download → glyph B.glyphiconDownloadAlt
    Variables → glyph B.glyphiconOpenFile
    Troubleshoot → glyph B.glyphiconTasks
    Chart → HH.div [ HP.classes [ Rc.glyphImage, Rc.chartGlyph ] ] [ ]
    Markdown → HH.div [ HP.classes [ Rc.glyphImage, Rc.codeGlyph ] ] [ ]
    Table → glyph B.glyphiconThList
    NextAction → glyph B.glyphiconStop -- arbitrary
    Cache → glyph B.glyphiconFloppyDisk
    Open → glyph B.glyphiconFolderOpen
    DownloadOptions → glyph B.glyphiconDownload
    Draftboard → glyph B.glyphiconTh
    ErrorCard → glyph B.glyphiconAlert
    PendingCard → glyph B.glyphiconAlert --arbitrary

cardClasses ∷ CardType → Array H.ClassName
cardClasses =
  case _ of
    Ace at → [ H.className "sd-card-ace" ] <> aceCardClasses at
    Search → [ H.className "sd-card-search" ]
    ChartOptions → [ H.className "sd-card-chart-options" ]
    Chart → [ H.className "sd-card-chart" ]
    Markdown → [ H.className "sd-card-markdown" ]
    Table → [ H.className "sd-card-table" ]
    Download → [ H.className "sd-card-download" ]
    DownloadOptions → [ H.className "sd-card-download-options" ]
    Variables → [ H.className "sd-card-variables" ]
    Troubleshoot → [ H.className "sd-card-troubleshoot" ]
    NextAction → [ H.className "sd-card-next-action" ]
    Cache → [ H.className "sd-card-cache" ]
    Open → [ H.className "sd-card-open" ]
    Draftboard → [ H.className "sd-card-draftboard" ]
    ErrorCard → [ H.className "sd-card-error" ]
    PendingCard → [ H.className "sd-card-pending" ]

aceCardName ∷ AceMode → String
aceCardName MarkdownMode = "Setup Markdown"
aceCardName SQLMode = "Query"

aceCardGlyph ∷ AceMode → HH.ClassName
aceCardGlyph MarkdownMode = B.glyphiconEdit
aceCardGlyph SQLMode = B.glyphiconQuestionSign

aceCardClasses ∷ AceMode → Array H.ClassName
aceCardClasses MarkdownMode = [ H.className "sd-card-markdown" ]
aceCardClasses SQLMode = [ H.className "sd-card-sql" ]

aceMode ∷ AceMode → String
aceMode MarkdownMode = "ace/mode/markdown"
aceMode SQLMode = "ace/mode/sql"

controllable ∷ CardType → Boolean
controllable NextAction = false
controllable _ = true

blocking ∷ CardType → Boolean
blocking ErrorCard = true
blocking _ = false


update to new Mesh

update to new Mesh


Simplify

Simplify

-- | A basic wrapper for the `webidl2` library, and some ADT sugar on top.

module WebIDL
  ( NodeView(..)
  , Type(..)
  , parse
  , toView
  , toViewWith
  ) where

import Prelude

import Data.Maybe
import Data.Either
import Data.Generic
import Data.Foreign
import Data.Foreign.Class
import Data.Foreign.NullOrUndefined

import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)

-- | Parse a WebIDL string. This function can throw exceptions.
foreign import parse :: String -> Foreign

newtype Type = Type
  { idlType   :: String
  , sequence  :: Boolean
  , generic   :: Maybe String
  , nullable  :: Boolean
  , array     :: Boolean
  , union     :: Boolean
  }

derive instance genericType :: Generic Type

instance showType :: Show Type where
  show = gShow

-- | A node represented as a PureScript data type.
data NodeView node
  = InterfaceNode
    { name        :: String
    , partial     :: Boolean
    , members     :: Array node
    , inheritance :: Maybe String
    }
  | ImplementsNode
    { target      :: String
    , implements  :: String
    }
  | TypeDefNode
  | CallbackNode
  | DictionaryNode
  | ExceptionNode
  | OperationMember
    { name            :: String
    , arguments       :: Array node
    , idlType         :: Type
    , getter          :: Boolean
    , setter          :: Boolean
    , creator         :: Boolean
    , deleter         :: Boolean
    , legacycaller    :: Boolean
    , static          :: Boolean
    , stringifier     :: Boolean
    }
  | ArgumentMember
    { name           :: String
    , idlType        :: Type
    , static         :: Boolean
    , stringifier    :: Boolean
    , inherit        :: Boolean
    , readonly       :: Boolean
    }
  | ConstantMember
  | SerializerMember
  | IteratorMember
  | OtherNode

derive instance genericNodeView :: (Generic node) => Generic (NodeView node)

instance showNodeView :: (Generic node) => Show (NodeView node) where
  show = gShow

-- | Unwrap the top level of a node.
toView :: Foreign -> NodeView Foreign
toView = toViewWith id

-- | Unwrap the top level of a node.
toViewWith :: forall node. (Foreign -> node) -> Foreign -> NodeView node
toViewWith fromForeign = fromRight <<< readView <<< toForeign
  where
  readView :: Foreign -> F (NodeView node)
  readView f = do
    _type <- readProp "type" f
    case _type of
      "interface" -> readInterfaceNode f
      _ -> pure OtherNode

  readInterfaceNode :: Foreign -> F (NodeView node)
  readInterfaceNode f = do
    name <- readProp "name" f
    partial <- readProp "partial" f
    members <- map fromForeign <$> readProp "members" f
    inheritance <- runNullOrUndefined <$> readProp "inheritance" f
    return $ InterfaceNode { name, partial, members, inheritance }

  fromRight (Right view) = view
  fromRight (Left err) = unsafeThrow $ "Unable to parse node: " <> show err

-- | A basic wrapper for the `webidl2` library, and some ADT sugar on top.

module WebIDL
  ( NodeView(..)
  , Type(..)
  , parse
  , toView
  , toViewWith
  ) where

import Prelude

import Data.Maybe
import Data.Either
import Data.Generic
import Data.Foreign
import Data.Foreign.Class
import Data.Foreign.NullOrUndefined

import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)

-- | Parse a WebIDL string. This function can throw exceptions.
foreign import parse :: String -> Foreign

newtype Type = Type
  { idlType   :: String
  , sequence  :: Boolean
  , generic   :: Maybe String
  , nullable  :: Boolean
  , array     :: Boolean
  , union     :: Boolean
  }

derive instance genericType :: Generic Type

instance showType :: Show Type where
  show = gShow

-- | A node represented as a PureScript data type.
data NodeView node
  = InterfaceNode
    { name        :: String
    , partial     :: Boolean
    , members     :: Array node
    , inheritance :: Maybe String
    }
  | ImplementsNode
    { target      :: String
    , implements  :: String
    }
  | TypeDefNode
  | CallbackNode
  | DictionaryNode
  | ExceptionNode
  | OperationMember
    { name            :: String
    , arguments       :: Array node
    , idlType         :: Type
    , getter          :: Boolean
    , setter          :: Boolean
    , creator         :: Boolean
    , deleter         :: Boolean
    , legacycaller    :: Boolean
    , static          :: Boolean
    , stringifier     :: Boolean
    }
  | ArgumentMember
    { name           :: String
    , idlType        :: Type
    , static         :: Boolean
    , stringifier    :: Boolean
    , inherit        :: Boolean
    , readonly       :: Boolean
    }
  | ConstantMember
  | SerializerMember
  | IteratorMember
  | OtherNode

derive instance genericNodeView :: (Generic node) => Generic (NodeView node)

instance showNodeView :: (Generic node) => Show (NodeView node) where
  show = gShow

-- | Unwrap the top level of a node.
toView :: Foreign -> NodeView Foreign
toView = toViewWith id

-- | Unwrap the top level of a node.
toViewWith :: forall node. (Foreign -> node) -> Foreign -> NodeView node
toViewWith fromForeign = fromRight <<< readView <<< toForeign
  where
  readView :: Foreign -> F (NodeView node)
  readView f = do
    _type <- readProp "type" f
    case _type of
      "interface" -> InterfaceNode <$> readInterfaceNode f
      _ -> pure OtherNode

  readInterfaceNode :: Foreign -> F { inheritance :: Maybe String
                                    , members :: Array node
                                    , partial :: Boolean
                                    , name :: String
                                    }
  readInterfaceNode f = do
    name <- readProp "name" f
    partial <- readProp "partial" f
    members <- map fromForeign <$> readProp "members" f
    inheritance <- runNullOrUndefined <$> readProp "inheritance" f
    return { name, partial, members, inheritance }

  fromRight (Right view) = view
  fromRight (Left err) = unsafeThrow $ "Unable to parse node: " <> show err


Sink manager and start of track manager

Sink manager and start of track manager

module Genetics.Browser.Events.TrackManager where

import Prelude
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Data.Record.Unsafe (unsafeGet)
import Data.Tuple (Tuple(..))
import Data.Variant (Variant, expand)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

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

-- A SourceManager simply keeps track of the incoming event bus.
-- we currently just use one event bus since we don't care about
-- from where the events are coming
newtype SourceManager events = SourceManager (BusRW (Variant events))

mkSourceManager :: ∀ eff evs.
                   Aff (avar :: AVAR | eff) (SourceManager evs)
mkSourceManager = do
  bus <- Bus.make
  pure $ SourceManager bus

-- A source can be added as long as the label and type don't conflict
-- with an existing source; i.e. if the label is already in the SourceManager,
-- the types for that label must be the same

-- adding a source is really...
-- providing a producer of the appropriate variants.
--
-- rather, attaching another producer to the bus.
-- the sourcemanager itself is just the bus, after all.

-- Need this since Bus doesn't have a Functor instance
expandBus :: ∀ lt a gt.
             Union lt a gt
          => BusRW (Variant lt)
          -> BusRW (Variant gt)
expandBus = unsafeCoerce

addSource :: ∀ eff events1 evC events2.
             Union events1 evC events2
          => (BusRW (Variant events2) -> Aff _ Unit)
          -> SourceManager events1
          -> Aff _ (SourceManager events2)
addSource cb (SourceManager bus) = cb bus2 *> (pure $ SourceManager bus2)
  where bus2 = expandBus bus

-- A SinkManager knows of all the tracks' respective TrackSinks,
-- i.e. all things that can receive events.
-- so, it receives events from the SourceManager.
-- it then runs the appropriate sinks; basically `applySinkManager` or w/e looks
-- just like `applyTrackSink`
-- the problem might be in the output type... we'll need to unify effects
-- (or more realistically, keep it a type hole~~)
newtype SinkManager (sinks :: # Type) (sinkFuns :: # Type) output = SinkManager (Record sinkFuns)

mkSinkManager :: ∀ a.
                 SinkManager () () a
mkSinkManager = SinkManager {}

applySinkManager :: ∀ lt a b rIn rFun.
                  Union lt a rIn
               => SinkManager rIn rFun b
               -> Variant lt
               -> b
applySinkManager (SinkManager h) v =
  case coerceV v of
    Tuple tag a -> a # unsafeGet tag h
  where coerceV :: ∀ c. Variant lt -> Tuple String c
        coerceV = unsafeCoerce

-- the EventManager must be able to be updated on the fly as tracks get started
-- while still doing its thing...

-- and what, exactly, *is* its "Thing?"
-- that would be actually running the sourcemanager and sinkmanager,
-- i.e. doing applySinkManager (which is in Eff or Aff, remember)
-- while reading from the SourceManager bus.

-- so we probably want something like
newtype EventManager = EventManager { sourceManager :: AVar (SourceManager _)
                                    , sinkManager :: AVar (SinkManager _)}

-- except, again, if we add new sources and sinks to these managers,
-- we the respective types actually change...

-- well, actually, that shouldn't be a problem.
-- the functions to add sinks and sources should have the correct types anyway;
-- the respective managers will have the correct types whether or not they've
-- actually been added yet.

-- which makes another problem apparent; what if a source sends an event that
-- will be handled by a sink that's not ready yet?

-- geez

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

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

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

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

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

module Genetics.Browser.Events.TrackManager where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Bus (BusRW)
import Data.Variant (Variant, expand)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

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

-- A SourceManager simply keeps track of the incoming event bus.
-- we currently just use one event bus since we don't care about
-- from where the events are coming
newtype SourceManager events = SourceManager (BusRW (Variant events))

-- mkSourceManager :: SourceManager ()
-- mkSourceManager = SourceManager ?makeBus

-- A source can be added as long as the label and type don't conflict
-- with an existing source; i.e. if the label is already in the SourceManager,
-- the types for that label must be the same

-- adding a source is really...
-- providing a producer of the appropriate variants.
--
-- rather, attaching another producer to the bus.
-- the sourcemanager itself is just the bus, after all.

-- Need this since Bus doesn't have a Functor instance
expandBus :: ∀ lt a gt.
             Union lt a gt
          => BusRW (Variant lt)
          -> BusRW (Variant gt)
expandBus = unsafeCoerce

addSource :: ∀ eff events1 evC events2.
             Union events1 evC events2
          => (BusRW (Variant events2) -> Aff _ Unit)
          -> SourceManager events1
          -> Aff _ (SourceManager events2)
addSource cb (SourceManager bus) = cb bus2 *> (pure $ SourceManager bus2)
  where bus2 = expandBus bus

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

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

mkSinkManager = SinkManager {}

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

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

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

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

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


Fix ordArray instance

Fix ordArray instance

module Prelude
  ( flip
  , const
  , asTypeOf
  , Semigroupoid, (<<<), (>>>)
  , Category, id
  , ($), (#)
  , (:), cons
  , Show, show
  , Functor, (<$>)
  , Apply, (<*>)
  , Applicative, pure, liftA1
  , Alternative, empty, (<|>)
  , Bind, (>>=)
  , Monad, return, liftM1, ap
  , Num, (+), (-), (*), (/), (%)
  , negate
  , Eq, (==), (/=), refEq, refIneq
  , Ord, Ordering(..), compare, (<), (>), (<=), (>=)
  , Bits, (&), (|), (^), shl, shr, zshr, complement
  , BoolLike, (&&), (||)
  , not
  , Semigroup, (<>), (++)
  ) where

  flip :: forall a b c. (a -> b -> c) -> b -> a -> c
  flip f b a = f a b

  const :: forall a b. a -> b -> a
  const a _ = a

  asTypeOf :: forall a. a -> a -> a
  asTypeOf x _ = x

  infixr 9 >>>
  infixr 9 <<<

  class Semigroupoid a where
    (<<<) :: forall b c d. a c d -> a b c -> a b d

  instance semigroupoidArr :: Semigroupoid (->) where
    (<<<) f g x = f (g x)

  (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
  (>>>) f g = g <<< f

  class (Semigroupoid a) <= Category a where
    id :: forall t. a t t

  instance categoryArr :: Category (->) where
    id x = x

  infixr 0 $
  infixl 0 #

  ($) :: forall a b. (a -> b) -> a -> b
  ($) f x = f x

  (#) :: forall a b. a -> (a -> b) -> b
  (#) x f = f x

  infixr 6 :

  (:) :: forall a. a -> [a] -> [a]
  (:) = cons

  foreign import cons
    "function cons(e) {\
    \  return function (l) {\
    \    return [e].concat(l);\
    \  };\
    \}" :: forall a. a -> [a] -> [a]

  class Show a where
    show :: a -> String

  foreign import showStringImpl
    "function showStringImpl(s) {\
    \  return JSON.stringify(s);\
    \}" :: String -> String

  instance showString :: Show String where
    show = showStringImpl

  instance showBoolean :: Show Boolean where
    show true = "true"
    show false = "false"

  foreign import showNumberImpl "function showNumberImpl(n) {\
                                \  return n.toString();\
                                \}" :: Number -> String

  instance showNumber :: Show Number where
    show = showNumberImpl

  foreign import showArrayImpl
    "function showArrayImpl (f) {\
    \  return function (xs) {\
    \    var ss = [];\
    \    for (var i = 0, l = xs.length; i < l; i++) {\
    \      ss[i] = f(xs[i]);\
    \    }\
    \    return '[' + ss.join(',') + ']';\
    \  };\
    \}" :: forall a. (a -> String) -> [a] -> String

  instance showArray :: (Show a) => Show [a] where
    show = showArrayImpl show

  infixl 4 <$>

  class Functor f where
    (<$>) :: forall a b. (a -> b) -> f a -> f b

  infixl 4 <*>

  class (Functor f) <= Apply f where
    (<*>) :: forall a b. f (a -> b) -> f a -> f b

  class (Apply f) <= Applicative f where
    pure :: forall a. a -> f a

  liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
  liftA1 f a = pure f <*> a

  infixl 3 <|>

  class Alternative f where
    empty :: forall a. f a
    (<|>) :: forall a. f a -> f a -> f a

  infixl 1 >>=

  class (Apply m) <= Bind m where
    (>>=) :: forall a b. m a -> (a -> m b) -> m b

  class (Applicative m, Bind m) <= Monad m

  return :: forall m a. (Monad m) => a -> m a
  return = pure

  liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
  liftM1 f a = do
    a' <- a
    return (f a')

  ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
  ap f a = do
    f' <- f
    a' <- a
    return (f' a')

  infixl 7 *
  infixl 7 /
  infixl 7 %

  infixl 6 -
  infixl 6 +

  class Num a where
    (+) :: a -> a -> a
    (-) :: a -> a -> a
    (*) :: a -> a -> a
    (/) :: a -> a -> a
    (%) :: a -> a -> a
    negate :: a -> a

  foreign import numAdd "function numAdd(n1) {\
                        \  return function(n2) {\
                        \    return n1 + n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numSub "function numSub(n1) {\
                        \  return function(n2) {\
                        \    return n1 - n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMul "function numMul(n1) {\
                        \  return function(n2) {\
                        \    return n1 * n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numDiv "function numDiv(n1) {\
                        \  return function(n2) {\
                        \    return n1 / n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMod "function numMod(n1) {\
                        \  return function(n2) {\
                        \    return n1 % n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numNegate "function numNegate(n) {\
                           \  return -n;\
                           \}" :: Number -> Number

  instance numNumber :: Num Number where
    (+) = numAdd
    (-) = numSub
    (*) = numMul
    (/) = numDiv
    (%) = numMod
    negate = numNegate

  infix 4 ==
  infix 4 /=

  class Eq a where
    (==) :: a -> a -> Boolean
    (/=) :: a -> a -> Boolean

  foreign import refEq
    "function refEq(r1) {\
    \  return function(r2) {\
    \    return r1 === r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  foreign import refIneq
    "function refIneq(r1) {\
    \  return function(r2) {\
    \    return r1 !== r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  instance eqString :: Eq String where
    (==) = refEq
    (/=) = refIneq

  instance eqNumber :: Eq Number where
    (==) = refEq
    (/=) = refIneq

  instance eqBoolean :: Eq Boolean where
    (==) = refEq
    (/=) = refIneq

  instance eqArray :: (Eq a) => Eq [a] where
    (==) [] [] = true
    (==) (x:xs) (y:ys) = x == y && xs == ys
    (==) _ _ = false
    (/=) xs ys = not (xs == ys)

  data Ordering = LT | GT | EQ

  instance eqOrdering :: Eq Ordering where
    (==) LT LT = true
    (==) GT GT = true
    (==) EQ EQ = true
    (==) _  _  = false
    (/=) x y = not (x == y)

  instance showOrdering :: Show Ordering where
    show LT = "LT"
    show GT = "GT"
    show EQ = "EQ"

  class (Eq a) <= Ord a where
    compare :: a -> a -> Ordering

  infixl 4 <

  (<) :: forall a. (Ord a) => a -> a -> Boolean
  (<) a1 a2 = case a1 `compare` a2 of
    LT -> true
    _ -> false

  infixl 4 >

  (>) :: forall a. (Ord a) => a -> a -> Boolean
  (>) a1 a2 = case a1 `compare` a2 of
    GT -> true
    _ -> false

  infixl 4 <=

  (<=) :: forall a. (Ord a) => a -> a -> Boolean
  (<=) a1 a2 = case a1 `compare` a2 of
    GT -> false
    _ -> true

  infixl 4 >=

  (>=) :: forall a. (Ord a) => a -> a -> Boolean
  (>=) a1 a2 = case a1 `compare` a2 of
    LT -> false
    _ -> true

  foreign import unsafeCompare
    "function unsafeCompare(n1) {\
    \  return function(n2) {\
    \    return n1 < n2 ? LT : n1 > n2 ? GT : EQ;\
    \  };\
    \}" :: forall a. a -> a -> Ordering

  instance ordBoolean :: Ord Boolean where
    compare false false = EQ
    compare false true  = LT
    compare true  true  = EQ
    compare true  false = GT

  instance ordNumber :: Ord Number where
    compare = unsafeCompare

  instance ordString :: Ord String where
    compare = unsafeCompare

  instance ordArray :: (Ord a) => Ord [a] where
    compare [] [] = EQ
    compare [] _ = LT
    compare _ [] = GT
    compare (x:xs) (y:ys) = case compare x y of
      EQ -> compare xs ys
      other -> other

  infixl 10 &
  infixl 10 |
  infixl 10 ^

  class Bits b where
    (&) :: b -> b -> b
    (|) :: b -> b -> b
    (^) :: b -> b -> b
    shl :: b -> Number -> b
    shr :: b -> Number -> b
    zshr :: b -> Number -> b
    complement :: b -> b

  foreign import numShl "function numShl(n1) {\
                        \  return function(n2) {\
                        \    return n1 << n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numShr "function numShr(n1) {\
                        \  return function(n2) {\
                        \    return n1 >> n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numZshr "function numZshr(n1) {\
                          \  return function(n2) {\
                          \    return n1 >>> n2;\
                          \  };\
                          \}" :: Number -> Number -> Number

  foreign import numAnd "function numAnd(n1) {\
                        \  return function(n2) {\
                        \    return n1 & n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numOr "function numOr(n1) {\
                       \  return function(n2) {\
                       \    return n1 | n2;\
                       \  };\
                       \}" :: Number -> Number -> Number

  foreign import numXor "function numXor(n1) {\
                        \  return function(n2) {\
                        \    return n1 ^ n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numComplement "function numComplement(n) {\
                               \  return ~n;\
                               \}" :: Number -> Number

  instance bitsNumber :: Bits Number where
    (&) = numAnd
    (|) = numOr
    (^) = numXor
    shl = numShl
    shr = numShr
    zshr = numZshr
    complement = numComplement

  infixr 2 ||
  infixr 3 &&

  class BoolLike b where
    (&&) :: b -> b -> b
    (||) :: b -> b -> b
    not :: b -> b

  foreign import boolAnd "function boolAnd(b1) {\
                         \  return function(b2) {\
                         \    return b1 && b2;\
                         \  };\
                         \}"  :: Boolean -> Boolean -> Boolean

  foreign import boolOr "function boolOr(b1) {\
                        \  return function(b2) {\
                        \    return b1 || b2;\
                        \  };\
                        \}" :: Boolean -> Boolean -> Boolean

  foreign import boolNot "function boolNot(b) {\
                         \  return !b;\
                         \}" :: Boolean -> Boolean

  instance boolLikeBoolean :: BoolLike Boolean where
    (&&) = boolAnd
    (||) = boolOr
    not = boolNot

  infixr 5 <>

  class Semigroup a where
    (<>) :: a -> a -> a

  foreign import concatString
    "function concatString(s1) {\
    \  return function(s2) {\
    \    return s1 + s2;\
    \  };\
    \}" :: String -> String -> String

  instance semigroupString :: Semigroup String where
    (<>) = concatString

  infixr 5 ++

  (++) :: forall s. (Semigroup s) => s -> s -> s
  (++) = (<>)

module Data.Function where

  on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
  on f g x y = g x `f` g y

module Data.Eq where

  data Ref a = Ref a

  liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
  liftRef f (Ref x) (Ref y) = f x y

  instance eqRef :: Eq (Ref a) where
    (==) = liftRef refEq
    (/=) = liftRef refIneq

module Prelude.Unsafe where

  foreign import unsafeIndex
    "function unsafeIndex(xs) {\
    \  return function(n) {\
    \    return xs[n];\
    \  };\
    \}" :: forall a. [a] -> Number -> a

module Control.Monad.Eff where

  foreign import data Eff :: # ! -> * -> *

  foreign import returnE "function returnE(a) {\
                         \  return function() {\
                         \    return a;\
                         \  };\
                         \}" :: forall e a. a -> Eff e a

  foreign import bindE "function bindE(a) {\
                       \  return function(f) {\
                       \    return function() {\
                       \      return f(a())();\
                       \    };\
                       \  };\
                       \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

  type Pure a = forall e. Eff e a

  foreign import runPure "function runPure(f) {\
                         \  return f();\
                         \}" :: forall a. Pure a -> a

  instance functorEff :: Functor (Eff e) where
    (<$>) = liftA1

  instance applyEff :: Apply (Eff e) where
    (<*>) = ap

  instance applicativeEff :: Applicative (Eff e) where
    pure = returnE

  instance bindEff :: Bind (Eff e) where
    (>>=) = bindE

  instance monadEff :: Monad (Eff e)

  foreign import untilE "function untilE(f) {\
                        \  return function() {\
                        \    while (!f()) { }\
                        \    return {};\
                        \  };\
                        \}" :: forall e. Eff e Boolean -> Eff e {}

  foreign import whileE "function whileE(f) {\
                        \  return function(a) {\
                        \    return function() {\
                        \      while (f()) {\
                        \        a();\
                        \      }\
                        \      return {};\
                        \    };\
                        \  };\
                        \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e {}

  foreign import forE "function forE(lo) {\
                      \  return function(hi) {\
                      \    return function(f) {\
                      \      return function() {\
                      \        for (var i = lo; i < hi; i++) {\
                      \          f(i)();\
                      \        }\
                      \      };\
                      \    };\
                      \  };\
                      \}" :: forall e. Number -> Number -> (Number -> Eff e {}) -> Eff e {}

  foreign import foreachE "function foreachE(as) {\
                          \  return function(f) {\
                          \    for (var i = 0; i < as.length; i++) {\
                          \      f(as[i])();\
                          \    }\
                          \  };\
                          \}" :: forall e a. [a] -> (a -> Eff e {}) -> Eff e {}

module Control.Monad.Eff.Unsafe where

  import Control.Monad.Eff

  foreign import unsafeInterleaveEff
    "function unsafeInterleaveEff(f) {\
    \  return f;\
    \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a

module Debug.Trace where

  import Control.Monad.Eff

  foreign import data Trace :: !

  foreign import trace "function trace(s) {\
                       \  return function() {\
                       \    console.log(s);\
                       \    return {};\
                       \  };\
                       \}" :: forall r. String -> Eff (trace :: Trace | r) {}

  print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) {}
  print o = trace (show o)

module Control.Monad.ST where

  import Control.Monad.Eff

  foreign import data ST :: * -> !

  foreign import data STRef :: * -> * -> *

  foreign import data STArray :: * -> * -> *

  foreign import newSTRef "function newSTRef(val) {\
                          \  return function () {\
                          \    return { value: val };\
                          \  };\
                          \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

  foreign import readSTRef "function readSTRef(ref) {\
                           \  return function() {\
                           \    return ref.value;\
                           \  };\
                           \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

  foreign import modifySTRef "function modifySTRef(ref) {\
                             \  return function(f) {\
                             \    return function() {\
                             \      return ref.value = f(ref.value);\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

  foreign import writeSTRef "function writeSTRef(ref) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      return ref.value = a;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

  foreign import newSTArray "function newSTArray(len) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      var arr = [];\
                            \      for (var i = 0; i < len; i++) {\
                            \        arr[i] = a;\
                            \      };\
                            \      return arr;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)

  foreign import peekSTArray "function peekSTArray(arr) {\
                             \  return function(i) {\
                             \    return function() {\
                             \      return arr[i];\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Eff (st :: ST h | r) a

  foreign import pokeSTArray "function pokeSTArray(arr) {\
                             \  return function(i) {\
                             \    return function(a) {\
                             \      return function() {\
                             \        return arr[i] = a;\
                             \      };\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a

  foreign import runST "function runST(f) {\
                       \  return f;\
                       \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

  foreign import runSTArray "function runSTArray(f) {\
                            \  return f;\
                            \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]

module Prelude
  ( flip
  , const
  , asTypeOf
  , Semigroupoid, (<<<), (>>>)
  , Category, id
  , ($), (#)
  , (:), cons
  , Show, show
  , Functor, (<$>)
  , Apply, (<*>)
  , Applicative, pure, liftA1
  , Alternative, empty, (<|>)
  , Bind, (>>=)
  , Monad, return, liftM1, ap
  , Num, (+), (-), (*), (/), (%)
  , negate
  , Eq, (==), (/=), refEq, refIneq
  , Ord, Ordering(..), compare, (<), (>), (<=), (>=)
  , Bits, (&), (|), (^), shl, shr, zshr, complement
  , BoolLike, (&&), (||)
  , not
  , Semigroup, (<>), (++)
  ) where

  flip :: forall a b c. (a -> b -> c) -> b -> a -> c
  flip f b a = f a b

  const :: forall a b. a -> b -> a
  const a _ = a

  asTypeOf :: forall a. a -> a -> a
  asTypeOf x _ = x

  infixr 9 >>>
  infixr 9 <<<

  class Semigroupoid a where
    (<<<) :: forall b c d. a c d -> a b c -> a b d

  instance semigroupoidArr :: Semigroupoid (->) where
    (<<<) f g x = f (g x)

  (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
  (>>>) f g = g <<< f

  class (Semigroupoid a) <= Category a where
    id :: forall t. a t t

  instance categoryArr :: Category (->) where
    id x = x

  infixr 0 $
  infixl 0 #

  ($) :: forall a b. (a -> b) -> a -> b
  ($) f x = f x

  (#) :: forall a b. a -> (a -> b) -> b
  (#) x f = f x

  infixr 6 :

  (:) :: forall a. a -> [a] -> [a]
  (:) = cons

  foreign import cons
    "function cons(e) {\
    \  return function (l) {\
    \    return [e].concat(l);\
    \  };\
    \}" :: forall a. a -> [a] -> [a]

  class Show a where
    show :: a -> String

  foreign import showStringImpl
    "function showStringImpl(s) {\
    \  return JSON.stringify(s);\
    \}" :: String -> String

  instance showString :: Show String where
    show = showStringImpl

  instance showBoolean :: Show Boolean where
    show true = "true"
    show false = "false"

  foreign import showNumberImpl "function showNumberImpl(n) {\
                                \  return n.toString();\
                                \}" :: Number -> String

  instance showNumber :: Show Number where
    show = showNumberImpl

  foreign import showArrayImpl
    "function showArrayImpl (f) {\
    \  return function (xs) {\
    \    var ss = [];\
    \    for (var i = 0, l = xs.length; i < l; i++) {\
    \      ss[i] = f(xs[i]);\
    \    }\
    \    return '[' + ss.join(',') + ']';\
    \  };\
    \}" :: forall a. (a -> String) -> [a] -> String

  instance showArray :: (Show a) => Show [a] where
    show = showArrayImpl show

  infixl 4 <$>

  class Functor f where
    (<$>) :: forall a b. (a -> b) -> f a -> f b

  infixl 4 <*>

  class (Functor f) <= Apply f where
    (<*>) :: forall a b. f (a -> b) -> f a -> f b

  class (Apply f) <= Applicative f where
    pure :: forall a. a -> f a

  liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
  liftA1 f a = pure f <*> a

  infixl 3 <|>

  class Alternative f where
    empty :: forall a. f a
    (<|>) :: forall a. f a -> f a -> f a

  infixl 1 >>=

  class (Apply m) <= Bind m where
    (>>=) :: forall a b. m a -> (a -> m b) -> m b

  class (Applicative m, Bind m) <= Monad m

  return :: forall m a. (Monad m) => a -> m a
  return = pure

  liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
  liftM1 f a = do
    a' <- a
    return (f a')

  ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
  ap f a = do
    f' <- f
    a' <- a
    return (f' a')

  infixl 7 *
  infixl 7 /
  infixl 7 %

  infixl 6 -
  infixl 6 +

  class Num a where
    (+) :: a -> a -> a
    (-) :: a -> a -> a
    (*) :: a -> a -> a
    (/) :: a -> a -> a
    (%) :: a -> a -> a
    negate :: a -> a

  foreign import numAdd "function numAdd(n1) {\
                        \  return function(n2) {\
                        \    return n1 + n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numSub "function numSub(n1) {\
                        \  return function(n2) {\
                        \    return n1 - n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMul "function numMul(n1) {\
                        \  return function(n2) {\
                        \    return n1 * n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numDiv "function numDiv(n1) {\
                        \  return function(n2) {\
                        \    return n1 / n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMod "function numMod(n1) {\
                        \  return function(n2) {\
                        \    return n1 % n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numNegate "function numNegate(n) {\
                           \  return -n;\
                           \}" :: Number -> Number

  instance numNumber :: Num Number where
    (+) = numAdd
    (-) = numSub
    (*) = numMul
    (/) = numDiv
    (%) = numMod
    negate = numNegate

  infix 4 ==
  infix 4 /=

  class Eq a where
    (==) :: a -> a -> Boolean
    (/=) :: a -> a -> Boolean

  foreign import refEq
    "function refEq(r1) {\
    \  return function(r2) {\
    \    return r1 === r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  foreign import refIneq
    "function refIneq(r1) {\
    \  return function(r2) {\
    \    return r1 !== r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  instance eqString :: Eq String where
    (==) = refEq
    (/=) = refIneq

  instance eqNumber :: Eq Number where
    (==) = refEq
    (/=) = refIneq

  instance eqBoolean :: Eq Boolean where
    (==) = refEq
    (/=) = refIneq

  instance eqArray :: (Eq a) => Eq [a] where
    (==) [] [] = true
    (==) (x:xs) (y:ys) = x == y && xs == ys
    (==) _ _ = false
    (/=) xs ys = not (xs == ys)

  data Ordering = LT | GT | EQ

  instance eqOrdering :: Eq Ordering where
    (==) LT LT = true
    (==) GT GT = true
    (==) EQ EQ = true
    (==) _  _  = false
    (/=) x y = not (x == y)

  instance showOrdering :: Show Ordering where
    show LT = "LT"
    show GT = "GT"
    show EQ = "EQ"

  class (Eq a) <= Ord a where
    compare :: a -> a -> Ordering

  infixl 4 <

  (<) :: forall a. (Ord a) => a -> a -> Boolean
  (<) a1 a2 = case a1 `compare` a2 of
    LT -> true
    _ -> false

  infixl 4 >

  (>) :: forall a. (Ord a) => a -> a -> Boolean
  (>) a1 a2 = case a1 `compare` a2 of
    GT -> true
    _ -> false

  infixl 4 <=

  (<=) :: forall a. (Ord a) => a -> a -> Boolean
  (<=) a1 a2 = case a1 `compare` a2 of
    GT -> false
    _ -> true

  infixl 4 >=

  (>=) :: forall a. (Ord a) => a -> a -> Boolean
  (>=) a1 a2 = case a1 `compare` a2 of
    LT -> false
    _ -> true

  foreign import unsafeCompare
    "function unsafeCompare(n1) {\
    \  return function(n2) {\
    \    return n1 < n2 ? LT : n1 > n2 ? GT : EQ;\
    \  };\
    \}" :: forall a. a -> a -> Ordering

  instance ordBoolean :: Ord Boolean where
    compare false false = EQ
    compare false true  = LT
    compare true  true  = EQ
    compare true  false = GT

  instance ordNumber :: Ord Number where
    compare = unsafeCompare

  instance ordString :: Ord String where
    compare = unsafeCompare

  instance ordArray :: (Ord a) => Ord [a] where
    compare (x:xs) (y:ys) = case compare x y of
      EQ -> compare xs ys
      other -> other

  infixl 10 &
  infixl 10 |
  infixl 10 ^

  class Bits b where
    (&) :: b -> b -> b
    (|) :: b -> b -> b
    (^) :: b -> b -> b
    shl :: b -> Number -> b
    shr :: b -> Number -> b
    zshr :: b -> Number -> b
    complement :: b -> b

  foreign import numShl "function numShl(n1) {\
                        \  return function(n2) {\
                        \    return n1 << n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numShr "function numShr(n1) {\
                        \  return function(n2) {\
                        \    return n1 >> n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numZshr "function numZshr(n1) {\
                          \  return function(n2) {\
                          \    return n1 >>> n2;\
                          \  };\
                          \}" :: Number -> Number -> Number

  foreign import numAnd "function numAnd(n1) {\
                        \  return function(n2) {\
                        \    return n1 & n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numOr "function numOr(n1) {\
                       \  return function(n2) {\
                       \    return n1 | n2;\
                       \  };\
                       \}" :: Number -> Number -> Number

  foreign import numXor "function numXor(n1) {\
                        \  return function(n2) {\
                        \    return n1 ^ n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numComplement "function numComplement(n) {\
                               \  return ~n;\
                               \}" :: Number -> Number

  instance bitsNumber :: Bits Number where
    (&) = numAnd
    (|) = numOr
    (^) = numXor
    shl = numShl
    shr = numShr
    zshr = numZshr
    complement = numComplement

  infixr 2 ||
  infixr 3 &&

  class BoolLike b where
    (&&) :: b -> b -> b
    (||) :: b -> b -> b
    not :: b -> b

  foreign import boolAnd "function boolAnd(b1) {\
                         \  return function(b2) {\
                         \    return b1 && b2;\
                         \  };\
                         \}"  :: Boolean -> Boolean -> Boolean

  foreign import boolOr "function boolOr(b1) {\
                        \  return function(b2) {\
                        \    return b1 || b2;\
                        \  };\
                        \}" :: Boolean -> Boolean -> Boolean

  foreign import boolNot "function boolNot(b) {\
                         \  return !b;\
                         \}" :: Boolean -> Boolean

  instance boolLikeBoolean :: BoolLike Boolean where
    (&&) = boolAnd
    (||) = boolOr
    not = boolNot

  infixr 5 <>

  class Semigroup a where
    (<>) :: a -> a -> a

  foreign import concatString
    "function concatString(s1) {\
    \  return function(s2) {\
    \    return s1 + s2;\
    \  };\
    \}" :: String -> String -> String

  instance semigroupString :: Semigroup String where
    (<>) = concatString

  infixr 5 ++

  (++) :: forall s. (Semigroup s) => s -> s -> s
  (++) = (<>)

module Data.Function where

  on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
  on f g x y = g x `f` g y

module Data.Eq where

  data Ref a = Ref a

  liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
  liftRef f (Ref x) (Ref y) = f x y

  instance eqRef :: Eq (Ref a) where
    (==) = liftRef refEq
    (/=) = liftRef refIneq

module Prelude.Unsafe where

  foreign import unsafeIndex
    "function unsafeIndex(xs) {\
    \  return function(n) {\
    \    return xs[n];\
    \  };\
    \}" :: forall a. [a] -> Number -> a

module Control.Monad.Eff where

  foreign import data Eff :: # ! -> * -> *

  foreign import returnE "function returnE(a) {\
                         \  return function() {\
                         \    return a;\
                         \  };\
                         \}" :: forall e a. a -> Eff e a

  foreign import bindE "function bindE(a) {\
                       \  return function(f) {\
                       \    return function() {\
                       \      return f(a())();\
                       \    };\
                       \  };\
                       \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

  type Pure a = forall e. Eff e a

  foreign import runPure "function runPure(f) {\
                         \  return f();\
                         \}" :: forall a. Pure a -> a

  instance functorEff :: Functor (Eff e) where
    (<$>) = liftA1

  instance applyEff :: Apply (Eff e) where
    (<*>) = ap

  instance applicativeEff :: Applicative (Eff e) where
    pure = returnE

  instance bindEff :: Bind (Eff e) where
    (>>=) = bindE

  instance monadEff :: Monad (Eff e)

  foreign import untilE "function untilE(f) {\
                        \  return function() {\
                        \    while (!f()) { }\
                        \    return {};\
                        \  };\
                        \}" :: forall e. Eff e Boolean -> Eff e {}

  foreign import whileE "function whileE(f) {\
                        \  return function(a) {\
                        \    return function() {\
                        \      while (f()) {\
                        \        a();\
                        \      }\
                        \      return {};\
                        \    };\
                        \  };\
                        \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e {}

  foreign import forE "function forE(lo) {\
                      \  return function(hi) {\
                      \    return function(f) {\
                      \      return function() {\
                      \        for (var i = lo; i < hi; i++) {\
                      \          f(i)();\
                      \        }\
                      \      };\
                      \    };\
                      \  };\
                      \}" :: forall e. Number -> Number -> (Number -> Eff e {}) -> Eff e {}

  foreign import foreachE "function foreachE(as) {\
                          \  return function(f) {\
                          \    for (var i = 0; i < as.length; i++) {\
                          \      f(as[i])();\
                          \    }\
                          \  };\
                          \}" :: forall e a. [a] -> (a -> Eff e {}) -> Eff e {}

module Control.Monad.Eff.Unsafe where

  import Control.Monad.Eff

  foreign import unsafeInterleaveEff
    "function unsafeInterleaveEff(f) {\
    \  return f;\
    \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a

module Debug.Trace where

  import Control.Monad.Eff

  foreign import data Trace :: !

  foreign import trace "function trace(s) {\
                       \  return function() {\
                       \    console.log(s);\
                       \    return {};\
                       \  };\
                       \}" :: forall r. String -> Eff (trace :: Trace | r) {}

  print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) {}
  print o = trace (show o)

module Control.Monad.ST where

  import Control.Monad.Eff

  foreign import data ST :: * -> !

  foreign import data STRef :: * -> * -> *

  foreign import data STArray :: * -> * -> *

  foreign import newSTRef "function newSTRef(val) {\
                          \  return function () {\
                          \    return { value: val };\
                          \  };\
                          \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

  foreign import readSTRef "function readSTRef(ref) {\
                           \  return function() {\
                           \    return ref.value;\
                           \  };\
                           \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

  foreign import modifySTRef "function modifySTRef(ref) {\
                             \  return function(f) {\
                             \    return function() {\
                             \      return ref.value = f(ref.value);\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

  foreign import writeSTRef "function writeSTRef(ref) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      return ref.value = a;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

  foreign import newSTArray "function newSTArray(len) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      var arr = [];\
                            \      for (var i = 0; i < len; i++) {\
                            \        arr[i] = a;\
                            \      };\
                            \      return arr;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)

  foreign import peekSTArray "function peekSTArray(arr) {\
                             \  return function(i) {\
                             \    return function() {\
                             \      return arr[i];\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Eff (st :: ST h | r) a

  foreign import pokeSTArray "function pokeSTArray(arr) {\
                             \  return function(i) {\
                             \    return function(a) {\
                             \      return function() {\
                             \        return arr[i] = a;\
                             \      };\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a

  foreign import runST "function runST(f) {\
                       \  return f;\
                       \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

  foreign import runSTArray "function runSTArray(f) {\
                            \  return f;\
                            \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]


Added examples to Main

Added examples to Main

module Main where

import Data.Maybe
import Debug.Trace
import Control.Apply
import Control.Monad.Eff
import Control.Monad.Aff
import Control.Monad.Aff.AVar
import Network.Wai
import Network.Wai.Internal
import Network.HTTP
import Network.Wai.Handler.Swai

body :: forall e. Request e -> Wai e String
body request = go ""
    where
        go message = do
            maybeRest <- request.body
            case maybeRest of
                 Just rest -> go (message ++ rest)
                 Nothing -> return message

-- Application echo-ing the received content
echo :: forall e. Application e
echo request respond = do
    message <- body request
    respond $ ResponseString status200 [] message

-- Application counting the number of requests received
count :: forall e. Wai e (Application e)
count = do
    count <- makeVar
    putVar count 0

    return $ \request respond -> do
        c <- takeVar count
        putVar count (c + 1)
        respond $ ResponseString status200 [] (show c)

-- Application serving a static index.html file
file :: forall e. Application e
file request respond = case request.rawPathInfo of
  "/"     -> respond index
  _       -> respond notFound

index = ResponseFile
    status200
    [contentType "text/html"]
    "./src/example/index.html"

notFound = ResponseString
    status404
    [contentType "text/plain"]
    "404 - Not Found"

-- Composed application, serve dynamic pages and fallback to static pages
composed = do
    counter <- count
    return \request respond -> case request.rawPathInfo of
        "/count" -> counter request respond
        "/echo"  -> echo request respond
        _        -> file request respond

main = runAff
        (\_           -> trace "error while launching aplpication")
        (\application -> trace "starting on port 3001..." *> run 3001 application)
        composed

module Main where

import Data.Maybe
import Debug.Trace
import Control.Monad.Eff
import Control.Monad.Aff
import Control.Monad.Aff.AVar
import Network.Wai
import Network.Wai.Internal
import Network.HTTP
import Network.Wai.Handler.Swai

body :: forall e. Request e -> Wai e String
body request = go ""
    where
        go message = do
            maybeRest <- request.body
            case maybeRest of
                 Just rest -> go (message ++ rest)
                 Nothing -> return message

file :: forall e. Application e
file request respond = respond $ ResponseFile status200 [contentType "text/html"] "./src/index.html"

echoApplication :: forall e. Application e
echoApplication request respond = do
    message <- body request
    respond $ ResponseString status200 [] message

countApplication :: forall e. AVar Number -> Application (trace :: Trace | e)
countApplication count request respond = do
    c <- takeVar count
    putVar count (c + 1)

    let message = "Request n°" ++ (show c)

    liftEff' $ trace message
    respond $ ResponseString status200 [] (show c)

main :: forall e. WaiEff (trace :: Trace | e)
main = do
    trace "running purescript-wai on port 3001..."
    run 3001 file


form events

form events

-- | Convenience functions for working with form elements.

module Halogen.HTML.Events.Forms
  ( onValueChanged
  , onChecked
  , onInput
  ) where

import DOM

import Data.Maybe
import Data.Either
import Data.Foreign
import Data.Foreign.Class
import Data.Traversable (traverse)

import Halogen.HTML.Events.Handler
import Halogen.HTML.Events.Unsafe (unsafeHandler')

import qualified Halogen.HTML as H

-- Attach event handler to event ```key``` with getting ```prop``` field
-- as an argument of handler
onSomething :: forall i value. (IsForeign value) =>
               String -> String -> (value -> EventHandler i) -> H.Attribute i
onSomething key prop f = unsafeHandler' (H.attributeName key)
                         \e -> traverse f (getProp prop e.target)
  where
    getProp :: String -> Node -> Maybe value
    getProp prop = either (const Nothing) Just <<< readProp prop <<< toForeign

onValueChanged :: forall value i. (IsForeign value) =>
                  (value -> EventHandler i) -> H.Attribute i
onValueChanged = onSomething "change" "value"

onChecked :: forall i. (Boolean -> EventHandler i) -> H.Attribute i
onChecked = onSomething "change" "checked"

onInput :: forall value i. (IsForeign value) =>
           (value -> EventHandler i) -> H.Attribute i
onInput = onSomething "input" "value"

-- | Convenience functions for working with form elements.

module Halogen.HTML.Events.Forms
  ( onValueChanged
  , onChecked
  ) where

import DOM

import Data.Maybe
import Data.Either
import Data.Foreign
import Data.Foreign.Class
import Data.Traversable (traverse)

import Halogen.HTML.Events.Handler
import Halogen.HTML.Events.Unsafe (unsafeHandler')

import qualified Halogen.HTML as H

-- | Attach an event handler which will produce an input when the value of an input field changes
-- |
-- | An input will not be produced if the value cannot be cast to the appropriate type.
onValueChanged :: forall value i. (IsForeign value) => (value -> EventHandler i) -> H.Attribute i
onValueChanged f = unsafeHandler' (H.attributeName "change") \e -> traverse f (readValue e.target)
  where
  readValue :: Node -> Maybe value
  readValue = either (const Nothing) Just <<< readProp "value" <<< toForeign

-- | Attach an event handler which will fire when a checkbox is checked or unchecked
onChecked :: forall i. (Boolean -> EventHandler i) -> H.Attribute i
onChecked f = unsafeHandler' (H.attributeName "change") \e -> traverse f (readChecked e.target)
  where
  readChecked :: Node -> Maybe Boolean
  readChecked = either (const Nothing) Just <<< readProp "checked" <<< toForeign