Squashed commit of the following:

Squashed commit of the following:

commit f2610404371c9e04443d697ad9f2b84e79f4702f
Author: Maxim Zimaliev <zimaliev@yandex.ru>
Date:   Mon Apr 20 17:31:08 2015 +0300

    readonly

commit 88dc6d28d1c3bf815696e5315f27292bf68e9c36
Author: Maxim Zimaliev <zimaliev@yandex.ru>
Date:   Mon Apr 20 17:27:18 2015 +0300

    ...

-- | This module provides the FFI definitions required to render HTML documents
-- | using the `virtual-dom` library.

module Halogen.Internal.VirtualDOM
  ( VTree()
  , Patch()
  , Props()
  , Widget()
  , emptyProps
  , prop
  , handlerProp
  , initProp
  , finalizerProp
  , createElement
  , diff
  , patch
  , vtext
  , vnode
  , vwidget
  , widget
  ) where

import DOM

import Data.Int
import Data.Maybe
import Data.Monoid
import Data.Nullable
import Data.Function

import Control.Monad.Eff
import Control.Monad.ST

-- | Virtual DOM nodes
data VTree

-- | Patch sets, used to update the DOM
data Patch

-- | Property collections
data Props

-- | A third-party widget
data Widget (eff :: # !) i

foreign import emptyProps
  "var emptyProps = {}" :: Props

-- | Create a property from a key/value pair.
-- |
-- | Properties named `data-*` will be added as attributes, and any other properties will
-- | be set directly.
-- |
-- | Users should use caution when creating custom attributes, and understand how they will
-- | be added to the DOM here.
foreign import prop
  "function prop(key, value) {\
  \  var props = {};\
  \  props[key] = value;\
  \  return props;\
  \}" :: forall value. Fn2 String value Props

-- | Create a property from an event handler
foreign import handlerProp
  "function handlerProp(key, f) {\
  \  var props = {};\
  \  var Hook = function () {};\
  \  Hook.prototype.callback = function(e) {\
  \    f(e)();\
  \  };\
  \  Hook.prototype.hook = function(node) {\
  \    node.addEventListener(key, this.callback);\
  \  };\
  \  Hook.prototype.unhook = function(node) {\
  \    node.removeEventListener(key, this.callback);\
  \  };\
  \  props['halogen-hook-' + key] = new Hook(f);\
  \  return props;\
  \}" :: forall eff event. Fn2 String (event -> Eff eff Unit) Props

-- | Create a property from an initializer
foreign import initProp
  "function initProp(f) {\
  \  var props = {};\
  \  var Hook = function () {};\
  \  Hook.prototype.hook = function(node, prop, prev) {\
  \    if (typeof prev === 'undefined') {\
  \      f();\
  \    };\
  \  };\
  \  props['halogen-init'] = new Hook(f);\
  \  return props;\
  \}" :: forall eff. Eff eff Unit -> Props

-- | Create a property from an finalizer
foreign import finalizerProp
  "function finalizerProp(f) {\
  \  var props = {};\
  \  var Hook = function () {};\
  \  Hook.prototype.hook = function() { };\
  \  Hook.prototype.unhook = function() {\
  \    f();\
  \  };\
  \  props['halogen-finalizer'] = new Hook(f);\
  \  return props;\
  \}" :: forall eff. Eff eff Unit -> Props

foreign import concatProps
  "function concatProps(p1, p2) {\
  \  var props = {};\
  \  for (var key in p1) {\
  \    props[key] = p1[key];\
  \  }\
  \  for (var key in p2) {\
  \    props[key] = p2[key];\
  \  }\
  \  return props;\
  \}" :: Fn2 Props Props Props

instance semigroupProps :: Semigroup Props where
  (<>) = runFn2 concatProps

instance monoidProps :: Monoid Props where
  mempty = emptyProps

-- | Create a DOM node from a virtual DOM tree
foreign import createElement
  "function createElement(vtree) {\
  \  return require('virtual-dom/create-element')(vtree);\
  \}" :: VTree -> Node

-- | Calculate the differences between two virtual DOM trees
foreign import diff
  "function diff(vtree1) {\
  \  return function createElement(vtree2) {\
  \    return require('virtual-dom/diff')(vtree1, vtree2);\
  \  };\
  \}" :: VTree -> VTree -> Patch

-- | Apply a set of patches to the DOM
foreign import patch
  "function patch(p) {\
  \  return function(node) {\
  \    return function() {\
  \      return require('virtual-dom/patch')(node, p);\
  \    };\
  \  };\
  \}" :: forall eff. Patch -> Node -> Eff (dom :: DOM | eff) Node

-- | Create a virtual DOM tree which represents a single text node
foreign import vtext
  "function vtext(s) {\
  \  var VText = require('virtual-dom/vnode/vtext');\
  \  return new VText(s);\
  \}" :: String -> VTree

-- | Create a virtual DOM tree which represents an element with properties
foreign import vnode
  "function vnode(name) {\
  \  return function(attr) {\
  \    return function(children) {\
  \      var VirtualNode = require('virtual-dom/vnode/vnode');\
  \      var props = {\
  \        attributes: {}\
  \      };\
  \      for (var key in attr) {\
  \        if ((key.indexOf('data-') === 0) || (key === 'readonly')) {\
  \          props.attributes[key] = attr[key];\
  \        } else {\
  \          props[key] = attr[key];\
  \        }\
  \      }\
  \      return new VirtualNode(name, props, children);\
  \    };\
  \  };\
  \}" :: String -> Props -> [VTree] -> VTree

-- | Create a virtual DOM tree from a `Widget`
foreign import vwidget
  "function vwidget(driver) {\
  \  return function(w) {\
  \    return w.create(driver);\
  \  };\
  \}" :: forall eff i. (i -> Eff eff Unit) -> Widget eff i -> VTree

foreign import mapWidget
  "function mapWidget(f) {\
  \  return function(w) {\
  \    return {\
  \      create: function(driver) {\
  \        return w.create(function(i) {\
  \          return driver(f(i));\
  \        });\
  \      }\
  \    };\
  \  };\
  \}" :: forall eff i j. (i -> j) -> Widget eff i -> Widget eff j

instance functorWidget :: Functor (Widget eff) where
  (<$>) = mapWidget

foreign import widget
  "function widget(ref, name, id, init, update, destroy) {\
  \  return {\
  \    create: function(driver) {\
  \      var Widget = function () {};\
  \      Widget.prototype.type = 'Widget';\
  \      Widget.prototype.name = name;\
  \      Widget.prototype.id = id;\
  \      Widget.prototype.ref = ref;\
  \      Widget.prototype.init = function(){\
  \        var state = init(driver)();\
  \        this.state = state.state;\
  \        return state.node;\
  \      };\
  \      Widget.prototype.update = function(prev, node) {\
  \        this.state = prev.state;\
  \        if (this.ref !== prev.ref) {\
  \          return update(prev.state)(node)();\
  \        } else {\
  \          return null;\
  \        }\
  \      };\
  \      Widget.prototype.destroy = function(node) {\
  \        destroy(this.state)(node)();\
  \      };\
  \      return new Widget();\
  \    }\
  \  };\
  \}" :: forall eff ref i s. Fn6 Int
                                 String
                                 String
                                 ((i -> Eff eff Unit) -> Eff eff { state :: s, node :: Node })
                                 (s -> Node -> Eff eff (Nullable Node))
                                 (s -> Node -> Eff eff Unit)
                                 (Widget eff i)

-- | This module provides the FFI definitions required to render HTML documents
-- | using the `virtual-dom` library.

module Halogen.Internal.VirtualDOM
  ( VTree()
  , Patch()
  , Props()
  , Widget()
  , emptyProps
  , prop
  , handlerProp
  , initProp
  , finalizerProp
  , createElement
  , diff
  , patch
  , vtext
  , vnode
  , vwidget
  , widget
  ) where

import DOM

import Data.Int
import Data.Maybe
import Data.Monoid
import Data.Nullable
import Data.Function

import Control.Monad.Eff
import Control.Monad.ST

-- | Virtual DOM nodes
data VTree

-- | Patch sets, used to update the DOM
data Patch

-- | Property collections
data Props

-- | A third-party widget
data Widget (eff :: # !) i

foreign import emptyProps
  "var emptyProps = {}" :: Props

-- | Create a property from a key/value pair.
-- |
-- | Properties named `data-*` will be added as attributes, and any other properties will
-- | be set directly.
-- |
-- | Users should use caution when creating custom attributes, and understand how they will
-- | be added to the DOM here.
foreign import prop
  "function prop(key, value) {\
  \  var props = {};\
  \  props[key] = value;\
  \  return props;\
  \}" :: forall value. Fn2 String value Props

-- | Create a property from an event handler
foreign import handlerProp
  "function handlerProp(key, f) {\
  \  var props = {};\
  \  var Hook = function () {};\
  \  Hook.prototype.callback = function(e) {\
  \    f(e)();\
  \  };\
  \  Hook.prototype.hook = function(node) {\
  \    node.addEventListener(key, this.callback);\
  \  };\
  \  Hook.prototype.unhook = function(node) {\
  \    node.removeEventListener(key, this.callback);\
  \  };\
  \  props['halogen-hook-' + key] = new Hook(f);\
  \  return props;\
  \}" :: forall eff event. Fn2 String (event -> Eff eff Unit) Props

-- | Create a property from an initializer
foreign import initProp
  "function initProp(f) {\
  \  var props = {};\
  \  var Hook = function () {};\
  \  Hook.prototype.hook = function(node, prop, prev) {\
  \    if (typeof prev === 'undefined') {\
  \      f();\
  \    };\
  \  };\
  \  props['halogen-init'] = new Hook(f);\
  \  return props;\
  \}" :: forall eff. Eff eff Unit -> Props

-- | Create a property from an finalizer
foreign import finalizerProp
  "function finalizerProp(f) {\
  \  var props = {};\
  \  var Hook = function () {};\
  \  Hook.prototype.hook = function() { };\
  \  Hook.prototype.unhook = function() {\
  \    f();\
  \  };\
  \  props['halogen-finalizer'] = new Hook(f);\
  \  return props;\
  \}" :: forall eff. Eff eff Unit -> Props

foreign import concatProps
  "function concatProps(p1, p2) {\
  \  var props = {};\
  \  for (var key in p1) {\
  \    props[key] = p1[key];\
  \  }\
  \  for (var key in p2) {\
  \    props[key] = p2[key];\
  \  }\
  \  return props;\
  \}" :: Fn2 Props Props Props

instance semigroupProps :: Semigroup Props where
  (<>) = runFn2 concatProps

instance monoidProps :: Monoid Props where
  mempty = emptyProps

-- | Create a DOM node from a virtual DOM tree
foreign import createElement
  "function createElement(vtree) {\
  \  return require('virtual-dom/create-element')(vtree);\
  \}" :: VTree -> Node

-- | Calculate the differences between two virtual DOM trees
foreign import diff
  "function diff(vtree1) {\
  \  return function createElement(vtree2) {\
  \    return require('virtual-dom/diff')(vtree1, vtree2);\
  \  };\
  \}" :: VTree -> VTree -> Patch

-- | Apply a set of patches to the DOM
foreign import patch
  "function patch(p) {\
  \  return function(node) {\
  \    return function() {\
  \      return require('virtual-dom/patch')(node, p);\
  \    };\
  \  };\
  \}" :: forall eff. Patch -> Node -> Eff (dom :: DOM | eff) Node

-- | Create a virtual DOM tree which represents a single text node
foreign import vtext
  "function vtext(s) {\
  \  var VText = require('virtual-dom/vnode/vtext');\
  \  return new VText(s);\
  \}" :: String -> VTree

-- | Create a virtual DOM tree which represents an element with properties
foreign import vnode
  "function vnode(name) {\
  \  return function(attr) {\
  \    return function(children) {\
  \      var VirtualNode = require('virtual-dom/vnode/vnode');\
  \      var props = {\
  \        attributes: {}\
  \      };\
  \      for (var key in attr) {\
  \        if (key.indexOf('data-') === 0) {\
  \          props.attributes[key] = attr[key];\
  \        } else {\
  \          props[key] = attr[key];\
  \        }\
  \      }\
  \      return new VirtualNode(name, props, children);\
  \    };\
  \  };\
  \}" :: String -> Props -> [VTree] -> VTree

-- | Create a virtual DOM tree from a `Widget`
foreign import vwidget
  "function vwidget(driver) {\
  \  return function(w) {\
  \    return w.create(driver);\
  \  };\
  \}" :: forall eff i. (i -> Eff eff Unit) -> Widget eff i -> VTree

foreign import mapWidget
  "function mapWidget(f) {\
  \  return function(w) {\
  \    return {\
  \      create: function(driver) {\
  \        return w.create(function(i) {\
  \          return driver(f(i));\
  \        });\
  \      }\
  \    };\
  \  };\
  \}" :: forall eff i j. (i -> j) -> Widget eff i -> Widget eff j

instance functorWidget :: Functor (Widget eff) where
  (<$>) = mapWidget

foreign import widget
  "function widget(ref, name, id, init, update, destroy) {\
  \  return {\
  \    create: function(driver) {\
  \      var Widget = function () {};\
  \      Widget.prototype.type = 'Widget';\
  \      Widget.prototype.name = name;\
  \      Widget.prototype.id = id;\
  \      Widget.prototype.ref = ref;\
  \      Widget.prototype.init = function(){\
  \        var state = init(driver)();\
  \        this.state = state.state;\
  \        return state.node;\
  \      };\
  \      Widget.prototype.update = function(prev, node) {\
  \        this.state = prev.state;\
  \        if (this.ref !== prev.ref) {\
  \          return update(prev.state)(node)();\
  \        } else {\
  \          return null;\
  \        }\
  \      };\
  \      Widget.prototype.destroy = function(node) {\
  \        destroy(this.state)(node)();\
  \      };\
  \      return new Widget();\
  \    }\
  \  };\
  \}" :: forall eff ref i s. Fn6 Int
                                 String
                                 String
                                 ((i -> Eff eff Unit) -> Eff eff { state :: s, node :: Node })
                                 (s -> Node -> Eff eff (Nullable Node))
                                 (s -> Node -> Eff eff Unit)
                                 (Widget eff i)


Default to newtype in `*SQLValue` classes instance chains.

module Database.PostgreSQL.Value where

import Prelude

import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (ExceptT, except, runExcept, runExceptT)
import Data.Array (foldl)
import Data.Array as Array
import Data.Bifunctor (lmap)
import Data.ByteString (ByteString)
import Data.Date (Date, canonicalDate, day, month, year)
import Data.DateTime.Instant (Instant, instant)
import Data.Decimal (Decimal)
import Data.Decimal as Decimal
import Data.Either (Either(..), note)
import Data.Enum (fromEnum, toEnum)
import Data.Identity (Identity)
import Data.Int (fromString)
import Data.JSDate (JSDate)
import Data.List (List)
import Data.List as List
import Data.List.NonEmpty (singleton)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.String (Pattern(..), split)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (sequence, traverse)
import Foreign (Foreign, ForeignError(..), MultipleErrors, isNull, readArray, readBoolean, readChar, readInt, readNumber, readString, renderForeignError, unsafeFromForeign, unsafeToForeign)
import Foreign.Internal (readObject)
import Foreign.Object (Object)

-- | Convert things to SQL values.
class ToSQLValue a where
    toSQLValue :: a -> Foreign

-- | Convert things from SQL values.
class FromSQLValue a where
    fromSQLValue :: Foreign -> Either String a

instance fromSQLValueBoolean :: FromSQLValue Boolean where
    fromSQLValue = lmap show <<< runExcept <<< readBoolean

else instance fromSQLValueChar :: FromSQLValue Char where
    fromSQLValue = lmap show <<< runExcept <<< readChar

else instance fromSQLValueInt :: FromSQLValue Int where
    fromSQLValue = lmap show <<< runExcept <<< readInt

else instance fromSQLValueNumber :: FromSQLValue Number where
    fromSQLValue = lmap show <<< runExcept <<< readNumber

else instance fromSQLValueString :: FromSQLValue String where
    fromSQLValue = lmap show <<< runExcept <<< readString

else instance fromSQLValueArray :: (FromSQLValue a) => FromSQLValue (Array a) where
    fromSQLValue = traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray

else instance fromSQLValueList :: (FromSQLValue a) => FromSQLValue (List a) where
    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray

else instance fromSQLValueByteString :: FromSQLValue ByteString where
    fromSQLValue x
        | unsafeIsBuffer x = pure $ unsafeFromForeign x
        | otherwise = throwError "FromSQLValue ByteString: not a buffer"

else instance fromSQLValueInstant :: FromSQLValue Instant where
    fromSQLValue v = do
      t <- instantFromString Left Right v
      note ("Instant construction failed for given timestamp: " <> show t) $ instant (Milliseconds t)

else instance fromSQLValueDate :: FromSQLValue Date where
    fromSQLValue v = do
        s <- lmap show $ runExcept (readString v)
        let
            msg = "Date parsing failed for value: " <> s
        case split (Pattern "-") s of
            [y, m, d] -> do
                let
                  result = canonicalDate
                    <$> (toEnum =<< fromString y)
                    <*> (toEnum =<< fromString m)
                    <*> (toEnum =<< fromString d)
                note msg result
            _ -> Left msg

else instance fromSQLValueJSDate :: FromSQLValue JSDate where
    fromSQLValue = Right <<< unsafeFromForeign

else instance fromSQLValueMaybe :: (FromSQLValue a) => FromSQLValue (Maybe a) where
    fromSQLValue x | isNull x  = pure Nothing
                   | otherwise = Just <$> fromSQLValue x

else instance fromSQLValueForeign :: FromSQLValue Foreign where
    fromSQLValue = pure

else instance fromSQLValueObject ∷ FromSQLValue a ⇒ FromSQLValue (Object a) where
  fromSQLValue sql = lmap showErr $ unwrap $ runExceptT main
    where
    showErr ∷ MultipleErrors → String
    showErr e = foldl (\a x → a <> renderForeignError x <> " ") "" e
    main ∷ ExceptT MultipleErrors Identity (Object a)
    main = do
      objF ∷ Object Foreign <- readObject sql
      let eso = sequence $ map fromSQLValue objF
      let emo = lmap (singleton <<< ForeignError) eso
      except emo
else instance fromSQLValueDecimal :: FromSQLValue Decimal where
    fromSQLValue v = do
        s <- lmap show $ runExcept (readString v)
        note ("Decimal literal parsing failed: " <> s) (Decimal.fromString s)

else instance fromSQLValueNewtype ∷ (Newtype a b, FromSQLValue b) ⇒ FromSQLValue a where
    fromSQLValue = map wrap <<< fromSQLValue

instance toSQLValueBoolean :: ToSQLValue Boolean where
    toSQLValue = unsafeToForeign

else instance toSQLValueChar :: ToSQLValue Char where
    toSQLValue = unsafeToForeign

else instance toSQLValueInt :: ToSQLValue Int where
    toSQLValue = unsafeToForeign

else instance toSQLValueNumber :: ToSQLValue Number where
    toSQLValue = unsafeToForeign

else instance toSQLValueString :: ToSQLValue String where
    toSQLValue = unsafeToForeign

else instance toSQLValueArray :: (ToSQLValue a) => ToSQLValue (Array a) where
    toSQLValue = unsafeToForeign <<< map toSQLValue

else instance toSQLValueList :: (ToSQLValue a) => ToSQLValue (List a) where
    toSQLValue = unsafeToForeign <<< Array.fromFoldable <<< map toSQLValue

else instance toSQLValueByteString :: ToSQLValue ByteString where
    toSQLValue = unsafeToForeign

else instance toSQLValueInstant :: ToSQLValue Instant where
    toSQLValue = instantToString

else instance toSQLValueDate :: ToSQLValue Date where
    toSQLValue date =
        let
            y = fromEnum $ year date
            m = fromEnum $ month date
            d = fromEnum $ day date
        in
            unsafeToForeign $ show y <> "-" <> show m <> "-" <> show d

else instance toSQLValueJSDate :: ToSQLValue JSDate where
    toSQLValue = unsafeToForeign

else instance toSQLValueMaybe :: (ToSQLValue a) => ToSQLValue (Maybe a) where
    toSQLValue Nothing = null
    toSQLValue (Just x) = toSQLValue x

else instance toSQLValueForeign :: ToSQLValue Foreign where
    toSQLValue = identity

else instance toSQLValueObject ∷ ToSQLValue a ⇒ ToSQLValue (Object a) where
  toSQLValue = unsafeToForeign

else instance toSQLValueDecimal :: ToSQLValue Decimal where
    toSQLValue = Decimal.toString >>> unsafeToForeign

else instance toSQLValueNewtype ∷ (Newtype a b, ToSQLValue b) ⇒ ToSQLValue a where
    toSQLValue = unwrap >>> toSQLValue

foreign import null :: Foreign
foreign import instantToString :: Instant -> Foreign
foreign import instantFromString :: (String -> Either String Number) -> (Number -> Either String Number) -> Foreign -> Either String Number
foreign import unsafeIsBuffer :: ∀ a. a -> Boolean

module Database.PostgreSQL.Value where

import Prelude

import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (ExceptT, except, runExcept, runExceptT)
import Data.Array (foldl)
import Data.Array as Array
import Data.Bifunctor (lmap)
import Data.ByteString (ByteString)
import Data.Date (Date, canonicalDate, day, month, year)
import Data.DateTime.Instant (Instant, instant)
import Data.Decimal (Decimal)
import Data.Decimal as Decimal
import Data.Either (Either(..), note)
import Data.Enum (fromEnum, toEnum)
import Data.Identity (Identity)
import Data.Int (fromString)
import Data.JSDate (JSDate)
import Data.List (List)
import Data.List as List
import Data.List.NonEmpty (singleton)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.String (Pattern(..), split)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (sequence, traverse)
import Foreign (Foreign, ForeignError(..), MultipleErrors, isNull, readArray, readBoolean, readChar, readInt, readNumber, readString, renderForeignError, unsafeFromForeign, unsafeToForeign)
import Foreign.Internal (readObject)
import Foreign.Object (Object)

-- | Convert things to SQL values.
class ToSQLValue a where
    toSQLValue :: a -> Foreign

-- | Convert things from SQL values.
class FromSQLValue a where
    fromSQLValue :: Foreign -> Either String a

instance toSQLValueBoolean :: ToSQLValue Boolean where
    toSQLValue = unsafeToForeign

instance fromSQLValueBoolean :: FromSQLValue Boolean where
    fromSQLValue = lmap show <<< runExcept <<< readBoolean

instance toSQLValueChar :: ToSQLValue Char where
    toSQLValue = unsafeToForeign

instance fromSQLValueChar :: FromSQLValue Char where
    fromSQLValue = lmap show <<< runExcept <<< readChar

instance toSQLValueInt :: ToSQLValue Int where
    toSQLValue = unsafeToForeign

instance fromSQLValueInt :: FromSQLValue Int where
    fromSQLValue = lmap show <<< runExcept <<< readInt

instance toSQLValueNumber :: ToSQLValue Number where
    toSQLValue = unsafeToForeign

instance fromSQLValueNumber :: FromSQLValue Number where
    fromSQLValue = lmap show <<< runExcept <<< readNumber

instance toSQLValueString :: ToSQLValue String where
    toSQLValue = unsafeToForeign

instance fromSQLValueString :: FromSQLValue String where
    fromSQLValue = lmap show <<< runExcept <<< readString

instance toSQLValueArray :: (ToSQLValue a) => ToSQLValue (Array a) where
    toSQLValue = unsafeToForeign <<< map toSQLValue

instance fromSQLValueArray :: (FromSQLValue a) => FromSQLValue (Array a) where
    fromSQLValue = traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray

instance toSQLValueList :: (ToSQLValue a) => ToSQLValue (List a) where
    toSQLValue = unsafeToForeign <<< Array.fromFoldable <<< map toSQLValue

instance fromSQLValueList :: (FromSQLValue a) => FromSQLValue (List a) where
    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< lmap show <<< runExcept <<< readArray

instance toSQLValueByteString :: ToSQLValue ByteString where
    toSQLValue = unsafeToForeign

instance fromSQLValueByteString :: FromSQLValue ByteString where
    fromSQLValue x
        | unsafeIsBuffer x = pure $ unsafeFromForeign x
        | otherwise = throwError "FromSQLValue ByteString: not a buffer"

instance toSQLValueInstant :: ToSQLValue Instant where
    toSQLValue = instantToString

instance fromSQLValueInstant :: FromSQLValue Instant where
    fromSQLValue v = do
      t <- instantFromString Left Right v
      note ("Instant construction failed for given timestamp: " <> show t) $ instant (Milliseconds t)

instance toSQLValueDate :: ToSQLValue Date where
    toSQLValue date =
        let
            y = fromEnum $ year date
            m = fromEnum $ month date
            d = fromEnum $ day date
        in
            unsafeToForeign $ show y <> "-" <> show m <> "-" <> show d

instance fromSQLValueDate :: FromSQLValue Date where
    fromSQLValue v = do
        s <- lmap show $ runExcept (readString v)
        let
            msg = "Date parsing failed for value: " <> s
        case split (Pattern "-") s of
            [y, m, d] -> do
                let
                  result = canonicalDate
                    <$> (toEnum =<< fromString y)
                    <*> (toEnum =<< fromString m)
                    <*> (toEnum =<< fromString d)
                note msg result
            _ -> Left msg

instance toSQLValueJSDate :: ToSQLValue JSDate where
    toSQLValue = unsafeToForeign

instance fromSQLValueJSDate :: FromSQLValue JSDate where
    fromSQLValue = Right <<< unsafeFromForeign

instance toSQLValueMaybe :: (ToSQLValue a) => ToSQLValue (Maybe a) where
    toSQLValue Nothing = null
    toSQLValue (Just x) = toSQLValue x

instance fromSQLValueMaybe :: (FromSQLValue a) => FromSQLValue (Maybe a) where
    fromSQLValue x | isNull x  = pure Nothing
                   | otherwise = Just <$> fromSQLValue x

instance toSQLValueForeign :: ToSQLValue Foreign where
    toSQLValue = identity

instance fromSQLValueForeign :: FromSQLValue Foreign where
    fromSQLValue = pure

instance toSQLValueObject ∷ ToSQLValue a ⇒ ToSQLValue (Object a) where
  toSQLValue = unsafeToForeign

instance fromSQLValueObject ∷ FromSQLValue a ⇒ FromSQLValue (Object a) where
  fromSQLValue sql = lmap showErr $ unwrap $ runExceptT main
    where
    showErr ∷ MultipleErrors → String
    showErr e = foldl (\a x → a <> renderForeignError x <> " ") "" e
    main ∷ ExceptT MultipleErrors Identity (Object a)
    main = do
      objF ∷ Object Foreign <- readObject sql
      let eso = sequence $ map fromSQLValue objF
      let emo = lmap (singleton <<< ForeignError) eso
      except emo

instance toSQLValueDecimal :: ToSQLValue Decimal where
    toSQLValue = Decimal.toString >>> unsafeToForeign

instance fromSQLValueDecimal :: FromSQLValue Decimal where
    fromSQLValue v = do
        s <- lmap show $ runExcept (readString v)
        note ("Decimal literal parsing failed: " <> s) (Decimal.fromString s)

foreign import null :: Foreign
foreign import instantToString :: Instant -> Foreign
foreign import instantFromString :: (String -> Either String Number) -> (Number -> Either String Number) -> Foreign -> Either String Number
foreign import unsafeIsBuffer :: ∀ a. a -> Boolean


Add Monad magic

Add Monad magic

module TextCursor.Element.Type
    ( TextCursorElement(..)
    , htmlTextCursorElementToHTMLElement
    , read, readEventTarget
    , validate, validate'
    , lookupAndValidate
    , lookupValidateAndDo
    ) where

import Prelude (Unit, bind, map, pure, (<$>), (<<<), (>>=))
import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.Array (elem)
import Data.Traversable (traverse_)
import Data.Foreign (F, Foreign, toForeign)
import Control.Alternative ((<|>))
import Control.Monad.Except (runExcept)
import Control.Monad.Eff (Eff)
import DOM (DOM)
import DOM.Event.Event (Event, target)
import DOM.HTML.Types
    ( HTMLElement, HTMLInputElement, HTMLTextAreaElement
    , htmlDocumentToNonElementParentNode
    , htmlInputElementToHTMLElement
    , htmlTextAreaElementToHTMLElement
    , readHTMLInputElement
    , readHTMLTextAreaElement
    )
import DOM.HTML (window)
import DOM.HTML.Window (document)
import DOM.HTML.HTMLInputElement (type_)
import DOM.Node.Types (ElementId)
import DOM.Node.NonElementParentNode (getElementById)

data TextCursorElement = Input HTMLInputElement | TextArea HTMLTextAreaElement

htmlTextCursorElementToHTMLElement :: TextCursorElement -> HTMLElement
htmlTextCursorElementToHTMLElement (Input e) = htmlInputElementToHTMLElement e
htmlTextCursorElementToHTMLElement (TextArea e) = htmlTextAreaElementToHTMLElement e

read :: Foreign -> F TextCursorElement
read e = ta <|> i
    where
        -- prefer TextArea, which needs no validation
        ta = TextArea <$> readHTMLTextAreaElement e
        i = Input <$> readHTMLInputElement e

readEventTarget :: Event -> F TextCursorElement
readEventTarget = read <<< toForeign <<< target

validate :: forall eff. TextCursorElement -> Eff ( dom :: DOM | eff ) (Maybe TextCursorElement)
validate = case _ of
    tae@(TextArea e) -> pure (Just tae)
    Input e -> map Input <$> validateInput e
    where
        validateInput :: HTMLInputElement -> Eff ( dom :: DOM | eff ) (Maybe HTMLInputElement)
        validateInput e = do
            inputtype <- type_ e
            pure if elem inputtype whitelist
                then Just e
                else Nothing
            where
                whitelist = ["", "text", "email", "search", "url"]

validate' :: forall eff. F TextCursorElement -> Eff ( dom :: DOM | eff ) (Maybe TextCursorElement)
validate' f =
    case runExcept f of
        Left _ -> pure Nothing
        Right e -> validate e

lookupAndValidate :: forall eff. ElementId -> Eff ( dom :: DOM | eff ) (Maybe TextCursorElement)
lookupAndValidate name = do
    win <- window
    doc <- htmlDocumentToNonElementParentNode <$> document win
    getElementById name doc >>= validate' <<< read <<< toForeign

lookupValidateAndDo :: forall eff. ElementId -> (TextCursorElement -> Eff ( dom :: DOM | eff ) Unit) -> Eff ( dom :: DOM | eff ) Unit
lookupValidateAndDo name action =
    lookupAndValidate name >>= traverse_ action

module TextCursor.Element.Type
    ( TextCursorElement(..)
    , htmlTextCursorElementToHTMLElement
    , read, readEventTarget
    , validate, validate'
    , lookupAndValidate
    , lookupValidateAndDo
    ) where

import Prelude (Unit, bind, map, pure, unit, (<$>), (<<<))
import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.Array (elem)
import Data.Foreign (F, Foreign, toForeign)
import Control.Alternative ((<|>))
import Control.Monad.Except (runExcept)
import Control.Monad.Eff (Eff)
import DOM (DOM)
import DOM.Event.Event (Event, target)
import DOM.HTML.Types
    ( HTMLElement, HTMLInputElement, HTMLTextAreaElement
    , htmlDocumentToNonElementParentNode
    , htmlInputElementToHTMLElement
    , htmlTextAreaElementToHTMLElement
    , readHTMLInputElement
    , readHTMLTextAreaElement
    )
import DOM.HTML (window)
import DOM.HTML.Window (document)
import DOM.HTML.HTMLInputElement (type_)
import DOM.Node.Types (ElementId)
import DOM.Node.NonElementParentNode (getElementById)

data TextCursorElement = Input HTMLInputElement | TextArea HTMLTextAreaElement

htmlTextCursorElementToHTMLElement :: TextCursorElement -> HTMLElement
htmlTextCursorElementToHTMLElement (Input e) = htmlInputElementToHTMLElement e
htmlTextCursorElementToHTMLElement (TextArea e) = htmlTextAreaElementToHTMLElement e

read :: Foreign -> F TextCursorElement
read e = ta <|> i
    where
        -- prefer TextArea, which needs no validation
        ta = TextArea <$> readHTMLTextAreaElement e
        i = Input <$> readHTMLInputElement e

readEventTarget :: Event -> F TextCursorElement
readEventTarget = read <<< toForeign <<< target

validate :: forall eff. TextCursorElement -> Eff ( dom :: DOM | eff ) (Maybe TextCursorElement)
validate = case _ of
    tae@(TextArea e) -> pure (Just tae)
    Input e -> map {- Eff -} (map {- Maybe -} Input) (validateInput e)
    where
        validateInput :: HTMLInputElement -> Eff ( dom :: DOM | eff ) (Maybe HTMLInputElement)
        validateInput e = do
            inputtype <- type_ e
            pure if elem inputtype whitelist
                then Just e
                else Nothing
            where
                whitelist = ["", "text", "email", "search", "url"]

validate' :: forall eff. F TextCursorElement -> Eff ( dom :: DOM | eff ) (Maybe TextCursorElement)
validate' f =
    case runExcept f of
        Left _ -> pure Nothing
        Right e -> validate e

lookupAndValidate :: forall eff. ElementId -> Eff ( dom :: DOM | eff ) (Maybe TextCursorElement)
lookupAndValidate name = do
    win <- window
    doc <- htmlDocumentToNonElementParentNode <$> document win
    elemm <- getElementById name doc
    case elemm of
        Nothing -> pure Nothing
        Just e -> validate' (read (toForeign e))

lookupValidateAndDo :: forall eff. ElementId -> (TextCursorElement -> Eff ( dom :: DOM | eff ) Unit) -> Eff ( dom :: DOM | eff ) Unit
lookupValidateAndDo name action = do
    textcursorm <- lookupAndValidate name
    case textcursorm of
        Nothing -> pure unit
        Just tc -> action tc


Fix test for overwriting a location

Fix test for overwriting a location

module Test.WriteGenericSpec (writeGenericSpec) where

import Prelude (Unit, bind, ($), class Show, class Eq)

import Control.Monad.Aff (Aff(), launchAff, liftEff' )
import Control.Monad.Aff.AVar (AVAR(), makeVar, takeVar, putVar)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Error.Class (throwError)
import Data.Maybe (Maybe(Nothing))
import Data.Either (Either(Left, Right))
import Web.Firebase.Monad.Aff (fb2error, onceValue, push, set)
import Web.Firebase.UnsafeRef (refFor)
import Web.Firebase.DataSnapshot as D
import Web.Firebase.Types as FBT
import Test.Spec                  (describe, it, Spec())
import Test.Spec.Assertions       (shouldEqual, shouldNotEqual)
import Data.Foreign.Generic  (Options, defaultOptions, toForeignGeneric, readGeneric)
import Data.Generic (class Generic, gShow, gEq)

entriesRef :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
entriesRef = refFor "https://purescript-spike.firebaseio.com/entries/generic"

setRef :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
setRef = refFor "https://purescript-spike.firebaseio.com/entries/wecanset/generic/paths"

jsonOptions :: Options
jsonOptions = defaultOptions {unwrapNewtypes = true}

data MyBoolean = Yes | No | Perhaps | DontKnowYet

derive instance genericMyBoolean :: Generic MyBoolean

instance showMyBoolean :: Show MyBoolean where
  show = gShow

instance eqMyBoolean :: Eq MyBoolean where
  eq = gEq

newtype MyInvitation = MyInvitation {invitee :: String
                                , willAttend :: MyBoolean }

derive instance genericMyInvitation :: Generic MyInvitation

instance showMyInvitation :: Show MyInvitation where
  show = gShow

instance eqMyInvitation :: Eq MyInvitation where
  eq = gEq

noShow :: MyInvitation
noShow = MyInvitation {invitee: "someone", willAttend: No}

dontKnow :: MyInvitation
dontKnow = MyInvitation {invitee: "mr bean", willAttend: DontKnowYet }

-- | We chose to test Eff functions indirectly through Aff -
-- Eff tests were as least as complicated as the implementation
-- see Authorization tests for errors when writing
-- tests are with generic - default toForeign only works for very simple objects (e.g. strings and ints as values, Abstract Data Types for instance.
-- Once you get to maps, you are on your own - manual marshalling - maps don't have a Generic instance.
writeGenericSpec ::  forall eff. Spec ( firebase :: FBT.FirebaseEff, err :: EXCEPTION | eff) Unit
writeGenericSpec = do
  describe "Writing with Generics" do
      it "can add an ADT to a list" do
        location <- entriesRef
        newChildRef <- push (toForeignGeneric jsonOptions Yes) location
        snap <- onceValue newChildRef
        (D.key snap) `shouldNotEqual` Nothing
        (readGeneric jsonOptions (D.val snap)) `shouldEqual` (Right Yes)

      it "can overwrite an existing ADT" do
        let secondValue = {success: "second value"}
        location <- entriesRef
        newChildRef <- push (toForeignGeneric jsonOptions Yes) location
        set (toForeignGeneric jsonOptions No) newChildRef
        snap <- onceValue newChildRef
        (readGeneric jsonOptions (D.val snap)) `shouldEqual` (Right No)
      it "can read what push writes in new location" do
          location <- entriesRef
          newLocation <- push (toForeignGeneric jsonOptions noShow) location
          snap <- onceValue newLocation
          (readGeneric jsonOptions (D.val snap)) `shouldEqual` (Right noShow)
      it "can read what set writes in new location " do
          location <- setRef
          set (toForeignGeneric jsonOptions dontKnow) location
          snap <- onceValue location
          (readGeneric jsonOptions (D.val snap)) `shouldEqual` (Right dontKnow)

module Test.WriteGenericSpec (writeGenericSpec) where

import Prelude (Unit, bind, ($), class Show, class Eq)

import Control.Monad.Aff (Aff(), launchAff, liftEff' )
import Control.Monad.Aff.AVar (AVAR(), makeVar, takeVar, putVar)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Error.Class (throwError)
import Data.Maybe (Maybe(Nothing))
import Data.Either (Either(Left, Right))
import Web.Firebase.Monad.Aff (fb2error, onceValue, push, set)
import Web.Firebase.UnsafeRef (refFor)
import Web.Firebase.DataSnapshot as D
import Web.Firebase.Types as FBT
import Test.Spec                  (describe, it, Spec())
import Test.Spec.Assertions       (shouldEqual, shouldNotEqual)
import Data.Foreign.Generic  (Options, defaultOptions, toForeignGeneric, readGeneric)
import Data.Generic (class Generic, gShow, gEq)

entriesRef :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
entriesRef = refFor "https://purescript-spike.firebaseio.com/entries/generic"

setRef :: forall eff. Aff (firebase :: FBT.FirebaseEff | eff) FBT.Firebase
setRef = refFor "https://purescript-spike.firebaseio.com/entries/wecanset/generic/paths"

jsonOptions :: Options
jsonOptions = defaultOptions {unwrapNewtypes = true}

data MyBoolean = Yes | No | Perhaps | DontKnowYet

derive instance genericMyBoolean :: Generic MyBoolean

instance showMyBoolean :: Show MyBoolean where
  show = gShow

instance eqMyBoolean :: Eq MyBoolean where
  eq = gEq

newtype MyInvitation = MyInvitation {invitee :: String
                                , willAttend :: MyBoolean }

derive instance genericMyInvitation :: Generic MyInvitation

instance showMyInvitation :: Show MyInvitation where
  show = gShow

instance eqMyInvitation :: Eq MyInvitation where
  eq = gEq

noShow :: MyInvitation
noShow = MyInvitation {invitee: "someone", willAttend: No}

dontKnow :: MyInvitation
dontKnow = MyInvitation {invitee: "mr bean", willAttend: DontKnowYet }

-- | We chose to test Eff functions indirectly through Aff -
-- Eff tests were as least as complicated as the implementation
-- see Authorization tests for errors when writing
-- tests are with generic - default toForeign only works for very simple objects (e.g. strings and ints as values, Abstract Data Types for instance.
-- Once you get to maps, you are on your own - manual marshalling - maps don't have a Generic instance.
writeGenericSpec ::  forall eff. Spec ( firebase :: FBT.FirebaseEff, err :: EXCEPTION | eff) Unit
writeGenericSpec = do
  describe "Writing objects with toForeignGeneric" do
      it "can add an ADT to a list" do
        location <- entriesRef
        newChildRef <- push (toForeignGeneric jsonOptions Yes) location
        snap <- onceValue newChildRef
        (D.key snap) `shouldNotEqual` Nothing
        (readGeneric jsonOptions (D.val snap)) `shouldEqual` (Right Yes)

      it "can overwrite an existing ADT" do
        let secondValue = {success: "second value"}
        location <- entriesRef
        newChildRef <- push (toForeignGeneric jsonOptions Yes) location
        set (toForeignGeneric jsonOptions No) location
        snap <- onceValue newChildRef
        (readGeneric jsonOptions (D.val snap)) `shouldEqual` (Right No)
      it "can read what push writes in new location" do
          location <- entriesRef
          newLocation <- push (toForeignGeneric jsonOptions noShow) location
          snap <- onceValue newLocation
          (readGeneric jsonOptions (D.val snap)) `shouldEqual` (Right noShow)
      it "can read what set writes in new location " do
          location <- setRef
          set (toForeignGeneric jsonOptions dontKnow) location
          snap <- onceValue location
          (readGeneric jsonOptions (D.val snap)) `shouldEqual` (Right dontKnow)


Create Cytoscape in Halogen main component

module Genetics.Browser.UI.Container
       where

import Prelude
import Genetics.Browser.Biodalliance as Biodalliance
import Genetics.Browser.Cytoscape as Cytoscape
import Genetics.Browser.Renderer.GWAS as GWAS
import Genetics.Browser.Renderer.Lineplot as QTL
import Genetics.Browser.UI.Biodalliance as UIBD
import Genetics.Browser.UI.Cytoscape as UICy
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Data.Const (Const(..))
import Data.Either.Nested (Either2)
import Data.Functor.Coproduct.Nested (type (<\/>), Coproduct2)
import Data.Maybe (Maybe(..))
import Data.Newtype (wrap)
import Genetics.Browser.Renderer.Lineplot (LinePlotConfig)
import Genetics.Browser.Source.QTL (fetch)
import Genetics.Browser.Types (BD, Biodalliance, CY, Cytoscape, Renderer)
import Genetics.Browser.Units (Bp(..))
import Global.Unsafe (unsafeStringify)
import Halogen.Component.ChildPath as CP
import Halogen.VDom.Driver (runUI)

qtlGlyphify :: LinePlotConfig -> Renderer
qtlGlyphify = QTL.render

gwasGlyphify :: Renderer
gwasGlyphify = GWAS.render

cytoscape = Cytoscape.cytoscape
setOn = Cytoscape.setOn

ajaxCytoscape = Cytoscape.ajaxCytoscape
ajaxAddEles = Cytoscape.ajaxAddEles
filterElements = Cytoscape.filterElements
elesOn = Cytoscape.elesOn
cyFilter = Cytoscape.cyFilter
cyReset = Cytoscape.resetFilter

type State = Unit

data Query a
  = Nop a
  | SetBD Biodalliance a
  | BDScroll Number a
  | BDJump String Number Number a
  | CreateCy String a
  | ResetCy a

type ChildSlot = Either2 UIBD.Slot UICy.Slot

type ChildQuery = UIBD.Query <\/> UICy.Query <\/> Const Void

-- type Effects e = _

component :: ∀ eff. H.Component HH.HTML Query Unit Void (Aff _)
component =
  H.parentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  initialState :: State
  initialState = unit

  render :: State -> H.ParentHTML Query ChildQuery ChildSlot (Aff _)
  render state =
    HH.div_
      [ HH.button
        [  HE.onClick (HE.input_ (BDScroll (-1000000.0)))
        ]
        [ HH.text "Scroll left 1MBp" ]
      , HH.button
        [  HE.onClick (HE.input_ (BDScroll 1000000.0))
        ]
        [ HH.text "Scroll right 1MBp" ]
      , HH.button
        [  HE.onClick (HE.input_ ResetCy)
        ]
        [ HH.text "Reset cytoscape" ]
      , HH.slot' CP.cp1 UIBD.Slot UIBD.component unit absurd
      , HH.slot' CP.cp2 UICy.Slot UICy.component unit absurd
      ]

  eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Void (Aff _)
  eval = case _ of
    Nop next -> do
      pure next
    SetBD bd next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Initialize bd)
      pure next
    BDScroll dist next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Scroll dist)
      pure next
    BDJump chr xl xr next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Jump chr xl xr)
      pure next
    CreateCy div next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action (UICy.Initialize div)
      pure next
    ResetCy next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action UICy.Reset
      pure next

-- main :: Eff (HA.HalogenEffects ()) Unit
-- TODO: creating BD should be in a promise or something.
main :: Biodalliance -> Eff _ Unit
main bd = HA.runHalogenAff do
  liftEff $ log "running main"
  HA.awaitLoad
  el <- HA.selectElement (wrap "#psgbHolder")
  case el of
    Nothing -> do
      liftEff $ log "no element for browser!"
    Just el' -> do
      io <- runUI component unit el'
      liftEff $ log "attaching BD"
      io.query $ H.action (SetBD bd)
      liftEff $ log "attached!"
      liftEff $ log "moving to chr 3"
      liftEff $ log ":("
      liftEff $ log "well this is crazy"
      -- io.query $ H.action (BDJump "Chr3" 1000000.0 10000000.0)
      liftEff $ log "wait it blocks after moving???"
      liftEff $ log "creating Cy.js"
      io.query $ H.action (CreateCy "http://localhost:8080/eles.json")
      liftEff $ log "created cy!"

module Genetics.Browser.UI.Container
       where

import Prelude
import Genetics.Browser.Biodalliance as Biodalliance
import Genetics.Browser.Cytoscape as Cytoscape
import Genetics.Browser.Renderer.GWAS as GWAS
import Genetics.Browser.Renderer.Lineplot as QTL
import Genetics.Browser.UI.Biodalliance as UIBD
import Genetics.Browser.UI.Cytoscape as UICy
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Data.Const (Const(..))
import Data.Either.Nested (Either2)
import Data.Functor.Coproduct.Nested (type (<\/>), Coproduct2)
import Data.Maybe (Maybe(..))
import Data.Newtype (wrap)
import Genetics.Browser.Renderer.Lineplot (LinePlotConfig)
import Genetics.Browser.Source.QTL (fetch)
import Genetics.Browser.Types (BD, Biodalliance, CY, Cytoscape, Renderer)
import Genetics.Browser.Units (Bp(..))
import Global.Unsafe (unsafeStringify)
import Halogen.Component.ChildPath as CP
import Halogen.VDom.Driver (runUI)

qtlGlyphify :: LinePlotConfig -> Renderer
qtlGlyphify = QTL.render

gwasGlyphify :: Renderer
gwasGlyphify = GWAS.render

cytoscape = Cytoscape.cytoscape
setOn = Cytoscape.setOn

ajaxCytoscape = Cytoscape.ajaxCytoscape
ajaxAddEles = Cytoscape.ajaxAddEles
filterElements = Cytoscape.filterElements
elesOn = Cytoscape.elesOn
cyFilter = Cytoscape.cyFilter
cyReset = Cytoscape.resetFilter

type State = Unit

data Query a
  = Nop a
  | SetBD Biodalliance a
  | BDScroll Number a
  | BDJump String Number Number a
  | CreateCy String a

type ChildSlot = Either2 UIBD.Slot UICy.Slot

type ChildQuery = UIBD.Query <\/> UICy.Query <\/> Const Void

-- type Effects e = _

component :: ∀ eff. H.Component HH.HTML Query Unit Void (Aff _)
component =
  H.parentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  initialState :: State
  initialState = unit

  render :: State -> H.ParentHTML Query ChildQuery ChildSlot (Aff _)
  render state =
    HH.div_
      [ HH.button
        [  HE.onClick (HE.input_ (BDScroll (-1000000.0)))
        ]
        [ HH.text "Scroll left 1MBp" ]
      , HH.button
        [  HE.onClick (HE.input_ (BDScroll 1000000.0))
        ]
        [ HH.text "Scroll right 1MBp" ]
      , HH.slot' CP.cp1 UIBD.Slot UIBD.component unit absurd
      ]

  eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Void (Aff _)
  eval = case _ of
    Nop next -> do
      pure next
    SetBD bd next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Initialize bd)
      pure next
    BDScroll dist next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Scroll dist)
      pure next
    BDJump chr xl xr next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Jump chr xl xr)
      pure next
    CreateCy div next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action (UICy.Initialize div)
      pure next

-- main :: Eff (HA.HalogenEffects ()) Unit
-- TODO: creating BD should be in a promise or something.
main :: Biodalliance -> Eff _ Unit
main bd = HA.runHalogenAff do
  liftEff $ log "running main"
  -- _ <- HA.awaitLoad
  el <- HA.selectElement (wrap "#psgbHolder")
  case el of
    Nothing -> do
      liftEff $ log "no element for browser!"
    Just el' -> do
      io <- runUI component unit el'
      liftEff $ log "attaching BD"
      io.query $ H.action (SetBD bd)
      liftEff $ log "attached!"
      liftEff $ log "moving to chr 3"
      liftEff $ log ":("
      liftEff $ log "well this is crazy"
      io.query $ H.action (BDJump "Chr3" 1000000.0 10000000.0)
      liftEff $ log "wait it blocks after moving???"
      liftEff $ log "creating Cy.js"
      io.query $ H.action (CreateCy "cyHolder")
      liftEff $ log "created cy!"


Allow large app json starting with { and ending with }

{-
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.FileSystem.Component
  ( module SlamData.FileSystem.Component.State
  , module SlamData.FileSystem.Component.Query
  , module SlamData.FileSystem.Component.Install
  , comp
  ) where

import SlamData.Prelude

import Control.UI.Browser (setLocation, locationString, clearValue)
import Control.UI.Browser.Event as Be
import Control.UI.File as Cf

import Data.Argonaut (jsonParser, jsonEmptyObject)
import Data.Array (head, last, mapMaybe, filter)
import Data.Foldable as F
import Data.Lens ((.~), preview)
import Data.MediaType.Common (textCSV, applicationJSON)
import Data.Path.Pathy (rootDir, (</>), dir, file, parentDir)
import Data.String as S
import Data.String.Regex as Rgx

import Halogen as H
import Halogen.Component.ChildPath (ChildPath, injSlot, prjQuery, injQuery)
import Halogen.Component.Utils (subscribeToBus')
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP

import Quasar.Data (QData(..))

import SlamData.Config as Config
import SlamData.Monad (Slam)
import SlamData.FileSystem.Breadcrumbs.Component as Breadcrumbs
import SlamData.FileSystem.Component.CSS as CSS
import SlamData.FileSystem.Component.Install (ChildQuery, ChildSlot, ChildState, QueryP, StateP, cpBreadcrumbs, cpDialog, cpListing, cpSearch, cpHeader, toDialog, toFs, toListing, toSearch)
import SlamData.FileSystem.Component.Query (Query(..))
import SlamData.FileSystem.Component.Render (sorting, toolbar)
import SlamData.FileSystem.Component.State (State, _isMount, _path, _salt, _showHiddenFiles, _sort, _version, initialState)
import SlamData.FileSystem.Dialog.Component as Dialog
import SlamData.FileSystem.Dialog.Download.Component as Download
import SlamData.FileSystem.Dialog.Explore.Component as Explore
import SlamData.FileSystem.Dialog.Mount.Component as Mount
import SlamData.FileSystem.Dialog.Mount.MongoDB.Component.State as MongoDB
import SlamData.FileSystem.Dialog.Mount.SQL2.Component.State as SQL2
import SlamData.FileSystem.Dialog.Rename.Component as Rename
import SlamData.FileSystem.Listing.Component as Listing
import SlamData.FileSystem.Listing.Item (Item(..), itemResource, sortItem)
import SlamData.FileSystem.Listing.Item.Component as Item
import SlamData.FileSystem.Listing.Sort (notSort)
import SlamData.FileSystem.Resource as R
import SlamData.FileSystem.Routing (browseURL)
import SlamData.FileSystem.Routing.Salt (newSalt)
import SlamData.FileSystem.Search.Component as Search
import SlamData.GlobalError as GE
import SlamData.Header.Component as Header
import SlamData.Quasar (ldJSON) as API
import SlamData.Quasar.Auth (authHeaders) as API
import SlamData.Quasar.Data (makeFile, save) as API
import SlamData.Quasar.FS (children, delete, getNewName) as API
import SlamData.Quasar.Mount (mountInfo, viewInfo) as API
import SlamData.Render.Common (content, row)
import SlamData.SignIn.Component as SignIn
import SlamData.Workspace.Action (Action(..), AccessType(..))
import SlamData.Workspace.Routing (mkWorkspaceURL)
import SlamData.Wiring (Wiring(..))

import Utils.DOM as D
import Utils.Path (DirPath, getNameStr)

type HTML = H.ParentHTML ChildState Query ChildQuery Slam ChildSlot
type DSL = H.ParentDSL State ChildState Query ChildQuery Slam ChildSlot

comp ∷ H.Component StateP QueryP Slam
comp =
  H.lifecycleParentComponent
    { render
    , eval
    , peek: Just (peek ∘ H.runChildF)
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ State → HTML
render state@{ version, sort, salt, path } =
  HH.div
    [ HP.classes [ CSS.filesystem ]
    , HE.onClick (HE.input_ DismissSignInSubmenu)
    ]
    [ HH.slot' cpHeader unit \_ →
          { component: Header.comp
          , initialState: H.parentState Header.initialState
          }

    , content
        [ HH.slot' cpSearch unit \_ →
             { component: Search.comp
             , initialState: Search.initialState
             }
        , HH.div_
            [ HH.slot' cpBreadcrumbs unit \_ →
                { component: Breadcrumbs.comp
                , initialState: Breadcrumbs.mkBreadcrumbs path sort salt
                }
            , toolbar state
            ]
        , row [ sorting state ]
        , HH.slot' cpListing unit \_ →
            { component: Listing.comp
            , initialState: H.parentState Listing.initialState
            }
        ]
    , HH.slot' cpDialog unit \_ →
        { component: Dialog.comp
        , initialState: H.parentState Dialog.initialState
        }
    ]

eval ∷ Query ~> DSL
eval (Init next) = do
  Wiring wiring ← H.liftH $ H.liftH ask
  subscribeToBus' (H.action ∘ HandleError) wiring.globalError
  pure next
eval (Resort next) = do
  { sort, salt, path } ← H.get
  searchValue ← H.query' cpSearch unit (H.request Search.GetValue)
  H.fromEff $ setLocation $ browseURL searchValue (notSort sort) salt path
  pure next
eval (SetPath path next) = H.modify (_path .~ path) *> updateBreadcrumbs $> next
eval (SetSort sort next) = do
  H.modify (_sort .~ sort)
  updateBreadcrumbs
  resort
  pure next
eval (SetSalt salt next) = H.modify (_salt .~ salt) *> updateBreadcrumbs $> next
eval (SetIsMount isMount next) = H.modify (_isMount .~ isMount) $> next
eval (ShowHiddenFiles next) = do
  H.modify (_showHiddenFiles .~ true)
  queryListing $ H.action (Listing.SetIsHidden false)
  pure next
eval (HideHiddenFiles next) = do
  H.modify (_showHiddenFiles .~ false)
  queryListing $ H.action (Listing.SetIsHidden true)
  pure next
eval (Configure next) = do
  path ← H.gets _.path
  configure (R.Database path)
  pure next
eval (MakeMount next) = do
  path ← H.gets _.path
  showDialog (Dialog.Mount path "" Nothing)
  pure next
eval (MakeFolder next) = do
  result ← runExceptT do
    path ← lift $ H.gets _.path
    dirName ← ExceptT $ API.getNewName path Config.newFolderName
    let dirPath = path </> dir dirName
        dirRes = R.Directory dirPath
        dirItem = PhantomItem dirRes
        hiddenFile = dirPath </> file (Config.folderMark)
    lift $ queryListing $ H.action (Listing.Add dirItem)
    ExceptT $ API.save hiddenFile jsonEmptyObject
    lift $ queryListing $ H.action (Listing.Filter (_ ≠ dirItem))
    pure dirRes
  case result of
    Left err →
      case GE.fromQError err of
        Left msg →
          showDialog $ Dialog.Error
            $ "There was a problem creating the directory: " ⊕ msg
        Right ge →
          GE.raiseGlobalError ge
    Right dirRes →
      void $ queryListing $ H.action $ Listing.Add (Item dirRes)
  pure next

eval (MakeWorkspace next) = do
  path ← H.gets _.path
  let newWorkspaceName = Config.newWorkspaceName ⊕ "." ⊕ Config.workspaceExtension
  name ← API.getNewName path newWorkspaceName
  case name of
    Left err →
      case GE.fromQError err of
        Left msg →
          -- This error isn't strictly true as we're not actually creating the
          -- workspace here, but saying there was a problem "creating a name for the
          -- workspace" would be a little strange
          showDialog $ Dialog.Error
            $ "There was a problem creating the workspace: " ⊕ msg
        Right ge →
          GE.raiseGlobalError ge
    Right name' → do
      H.fromEff $ setLocation $ mkWorkspaceURL (path </> dir name') New
  pure next

eval (UploadFile el next) = do
  mbInput ← H.fromEff $ D.querySelector "input" el
  for_ mbInput \input →
    void $ H.fromEff $ Be.raiseEvent "click" input
  pure next

eval (FileListChanged el next) = do
  fileArr ← map Cf.fileListToArray $ (H.fromAff $ Cf.files el)
  H.fromEff $ clearValue el
  case head fileArr of
    Nothing →
      -- TODO: notification? this shouldn't be a runtime exception anyway!
      -- let err ∷ Slam Unit
      --     err = throwError $ error "empty filelist"
      -- in H.fromAff err
      pure unit
    Just f → uploadFileSelected f
  pure next

eval (Download next) = do
  path ← H.gets _.path
  download (R.Directory path)
  pure next

eval (SetVersion version next) = H.modify (_version .~ Just version) $> next
eval (DismissSignInSubmenu next) = dismissSignInSubmenu $> next
eval (HandleError ge next) = do
  showDialog $ Dialog.Error $ GE.print ge
  pure next

uploadFileSelected ∷ Cf.File → DSL Unit
uploadFileSelected f = do
  { path, sort, salt } ← H.get
  name ←
    H.fromEff (Cf.name f)
      <#> Rgx.replace (unsafePartial fromRight $ Rgx.regex "/" Rgx.noFlags{global=true}) ":"
      >>= API.getNewName path

  case name of
    Left err → handleError err
    Right name' → do
      reader ← H.fromEff Cf.newReaderEff
      content' ← H.fromAff $ Cf.readAsBinaryString f reader

      let fileName = path </> file name'
          res = R.File fileName
          fileItem = PhantomItem res
          ext = last (S.split "." name')
          mime = if ext ≡ Just "csv"
                 then textCSV
                 else if isApplicationJSON content'
                      then applicationJSON
                      else API.ldJSON
      queryListing $ H.action (Listing.Add fileItem)
      f' ← API.makeFile fileName (CustomData mime content')
      queryListing $ H.action $
        Listing.Filter (not ∘ eq res ∘ itemResource)
      case f' of
        Left err → handleError err
        Right _ →
          void $ queryListing $ H.action $ Listing.Add (Item res)

  where
  isApplicationJSON ∷ String → Boolean
  isApplicationJSON content'
    -- Parse if content is small enough
    | S.length content' < 1048576 = isRight $ jsonParser content'
    -- Or check if its first/last characters are [/]
    | otherwise =
        let trimmed = S.trim content'
        in (startsWithEndsWith "[" "]" trimmed) || (startsWithEndsWith "{" "}" trimmed)

  startsWithEndsWith startsWith endsWith s =
    F.all isJust [S.stripPrefix startsWith s, S.stripSuffix endsWith s]

  handleError err =
    case GE.fromQError err of
      Left msg → showDialog $ Dialog.Error msg
      Right ge → GE.raiseGlobalError ge

peek ∷ ∀ a. ChildQuery a → DSL Unit
peek
  = listingPeek
  ⨁ searchPeek
  ⨁ const (pure unit)
  ⨁ dialogPeek
  ⨁ const (pure unit)

listingPeek ∷ ∀ a. Listing.QueryP a → DSL Unit
listingPeek = go ⨁ (itemPeek ∘ H.runChildF)
  where
  go (Listing.Add _ _) = resort
  go (Listing.Adds _ _) = resort
  go _ = pure unit

itemPeek ∷ ∀ a. Item.Query a → DSL Unit
itemPeek (Item.Open res _) = do
  { sort, salt, path } ← H.get
  loc ← H.fromEff locationString
  for_ (preview R._filePath res) \fp →
    showDialog $ Dialog.Explore fp
  for_ (preview R._dirPath res) \dp →
    H.fromEff $ setLocation $ browseURL Nothing sort salt dp
  for_ (preview R._Workspace res) \wp →
    H.fromEff $ setLocation $ append (loc ⊕ "/") $ mkWorkspaceURL wp (Load Editable)

itemPeek (Item.Configure (R.Mount mount) _) = configure mount
itemPeek (Item.Move res _) = do
  showDialog $ Dialog.Rename res
  flip getDirectories rootDir \x →
    void $ queryDialog Dialog.cpRename $ H.action (Rename.AddDirs x)
itemPeek (Item.Remove res _) = do
  -- Replace actual item with phantom
  queryListing $ H.action $ Listing.Filter (not ∘ eq res ∘ itemResource)
  queryListing $ H.action $ Listing.Add (PhantomItem res)
  -- Save order of items during deletion (or phantom will be on top of list)
  resort
  -- Try to delete
  mbTrashFolder ← H.liftH $ H.liftH $ API.delete res
  -- Remove phantom resource after we have response from server
  queryListing $ H.action $ Listing.Filter (not ∘ eq res ∘ itemResource)

  case mbTrashFolder of
    Left err → do
      -- Error occured: put item back and show dialog
      void $ queryListing $ H.action $ Listing.Add (Item res)
      case GE.fromQError err of
        Left msg →
          showDialog $ Dialog.Error msg
        Right ge →
          GE.raiseGlobalError ge
    Right mbRes →
      -- Item has been deleted: probably add trash folder
      for_ mbRes \res' →
        void $ queryListing $ H.action $ Listing.Add (Item res')

  resort

itemPeek (Item.Share res _) = do
  path ← H.gets _.path
  loc ← map (_ ⊕ "/") $ H.fromEff locationString
  for_ (preview R._filePath res) \fp → do
    let newWorkspaceName = Config.newWorkspaceName ⊕ "." ⊕ Config.workspaceExtension
    name ← API.getNewName path newWorkspaceName
    case name of
      Left err →
        case GE.fromQError err of
          Left msg →
            showDialog $ Dialog.Error
              $ "There was a problem creating the workspace: " ⊕ msg
          Right ge →
            GE.raiseGlobalError ge
      Right name' → do
        showDialog (Dialog.Share $ append loc $  mkWorkspaceURL (path </> dir name') $ Exploring fp)
  for_ (preview R._Workspace res) \wp → do
    showDialog (Dialog.Share $ append loc $ mkWorkspaceURL wp (Load ReadOnly))

itemPeek (Item.Download res _) = download res
itemPeek _ = pure unit

searchPeek ∷ ∀ a. Search.Query a → DSL Unit
searchPeek (Search.Clear _) = do
  salt ← H.fromEff newSalt
  { sort, path } ← H.get
  H.fromEff $ setLocation $ browseURL Nothing sort salt path
searchPeek (Search.Submit _) = do
  salt ← H.fromEff newSalt
  { sort, path } ← H.get
  value ← H.query' cpSearch unit $ H.request Search.GetValue
  H.fromEff $ setLocation $ browseURL value sort salt path
searchPeek _ = pure unit

dialogPeek ∷ ∀ a. Dialog.QueryP a → DSL Unit
dialogPeek = const (pure unit) ⨁ dialogChildrenPeek ∘ H.runChildF

dialogChildrenPeek ∷ ∀ a. Dialog.ChildQuery a → DSL Unit
dialogChildrenPeek q = do
  for_ (prjQuery Dialog.cpMount q) mountPeek
  for_ (prjQuery Dialog.cpExplore q) explorePeek

explorePeek ∷ ∀ a. Explore.Query a → DSL Unit
explorePeek (Explore.Explore fp name next) = do
  { path } ← H.get
  let newWorkspaceName = name ⊕ "." ⊕ Config.workspaceExtension
  name ← API.getNewName path newWorkspaceName
  case name of
    Left err →
      case GE.fromQError err of
        Left msg →
          showDialog $ Dialog.Error
            $ "There was a problem creating the workspace: " ⊕ msg
        Right ge →
          GE.raiseGlobalError ge
    Right name' →
      H.fromEff $ setLocation  $ mkWorkspaceURL (path </> dir name') $ Exploring fp
explorePeek _ = pure unit

mountPeek ∷ ∀ a. Mount.QueryP a → DSL Unit
mountPeek = go ⨁ const (pure unit)
  where
  go ∷ Mount.Query a → DSL Unit
  go (Mount.NotifySave _) = do
    mount ← queryDialog Dialog.cpMount $ left (H.request Mount.Save)
    for_ (join mount) \m → do
      hideDialog
      -- check if we just edited the mount for the current directory, as if
      -- so, we don't want to add an item to the list for it
      isCurrentMount ← case m of
        R.Database path' → (\p → path' ≡ (p </> dir "")) <$> H.gets _.path
        _ → pure false
      unless isCurrentMount do
        queryListing $ H.action $ Listing.Add $ Item (R.Mount m)
        resort
  go _ = pure unit

dismissSignInSubmenu ∷ DSL Unit
dismissSignInSubmenu = querySignIn $ H.action SignIn.DismissSubmenu
  where
  querySignIn ∷ ∀ a. SignIn.Query a → DSL Unit
  querySignIn =
    void
      ∘ H.query' cpHeader unit
      ∘ right
      ∘ H.ChildF (injSlot Header.cpSignIn unit)
      ∘ right
      ∘ left

updateBreadcrumbs ∷ DSL Unit
updateBreadcrumbs = do
  { path, sort, salt } ← H.get
  void $ H.query' cpBreadcrumbs unit $ H.action (Breadcrumbs.Update path sort salt)

resort ∷ DSL Unit
resort = do
  sort ← H.gets _.sort
  H.query' cpSearch unit (H.request Search.IsSearching)
    >>= traverse_ \isSearching →
      void $ queryListing $ H.action $ Listing.SortBy (sortItem isSearching sort)

configure ∷ R.Mount → DSL Unit
configure (R.View path) = do
  API.viewInfo path >>=
    case _ of
      Left err →
        case GE.fromQError err of
          Left msg →
            showDialog $ Dialog.Error
              $ "There was a problem reading the mount settings: "
              ⊕ msg
          Right ge →
            GE.raiseGlobalError ge
      Right info →
        showDialog $ Dialog.Mount
          (fromMaybe rootDir (parentDir path))
          (getNameStr (Right path))
          (Just (Right (SQL2.stateFromViewInfo info)))

configure (R.Database path) = do
  API.mountInfo path >>=
    case _ of
      Left err
        | path /= rootDir →
            case GE.fromQError err of
              Left msg →
                showDialog $ Dialog.Error
                  $ "There was a problem reading the mount settings: "
                  ⊕ msg
              Right ge →
                GE.raiseGlobalError ge
        | otherwise →
            -- We need to allow a non-existant root mount to be configured to
            -- allow for the case where Quasar has not yet had any mounts set
            -- up.
            showDialog $ Dialog.Mount
              rootDir
              ""
              (Just (Left MongoDB.initialState))
      Right config →
        showDialog $ Dialog.Mount
          (fromMaybe rootDir (parentDir path))
          (getNameStr (Left path))
          (Just (Left (MongoDB.fromConfig config)))

download ∷ R.Resource → DSL Unit
download res = do
  hs ← H.liftH $ H.liftH API.authHeaders
  showDialog (Dialog.Download res)
  queryDialog Dialog.cpDownload (H.action $ Download.SetAuthHeaders hs)
  pure unit

getChildren
  ∷ (R.Resource → Boolean)
  → (Array R.Resource → DSL Unit)
  → DirPath
  → DSL Unit
getChildren pred cont start = do
  ei ← API.children start
  case ei of
    Right items → do
      let items' = filter pred items
          parents = mapMaybe (either Just (const Nothing) ∘ R.getPath) items
      cont items'
      traverse_ (getChildren pred cont) parents
    _ → pure unit

getDirectories ∷ (Array R.Resource → DSL Unit) → DirPath → DSL Unit
getDirectories = getChildren (R.isDirectory ∨ R.isDatabaseMount)

showDialog ∷ Dialog.Dialog → DSL Unit
showDialog = void ∘ H.query' cpDialog unit ∘ left ∘ H.action ∘ Dialog.Show

hideDialog ∷ DSL Unit
hideDialog = void $ H.query' cpDialog unit $ left (H.action Dialog.Dismiss)

queryListing ∷ ∀ a. Listing.Query a → DSL (Maybe a)
queryListing = H.query' cpListing unit ∘ left

queryItem ∷ ∀ a. Listing.ItemSlot → Item.Query a → DSL (Maybe a)
queryItem slot = H.query' cpListing unit ∘ right ∘ H.ChildF slot

queryDialog
  ∷ ∀ s f a
  . ChildPath s Dialog.ChildState f Dialog.ChildQuery Unit Dialog.ChildSlot
  → f a
  → DSL (Maybe a)
queryDialog cp =
  H.query' cpDialog unit ∘ right ∘ H.ChildF (injSlot cp unit) ∘ injQuery cp

{-
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.FileSystem.Component
  ( module SlamData.FileSystem.Component.State
  , module SlamData.FileSystem.Component.Query
  , module SlamData.FileSystem.Component.Install
  , comp
  ) where

import SlamData.Prelude

import Control.UI.Browser (setLocation, locationString, clearValue)
import Control.UI.Browser.Event as Be
import Control.UI.File as Cf

import Data.Argonaut (jsonParser, jsonEmptyObject)
import Data.Array (head, last, mapMaybe, filter)
import Data.Foldable as F
import Data.Lens ((.~), preview)
import Data.MediaType.Common (textCSV, applicationJSON)
import Data.Path.Pathy (rootDir, (</>), dir, file, parentDir)
import Data.String as S
import Data.String.Regex as Rgx

import Halogen as H
import Halogen.Component.ChildPath (ChildPath, injSlot, prjQuery, injQuery)
import Halogen.Component.Utils (subscribeToBus')
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP

import Quasar.Data (QData(..))

import SlamData.Config as Config
import SlamData.Monad (Slam)
import SlamData.FileSystem.Breadcrumbs.Component as Breadcrumbs
import SlamData.FileSystem.Component.CSS as CSS
import SlamData.FileSystem.Component.Install (ChildQuery, ChildSlot, ChildState, QueryP, StateP, cpBreadcrumbs, cpDialog, cpListing, cpSearch, cpHeader, toDialog, toFs, toListing, toSearch)
import SlamData.FileSystem.Component.Query (Query(..))
import SlamData.FileSystem.Component.Render (sorting, toolbar)
import SlamData.FileSystem.Component.State (State, _isMount, _path, _salt, _showHiddenFiles, _sort, _version, initialState)
import SlamData.FileSystem.Dialog.Component as Dialog
import SlamData.FileSystem.Dialog.Download.Component as Download
import SlamData.FileSystem.Dialog.Explore.Component as Explore
import SlamData.FileSystem.Dialog.Mount.Component as Mount
import SlamData.FileSystem.Dialog.Mount.MongoDB.Component.State as MongoDB
import SlamData.FileSystem.Dialog.Mount.SQL2.Component.State as SQL2
import SlamData.FileSystem.Dialog.Rename.Component as Rename
import SlamData.FileSystem.Listing.Component as Listing
import SlamData.FileSystem.Listing.Item (Item(..), itemResource, sortItem)
import SlamData.FileSystem.Listing.Item.Component as Item
import SlamData.FileSystem.Listing.Sort (notSort)
import SlamData.FileSystem.Resource as R
import SlamData.FileSystem.Routing (browseURL)
import SlamData.FileSystem.Routing.Salt (newSalt)
import SlamData.FileSystem.Search.Component as Search
import SlamData.GlobalError as GE
import SlamData.Header.Component as Header
import SlamData.Quasar (ldJSON) as API
import SlamData.Quasar.Auth (authHeaders) as API
import SlamData.Quasar.Data (makeFile, save) as API
import SlamData.Quasar.FS (children, delete, getNewName) as API
import SlamData.Quasar.Mount (mountInfo, viewInfo) as API
import SlamData.Render.Common (content, row)
import SlamData.SignIn.Component as SignIn
import SlamData.Workspace.Action (Action(..), AccessType(..))
import SlamData.Workspace.Routing (mkWorkspaceURL)
import SlamData.Wiring (Wiring(..))

import Utils.DOM as D
import Utils.Path (DirPath, getNameStr)

type HTML = H.ParentHTML ChildState Query ChildQuery Slam ChildSlot
type DSL = H.ParentDSL State ChildState Query ChildQuery Slam ChildSlot

comp ∷ H.Component StateP QueryP Slam
comp =
  H.lifecycleParentComponent
    { render
    , eval
    , peek: Just (peek ∘ H.runChildF)
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ State → HTML
render state@{ version, sort, salt, path } =
  HH.div
    [ HP.classes [ CSS.filesystem ]
    , HE.onClick (HE.input_ DismissSignInSubmenu)
    ]
    [ HH.slot' cpHeader unit \_ →
          { component: Header.comp
          , initialState: H.parentState Header.initialState
          }

    , content
        [ HH.slot' cpSearch unit \_ →
             { component: Search.comp
             , initialState: Search.initialState
             }
        , HH.div_
            [ HH.slot' cpBreadcrumbs unit \_ →
                { component: Breadcrumbs.comp
                , initialState: Breadcrumbs.mkBreadcrumbs path sort salt
                }
            , toolbar state
            ]
        , row [ sorting state ]
        , HH.slot' cpListing unit \_ →
            { component: Listing.comp
            , initialState: H.parentState Listing.initialState
            }
        ]
    , HH.slot' cpDialog unit \_ →
        { component: Dialog.comp
        , initialState: H.parentState Dialog.initialState
        }
    ]

eval ∷ Query ~> DSL
eval (Init next) = do
  Wiring wiring ← H.liftH $ H.liftH ask
  subscribeToBus' (H.action ∘ HandleError) wiring.globalError
  pure next
eval (Resort next) = do
  { sort, salt, path } ← H.get
  searchValue ← H.query' cpSearch unit (H.request Search.GetValue)
  H.fromEff $ setLocation $ browseURL searchValue (notSort sort) salt path
  pure next
eval (SetPath path next) = H.modify (_path .~ path) *> updateBreadcrumbs $> next
eval (SetSort sort next) = do
  H.modify (_sort .~ sort)
  updateBreadcrumbs
  resort
  pure next
eval (SetSalt salt next) = H.modify (_salt .~ salt) *> updateBreadcrumbs $> next
eval (SetIsMount isMount next) = H.modify (_isMount .~ isMount) $> next
eval (ShowHiddenFiles next) = do
  H.modify (_showHiddenFiles .~ true)
  queryListing $ H.action (Listing.SetIsHidden false)
  pure next
eval (HideHiddenFiles next) = do
  H.modify (_showHiddenFiles .~ false)
  queryListing $ H.action (Listing.SetIsHidden true)
  pure next
eval (Configure next) = do
  path ← H.gets _.path
  configure (R.Database path)
  pure next
eval (MakeMount next) = do
  path ← H.gets _.path
  showDialog (Dialog.Mount path "" Nothing)
  pure next
eval (MakeFolder next) = do
  result ← runExceptT do
    path ← lift $ H.gets _.path
    dirName ← ExceptT $ API.getNewName path Config.newFolderName
    let dirPath = path </> dir dirName
        dirRes = R.Directory dirPath
        dirItem = PhantomItem dirRes
        hiddenFile = dirPath </> file (Config.folderMark)
    lift $ queryListing $ H.action (Listing.Add dirItem)
    ExceptT $ API.save hiddenFile jsonEmptyObject
    lift $ queryListing $ H.action (Listing.Filter (_ ≠ dirItem))
    pure dirRes
  case result of
    Left err →
      case GE.fromQError err of
        Left msg →
          showDialog $ Dialog.Error
            $ "There was a problem creating the directory: " ⊕ msg
        Right ge →
          GE.raiseGlobalError ge
    Right dirRes →
      void $ queryListing $ H.action $ Listing.Add (Item dirRes)
  pure next

eval (MakeWorkspace next) = do
  path ← H.gets _.path
  let newWorkspaceName = Config.newWorkspaceName ⊕ "." ⊕ Config.workspaceExtension
  name ← API.getNewName path newWorkspaceName
  case name of
    Left err →
      case GE.fromQError err of
        Left msg →
          -- This error isn't strictly true as we're not actually creating the
          -- workspace here, but saying there was a problem "creating a name for the
          -- workspace" would be a little strange
          showDialog $ Dialog.Error
            $ "There was a problem creating the workspace: " ⊕ msg
        Right ge →
          GE.raiseGlobalError ge
    Right name' → do
      H.fromEff $ setLocation $ mkWorkspaceURL (path </> dir name') New
  pure next

eval (UploadFile el next) = do
  mbInput ← H.fromEff $ D.querySelector "input" el
  for_ mbInput \input →
    void $ H.fromEff $ Be.raiseEvent "click" input
  pure next

eval (FileListChanged el next) = do
  fileArr ← map Cf.fileListToArray $ (H.fromAff $ Cf.files el)
  H.fromEff $ clearValue el
  case head fileArr of
    Nothing →
      -- TODO: notification? this shouldn't be a runtime exception anyway!
      -- let err ∷ Slam Unit
      --     err = throwError $ error "empty filelist"
      -- in H.fromAff err
      pure unit
    Just f → uploadFileSelected f
  pure next

eval (Download next) = do
  path ← H.gets _.path
  download (R.Directory path)
  pure next

eval (SetVersion version next) = H.modify (_version .~ Just version) $> next
eval (DismissSignInSubmenu next) = dismissSignInSubmenu $> next
eval (HandleError ge next) = do
  showDialog $ Dialog.Error $ GE.print ge
  pure next

uploadFileSelected ∷ Cf.File → DSL Unit
uploadFileSelected f = do
  { path, sort, salt } ← H.get
  name ←
    H.fromEff (Cf.name f)
      <#> Rgx.replace (unsafePartial fromRight $ Rgx.regex "/" Rgx.noFlags{global=true}) ":"
      >>= API.getNewName path

  case name of
    Left err → handleError err
    Right name' → do
      reader ← H.fromEff Cf.newReaderEff
      content' ← H.fromAff $ Cf.readAsBinaryString f reader

      let fileName = path </> file name'
          res = R.File fileName
          fileItem = PhantomItem res
          ext = last (S.split "." name')
          mime = if ext ≡ Just "csv"
                 then textCSV
                 else if isApplicationJSON content'
                      then applicationJSON
                      else API.ldJSON
      queryListing $ H.action (Listing.Add fileItem)
      f' ← API.makeFile fileName (CustomData mime content')
      queryListing $ H.action $
        Listing.Filter (not ∘ eq res ∘ itemResource)
      case f' of
        Left err → handleError err
        Right _ →
          void $ queryListing $ H.action $ Listing.Add (Item res)

  where
  isApplicationJSON ∷ String → Boolean
  isApplicationJSON content'
    -- Parse if content is small enough
    | S.length content' < 1048576 = isRight $ jsonParser content'
    -- Or check if its first/last characters are [/]
    | otherwise =
        let trimmed = S.trim content'
        in F.all isJust [S.stripPrefix "[" trimmed, S.stripSuffix "]" trimmed]

  handleError err =
    case GE.fromQError err of
      Left msg → showDialog $ Dialog.Error msg
      Right ge → GE.raiseGlobalError ge

peek ∷ ∀ a. ChildQuery a → DSL Unit
peek
  = listingPeek
  ⨁ searchPeek
  ⨁ const (pure unit)
  ⨁ dialogPeek
  ⨁ const (pure unit)

listingPeek ∷ ∀ a. Listing.QueryP a → DSL Unit
listingPeek = go ⨁ (itemPeek ∘ H.runChildF)
  where
  go (Listing.Add _ _) = resort
  go (Listing.Adds _ _) = resort
  go _ = pure unit

itemPeek ∷ ∀ a. Item.Query a → DSL Unit
itemPeek (Item.Open res _) = do
  { sort, salt, path } ← H.get
  loc ← H.fromEff locationString
  for_ (preview R._filePath res) \fp →
    showDialog $ Dialog.Explore fp
  for_ (preview R._dirPath res) \dp →
    H.fromEff $ setLocation $ browseURL Nothing sort salt dp
  for_ (preview R._Workspace res) \wp →
    H.fromEff $ setLocation $ append (loc ⊕ "/") $ mkWorkspaceURL wp (Load Editable)

itemPeek (Item.Configure (R.Mount mount) _) = configure mount
itemPeek (Item.Move res _) = do
  showDialog $ Dialog.Rename res
  flip getDirectories rootDir \x →
    void $ queryDialog Dialog.cpRename $ H.action (Rename.AddDirs x)
itemPeek (Item.Remove res _) = do
  -- Replace actual item with phantom
  queryListing $ H.action $ Listing.Filter (not ∘ eq res ∘ itemResource)
  queryListing $ H.action $ Listing.Add (PhantomItem res)
  -- Save order of items during deletion (or phantom will be on top of list)
  resort
  -- Try to delete
  mbTrashFolder ← H.liftH $ H.liftH $ API.delete res
  -- Remove phantom resource after we have response from server
  queryListing $ H.action $ Listing.Filter (not ∘ eq res ∘ itemResource)

  case mbTrashFolder of
    Left err → do
      -- Error occured: put item back and show dialog
      void $ queryListing $ H.action $ Listing.Add (Item res)
      case GE.fromQError err of
        Left msg →
          showDialog $ Dialog.Error msg
        Right ge →
          GE.raiseGlobalError ge
    Right mbRes →
      -- Item has been deleted: probably add trash folder
      for_ mbRes \res' →
        void $ queryListing $ H.action $ Listing.Add (Item res')

  resort

itemPeek (Item.Share res _) = do
  path ← H.gets _.path
  loc ← map (_ ⊕ "/") $ H.fromEff locationString
  for_ (preview R._filePath res) \fp → do
    let newWorkspaceName = Config.newWorkspaceName ⊕ "." ⊕ Config.workspaceExtension
    name ← API.getNewName path newWorkspaceName
    case name of
      Left err →
        case GE.fromQError err of
          Left msg →
            showDialog $ Dialog.Error
              $ "There was a problem creating the workspace: " ⊕ msg
          Right ge →
            GE.raiseGlobalError ge
      Right name' → do
        showDialog (Dialog.Share $ append loc $  mkWorkspaceURL (path </> dir name') $ Exploring fp)
  for_ (preview R._Workspace res) \wp → do
    showDialog (Dialog.Share $ append loc $ mkWorkspaceURL wp (Load ReadOnly))

itemPeek (Item.Download res _) = download res
itemPeek _ = pure unit

searchPeek ∷ ∀ a. Search.Query a → DSL Unit
searchPeek (Search.Clear _) = do
  salt ← H.fromEff newSalt
  { sort, path } ← H.get
  H.fromEff $ setLocation $ browseURL Nothing sort salt path
searchPeek (Search.Submit _) = do
  salt ← H.fromEff newSalt
  { sort, path } ← H.get
  value ← H.query' cpSearch unit $ H.request Search.GetValue
  H.fromEff $ setLocation $ browseURL value sort salt path
searchPeek _ = pure unit

dialogPeek ∷ ∀ a. Dialog.QueryP a → DSL Unit
dialogPeek = const (pure unit) ⨁ dialogChildrenPeek ∘ H.runChildF

dialogChildrenPeek ∷ ∀ a. Dialog.ChildQuery a → DSL Unit
dialogChildrenPeek q = do
  for_ (prjQuery Dialog.cpMount q) mountPeek
  for_ (prjQuery Dialog.cpExplore q) explorePeek

explorePeek ∷ ∀ a. Explore.Query a → DSL Unit
explorePeek (Explore.Explore fp name next) = do
  { path } ← H.get
  let newWorkspaceName = name ⊕ "." ⊕ Config.workspaceExtension
  name ← API.getNewName path newWorkspaceName
  case name of
    Left err →
      case GE.fromQError err of
        Left msg →
          showDialog $ Dialog.Error
            $ "There was a problem creating the workspace: " ⊕ msg
        Right ge →
          GE.raiseGlobalError ge
    Right name' →
      H.fromEff $ setLocation  $ mkWorkspaceURL (path </> dir name') $ Exploring fp
explorePeek _ = pure unit

mountPeek ∷ ∀ a. Mount.QueryP a → DSL Unit
mountPeek = go ⨁ const (pure unit)
  where
  go ∷ Mount.Query a → DSL Unit
  go (Mount.NotifySave _) = do
    mount ← queryDialog Dialog.cpMount $ left (H.request Mount.Save)
    for_ (join mount) \m → do
      hideDialog
      -- check if we just edited the mount for the current directory, as if
      -- so, we don't want to add an item to the list for it
      isCurrentMount ← case m of
        R.Database path' → (\p → path' ≡ (p </> dir "")) <$> H.gets _.path
        _ → pure false
      unless isCurrentMount do
        queryListing $ H.action $ Listing.Add $ Item (R.Mount m)
        resort
  go _ = pure unit

dismissSignInSubmenu ∷ DSL Unit
dismissSignInSubmenu = querySignIn $ H.action SignIn.DismissSubmenu
  where
  querySignIn ∷ ∀ a. SignIn.Query a → DSL Unit
  querySignIn =
    void
      ∘ H.query' cpHeader unit
      ∘ right
      ∘ H.ChildF (injSlot Header.cpSignIn unit)
      ∘ right
      ∘ left

updateBreadcrumbs ∷ DSL Unit
updateBreadcrumbs = do
  { path, sort, salt } ← H.get
  void $ H.query' cpBreadcrumbs unit $ H.action (Breadcrumbs.Update path sort salt)

resort ∷ DSL Unit
resort = do
  sort ← H.gets _.sort
  H.query' cpSearch unit (H.request Search.IsSearching)
    >>= traverse_ \isSearching →
      void $ queryListing $ H.action $ Listing.SortBy (sortItem isSearching sort)

configure ∷ R.Mount → DSL Unit
configure (R.View path) = do
  API.viewInfo path >>=
    case _ of
      Left err →
        case GE.fromQError err of
          Left msg →
            showDialog $ Dialog.Error
              $ "There was a problem reading the mount settings: "
              ⊕ msg
          Right ge →
            GE.raiseGlobalError ge
      Right info →
        showDialog $ Dialog.Mount
          (fromMaybe rootDir (parentDir path))
          (getNameStr (Right path))
          (Just (Right (SQL2.stateFromViewInfo info)))

configure (R.Database path) = do
  API.mountInfo path >>=
    case _ of
      Left err
        | path /= rootDir →
            case GE.fromQError err of
              Left msg →
                showDialog $ Dialog.Error
                  $ "There was a problem reading the mount settings: "
                  ⊕ msg
              Right ge →
                GE.raiseGlobalError ge
        | otherwise →
            -- We need to allow a non-existant root mount to be configured to
            -- allow for the case where Quasar has not yet had any mounts set
            -- up.
            showDialog $ Dialog.Mount
              rootDir
              ""
              (Just (Left MongoDB.initialState))
      Right config →
        showDialog $ Dialog.Mount
          (fromMaybe rootDir (parentDir path))
          (getNameStr (Left path))
          (Just (Left (MongoDB.fromConfig config)))

download ∷ R.Resource → DSL Unit
download res = do
  hs ← H.liftH $ H.liftH API.authHeaders
  showDialog (Dialog.Download res)
  queryDialog Dialog.cpDownload (H.action $ Download.SetAuthHeaders hs)
  pure unit

getChildren
  ∷ (R.Resource → Boolean)
  → (Array R.Resource → DSL Unit)
  → DirPath
  → DSL Unit
getChildren pred cont start = do
  ei ← API.children start
  case ei of
    Right items → do
      let items' = filter pred items
          parents = mapMaybe (either Just (const Nothing) ∘ R.getPath) items
      cont items'
      traverse_ (getChildren pred cont) parents
    _ → pure unit

getDirectories ∷ (Array R.Resource → DSL Unit) → DirPath → DSL Unit
getDirectories = getChildren (R.isDirectory ∨ R.isDatabaseMount)

showDialog ∷ Dialog.Dialog → DSL Unit
showDialog = void ∘ H.query' cpDialog unit ∘ left ∘ H.action ∘ Dialog.Show

hideDialog ∷ DSL Unit
hideDialog = void $ H.query' cpDialog unit $ left (H.action Dialog.Dismiss)

queryListing ∷ ∀ a. Listing.Query a → DSL (Maybe a)
queryListing = H.query' cpListing unit ∘ left

queryItem ∷ ∀ a. Listing.ItemSlot → Item.Query a → DSL (Maybe a)
queryItem slot = H.query' cpListing unit ∘ right ∘ H.ChildF slot

queryDialog
  ∷ ∀ s f a
  . ChildPath s Dialog.ChildState f Dialog.ChildQuery Unit Dialog.ChildSlot
  → f a
  → DSL (Maybe a)
queryDialog cp =
  H.query' cpDialog unit ∘ right ∘ H.ChildF (injSlot cp unit) ∘ injQuery cp


removed zipP and defined zip as synonyme for map2

module Signal
  ( Signal(..)
  , constant
  , map
  , applySig
  , merge
  , foldp
  , sampleOn
  , distinct
  , distinct'
  , zip
  , runSignal
  , unwrap
  , keepIf
  , (<~)
  , (~>)
  , (~)
  ) where

import Control.Monad.Eff
import Data.Function

foreign import data Signal :: * -> *

foreign import constant """
  function constant(initial) {
    var subs = [];
    var val = initial;
    var sig = {
      subscribe: function(sub) {
        subs.push(sub);
        sub(val);
      },
      get: function() { return val; },
      set: function(newval) {
        val = newval;
        subs.forEach(function(sub) { sub(newval); });
      }
    };
    return sig;
  }""" :: forall a. a -> Signal a

foreign import mapP """
  function mapP(constant, fun, sig) {
    var out = constant(fun(sig.get()));
    sig.subscribe(function(val) { out.set(fun(val)); });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (a -> b) (Signal a) (Signal b)

map :: forall a b. (a -> b) -> Signal a -> Signal b
map = runFn3 mapP constant

foreign import applySigP """
  function applySigP(constant, fun, sig) {
    var out = constant(fun.get()(sig.get()));
    var produce = function() { out.set(fun.get()(sig.get())); };
    fun.subscribe(produce);
    sig.subscribe(produce);
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal (a -> b)) (Signal a) (Signal b)

applySig :: forall a b. Signal (a -> b) -> Signal a -> Signal b
applySig = runFn3 applySigP constant

foreign import mergeP """
  function mergeP(constant, sig1, sig2) {
    var out = constant(sig1.get());
    sig1.subscribe(out.set);
    sig2.subscribe(out.set);
    return out;
  }""" :: forall a c. Fn3 (c -> Signal c) (Signal a) (Signal a) (Signal a)

merge :: forall a. Signal a -> Signal a -> Signal a
merge = runFn3 mergeP constant

foreign import foldpP """
  function foldpP(constant, fun, seed, sig) {
    var acc = seed;
    var out = constant(acc);
    sig.subscribe(function(val) {
      acc = fun(val)(acc);
      out.set(acc);
    });
    return out;
  }""" :: forall a b c. Fn4 (c -> Signal c) (a -> b -> b) b (Signal a) (Signal b)

foldp :: forall a b. (a -> b -> b) -> b -> Signal a -> Signal b
foldp = runFn4 foldpP constant

foreign import sampleOnP """
  function sampleOnP(constant, sig1, sig2) {
    var out = constant(sig2.get());
    sig1.subscribe(function() {
      out.set(sig2.get());
    });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal a) (Signal b) (Signal b)

sampleOn :: forall a b. Signal a -> Signal b -> Signal b
sampleOn = runFn3 sampleOnP constant

foreign import distinctP """
  function distinctP(eq) {
  return function(constant) {
  return function(sig) {
    var val = sig.get();
    var out = constant(val);
    sig.subscribe(function(newval) {
      if (eq['/='](val)(newval)) {
        val = newval;
        out.set(val);
      }
    });
    return out;
  };};}""" :: forall a c. (Eq a) => (c -> Signal c) -> Signal a -> Signal a

distinct :: forall a. (Eq a) => Signal a -> Signal a
distinct = distinctP constant

foreign import distinctRefP """
  function distinctRefP(constant, sig) {
    var val = sig.get();
    var out = constant(val);
    sig.subscribe(function(newval) {
      if (val !== newval) {
        val = newval;
        out.set(val);
      }
    });
    return out;
  }""" :: forall a c. Fn2 (c -> Signal c) (Signal a) (Signal a)

distinct' :: forall a. Signal a -> Signal a
distinct' = runFn2 distinctRefP constant

zip :: forall a b c. (a -> b -> c) -> Signal a -> Signal b -> Signal c
zip = map2

foreign import runSignal """
  function runSignal(sig) {
    return function() {
      sig.subscribe(function(val) {
        val();
      });
      return {};
    };
  }""" :: forall e. Signal (Eff e Unit) -> Eff e Unit

foreign import unwrapP """
  function unwrapP(constant, sig) {
    return function() {
      var out = constant(sig.get()());
      sig.subscribe(function(val) { out.set(val()); });
      return out;
    };
  }""" :: forall e a c. Fn2 (c -> Signal c) (Signal (Eff e a)) (Eff e (Signal a))

unwrap :: forall a e. Signal (Eff e a) -> Eff e (Signal a)
unwrap = runFn2 unwrapP constant

foreign import keepIfP """
  function keepIfP(constant, fn, seed, sig) {
    var out = constant(fn(sig.get()) ? sig.get() : seed);
    sig.subscribe(function(val) { if (fn(val)) out.set(val); });
    return out;
  }""" :: forall a c. Fn4 (c -> Signal c) (a -> Boolean) a (Signal a) (Signal a)

keepIf :: forall a. (a -> Boolean) -> a -> Signal a -> Signal a
keepIf = runFn4 keepIfP constant

instance functorSignal :: Functor Signal where
  (<$>) = map

instance applySignal :: Apply Signal where
  (<*>) = applySig

instance applicativeSignal :: Applicative Signal where
  pure = constant

instance semigroupSignal :: Semigroup (Signal a) where
  (<>) = merge

infixl 4 <~
(<~) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
(<~) = (<$>)

infixl 4 ~>
(~>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
(~>) = flip (<$>)

infixl 4 ~
(~) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
(~) = (<*>)

map2 :: forall a b c. (a -> b -> c) -> Signal a -> Signal b -> Signal c
map2 f a b = f <~ a ~ b

map3 :: forall a b c d. (a -> b -> c -> d) -> Signal a -> Signal b -> Signal c -> Signal d
map3 f a b c = f <~ a ~ b ~ c

map4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e
map4 f a b c d = f <~ a ~ b ~ c ~ d

map5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f
map5 f a b c d e = f <~ a ~ b ~ c ~ d ~ e

module Signal
  ( Signal(..)
  , constant
  , map
  , applySig
  , merge
  , foldp
  , sampleOn
  , distinct
  , distinct'
  , zip
  , runSignal
  , unwrap
  , keepIf
  , (<~)
  , (~>)
  , (~)
  ) where

import Control.Monad.Eff
import Data.Function

foreign import data Signal :: * -> *

foreign import constant """
  function constant(initial) {
    var subs = [];
    var val = initial;
    var sig = {
      subscribe: function(sub) {
        subs.push(sub);
        sub(val);
      },
      get: function() { return val; },
      set: function(newval) {
        val = newval;
        subs.forEach(function(sub) { sub(newval); });
      }
    };
    return sig;
  }""" :: forall a. a -> Signal a

foreign import mapP """
  function mapP(constant, fun, sig) {
    var out = constant(fun(sig.get()));
    sig.subscribe(function(val) { out.set(fun(val)); });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (a -> b) (Signal a) (Signal b)

map :: forall a b. (a -> b) -> Signal a -> Signal b
map = runFn3 mapP constant

foreign import applySigP """
  function applySigP(constant, fun, sig) {
    var out = constant(fun.get()(sig.get()));
    var produce = function() { out.set(fun.get()(sig.get())); };
    fun.subscribe(produce);
    sig.subscribe(produce);
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal (a -> b)) (Signal a) (Signal b)

applySig :: forall a b. Signal (a -> b) -> Signal a -> Signal b
applySig = runFn3 applySigP constant

foreign import mergeP """
  function mergeP(constant, sig1, sig2) {
    var out = constant(sig1.get());
    sig1.subscribe(out.set);
    sig2.subscribe(out.set);
    return out;
  }""" :: forall a c. Fn3 (c -> Signal c) (Signal a) (Signal a) (Signal a)

merge :: forall a. Signal a -> Signal a -> Signal a
merge = runFn3 mergeP constant

foreign import foldpP """
  function foldpP(constant, fun, seed, sig) {
    var acc = seed;
    var out = constant(acc);
    sig.subscribe(function(val) {
      acc = fun(val)(acc);
      out.set(acc);
    });
    return out;
  }""" :: forall a b c. Fn4 (c -> Signal c) (a -> b -> b) b (Signal a) (Signal b)

foldp :: forall a b. (a -> b -> b) -> b -> Signal a -> Signal b
foldp = runFn4 foldpP constant

foreign import sampleOnP """
  function sampleOnP(constant, sig1, sig2) {
    var out = constant(sig2.get());
    sig1.subscribe(function() {
      out.set(sig2.get());
    });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal a) (Signal b) (Signal b)

sampleOn :: forall a b. Signal a -> Signal b -> Signal b
sampleOn = runFn3 sampleOnP constant

foreign import distinctP """
  function distinctP(eq) {
  return function(constant) {
  return function(sig) {
    var val = sig.get();
    var out = constant(val);
    sig.subscribe(function(newval) {
      if (eq['/='](val)(newval)) {
        val = newval;
        out.set(val);
      }
    });
    return out;
  };};}""" :: forall a c. (Eq a) => (c -> Signal c) -> Signal a -> Signal a

distinct :: forall a. (Eq a) => Signal a -> Signal a
distinct = distinctP constant

foreign import distinctRefP """
  function distinctRefP(constant, sig) {
    var val = sig.get();
    var out = constant(val);
    sig.subscribe(function(newval) {
      if (val !== newval) {
        val = newval;
        out.set(val);
      }
    });
    return out;
  }""" :: forall a c. Fn2 (c -> Signal c) (Signal a) (Signal a)

distinct' :: forall a. Signal a -> Signal a
distinct' = runFn2 distinctRefP constant

foreign import zipP """
  function zipP(constant, f, sig1, sig2) {
    var val1 = sig1.get(), val2 = sig2.get();
    var out = constant(f(val1)(val2));
    sig1.subscribe(function(v) {
      val1 = v;
      out.set(f(val1)(val2));
    });
    sig2.subscribe(function(v) {
      val2 = v;
      out.set(f(val1)(val2));
    });
    return out;
  }""" :: forall a b c d. Fn4 (d -> Signal d) (a -> b -> c) (Signal a) (Signal b) (Signal c)

zip :: forall a b c. (a -> b -> c) -> Signal a -> Signal b -> Signal c
zip f a b = runFn4 zipP constant f a b

foreign import runSignal """
  function runSignal(sig) {
    return function() {
      sig.subscribe(function(val) {
        val();
      });
      return {};
    };
  }""" :: forall e. Signal (Eff e Unit) -> Eff e Unit

foreign import unwrapP """
  function unwrapP(constant, sig) {
    return function() {
      var out = constant(sig.get()());
      sig.subscribe(function(val) { out.set(val()); });
      return out;
    };
  }""" :: forall e a c. Fn2 (c -> Signal c) (Signal (Eff e a)) (Eff e (Signal a))

unwrap :: forall a e. Signal (Eff e a) -> Eff e (Signal a)
unwrap = runFn2 unwrapP constant

foreign import keepIfP """
  function keepIfP(constant, fn, seed, sig) {
    var out = constant(fn(sig.get()) ? sig.get() : seed);
    sig.subscribe(function(val) { if (fn(val)) out.set(val); });
    return out;
  }""" :: forall a c. Fn4 (c -> Signal c) (a -> Boolean) a (Signal a) (Signal a)

keepIf :: forall a. (a -> Boolean) -> a -> Signal a -> Signal a
keepIf = runFn4 keepIfP constant

instance functorSignal :: Functor Signal where
  (<$>) = map

instance applySignal :: Apply Signal where
  (<*>) = applySig

instance applicativeSignal :: Applicative Signal where
  pure = constant

instance semigroupSignal :: Semigroup (Signal a) where
  (<>) = merge

infixl 4 <~
(<~) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
(<~) = (<$>)

infixl 4 ~>
(~>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
(~>) = flip (<$>)

infixl 4 ~
(~) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
(~) = (<*>)

map2 :: forall a b c. (a -> b -> c) -> Signal a -> Signal b -> Signal c
map2 f a b = f <~ a ~ b

map3 :: forall a b c d. (a -> b -> c -> d) -> Signal a -> Signal b -> Signal c -> Signal d
map3 f a b c = f <~ a ~ b ~ c

map4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e
map4 f a b c d = f <~ a ~ b ~ c ~ d

map5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f
map5 f a b c d e = f <~ a ~ b ~ c ~ d ~ e