Pass key to vnode

Pass key to vnode

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

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

import DOM
import Data.DOM.Simple.Types

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

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
  """
  var createElement = (function () {
    var vcreateElement = require('virtual-dom/create-element');
    return function (vtree) {
      return vcreateElement(vtree);
    };
  }());
  """ :: VTree -> HTMLElement

-- | Calculate the differences between two virtual DOM trees
foreign import diff
  """
  var diff = (function () {
    var vdiff = require('virtual-dom/diff');
    return function (vtree1) {
      return function (vtree2) {
        return vdiff(vtree1, vtree2);
      };
    };
  }());

  """ :: VTree -> VTree -> Patch

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

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

-- | Create a virtual DOM tree which represents an element with properties
foreign import vnode
  """
  var vnode = (function () {
    var VirtualNode = require('virtual-dom/vnode/vnode');
    var SoftSetHook = require('virtual-dom/virtual-hyperscript/hooks/soft-set-hook');
    return function (name) {
      return function (attr) {
        return function (children) {
          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];
            }
          }
          if (name === 'input' && props.value !== undefined) {
            props.value = new SoftSetHook(props.value);
          }
          return new VirtualNode(name, props, children, attr.key);
        };
      };
    };
  }());
  """ :: String -> Props -> [VTree] -> VTree

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

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

import DOM
import Data.DOM.Simple.Types

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

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
  """
  var createElement = (function () {
    var vcreateElement = require('virtual-dom/create-element');
    return function (vtree) {
      return vcreateElement(vtree);
    };
  }());
  """ :: VTree -> HTMLElement

-- | Calculate the differences between two virtual DOM trees
foreign import diff
  """
  var diff = (function () {
    var vdiff = require('virtual-dom/diff');
    return function (vtree1) {
      return function (vtree2) {
        return vdiff(vtree1, vtree2);
      };
    };
  }());

  """ :: VTree -> VTree -> Patch

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

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

-- | Create a virtual DOM tree which represents an element with properties
foreign import vnode
  """
  var vnode = (function () {
    var VirtualNode = require('virtual-dom/vnode/vnode');
    var SoftSetHook = require('virtual-dom/virtual-hyperscript/hooks/soft-set-hook');
    return function (name) {
      return function (attr) {
        return function (children) {
          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];
            }
          }
          if (name === 'input' && props.value !== undefined) {
            props.value = new SoftSetHook(props.value);
          }
          return new VirtualNode(name, props, children);
        };
      };
    };
  }());
  """ :: String -> Props -> [VTree] -> VTree


split action runners into initializing and non-init

probably the whole ADT needs to be split, and certainly we need to be able to pass validated D3 Selections back to the DSL to use in order to do updates and so forth but the idea is to do it this sort of hacky way until it’s clearer how that should look

module D3DSL.Eval where

import D3DSL.Foreign.Run
import Control.Monad.Eff (Eff)
import D3DSL.Base (D3, D3Action(..), D3S)
import DOM (DOM)
import Data.Either (Either(..))
import Data.Foldable (class Foldable)
import Data.Function.Eff (runEffFn1, runEffFn2)
import Data.List (List, fromFoldable, head, (:))
import Data.Maybe (Maybe(..))
import Prelude (($), (<$>), pure, Unit, unit, bind)

type D3Effects e v = Eff (d3::D3,dom::DOM|e) v

{- in this first cut we want to handle the simple case where you have a List of
D3Actions which is completely self-contained - ie you haven't cached the
D3Selection in the pure code anywhere so you are definitely starting with a
DocumentSelect or a DocumentSelectAll -}
evalD3 :: ∀ d i e. D3S d i -> D3Effects e Unit
evalD3 (firstAction:rest) = do
    initialSelect <- runD3Action firstAction (Left Uninitialized)
    pure unit
evalD3 _ = pure unit

d3s :: forall f a. (Foldable f) => f a -> List a
d3s = fromFoldable

runD3InitAction :: ∀ d i e. D3Action d i -> PossibleSelection -> Eff (d3::D3, dom::DOM|e) PossibleSelection
runD3InitAction (DocumentSelect selector) _ -- don't care about PossibleSelection if making new docSelect
    = Right <$> runEffFn1 d3DocSelectFn selector

runD3InitAction (DocumentSelectAll selector) _ -- don't care about PossibleSelection if making new docSelect
    = Right <$> runEffFn1 d3DocSelectAllFn selector

runD3InitAction _ _ = pure $ Left $ JSerr "tried to runD3InitAction on non-initializing Action"

runD3Action :: ∀ d i e. D3Action d i -> PossibleSelection -> Eff (d3::D3, dom::DOM|e) PossibleSelection
runD3Action (Select selector) (Right selection)
    = Right <$> runEffFn2 d3SelectFn selector selection

runD3Action (SelectAll selector) (Right selection)
    = Right <$> runEffFn2 d3SelectAllFn selector selection

runD3Action _ _ = pure $ Left $ JSerr "unhandled action in runD3Action"
{-
runD3Action (Merge _)
    = dummyD3Fn "Merge"

runD3Action (Append _)
    = dummyD3Fn "Append"

runD3Action Remove
    = dummyD3Fn "Remove"

runD3Action Enter
    = dummyD3Fn "Enter"

runD3Action Exit
    = dummyD3Fn "Exit"

runD3Action (Transition _)
    = dummyD3Fn "Transition"

runD3Action (Attrs _)
    = dummyD3Fn "Attrs"

runD3Action (DataA d)
    = runEffFn2 d3DataAFn d emptySelection

runD3Action (DataH _)
    = dummyD3Fn "DataH"

runD3Action (DataAI _ _)
    = dummyD3Fn "DataAI"

runD3Action (DataHI _ _)
    = dummyD3Fn "DataHI"

-}

module D3DSL.Eval where

import D3DSL.Foreign.Run
import Control.Monad.Eff (Eff)
import D3DSL.Base (D3, D3Action(..), D3S)
import DOM (DOM)
import Data.Either (Either(..))
import Data.Foldable (class Foldable)
import Data.Function.Eff (runEffFn1, runEffFn2)
import Data.List (List, fromFoldable, head, (:))
import Data.Maybe (Maybe(..))
import Prelude (($), (<$>), pure, Unit, unit, bind)

d3s :: forall f a. (Foldable f) => f a -> List a
d3s = fromFoldable

runD3Action :: ∀ d i e. D3Action d i -> PossibleSelection -> Eff (d3::D3, dom::DOM|e) PossibleSelection
runD3Action (DocumentSelect selector) _ -- don't care about PossibleSelection if making new docSelect
    = Right <$> runEffFn1 d3DocSelectFn selector

runD3Action (DocumentSelectAll selector) _ -- don't care about PossibleSelection if making new docSelect
    = Right <$> runEffFn1 d3DocSelectAllFn selector

runD3Action (Select selector) (Right selection)
    = Right <$> runEffFn2 d3SelectFn selector selection

runD3Action (SelectAll selector) (Right selection)
    = Right <$> runEffFn2 d3SelectAllFn selector selection

runD3Action _ _ = pure $ Left $ JSerr "unhandled action in runD3Action"
{-
runD3Action (Merge _)
    = dummyD3Fn "Merge"

runD3Action (Append _)
    = dummyD3Fn "Append"

runD3Action Remove
    = dummyD3Fn "Remove"

runD3Action Enter
    = dummyD3Fn "Enter"

runD3Action Exit
    = dummyD3Fn "Exit"

runD3Action (Transition _)
    = dummyD3Fn "Transition"

runD3Action (Attrs _)
    = dummyD3Fn "Attrs"

runD3Action (DataA d)
    = runEffFn2 d3DataAFn d emptySelection

runD3Action (DataH _)
    = dummyD3Fn "DataH"

runD3Action (DataAI _ _)
    = dummyD3Fn "DataAI"

runD3Action (DataHI _ _)
    = dummyD3Fn "DataHI"

-}
type D3Effects e v = Eff (d3::D3,dom::DOM|e) v

-- headAsEither :: ∀ d err. err -> List d -> Either err d
-- headAsEither err l = case head l of
--                      Nothing -> Left err
--                      Just el -> Right el

evalD3 :: ∀ d i e. D3S d i -> D3Effects e Unit
evalD3 (firstAction:rest) = do
    initialSelect <- runD3Action firstAction (Left Uninitialized)
    pure unit
evalD3 _ = pure unit


ConnectState: use a new type

ConnectState: use a new type

module React.Redox
  ( ConnectState
  , withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, runFn2, runFn3)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, over)
import React (ReactClass, ReactSpec, ReactThis, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Canceler (redox :: RedoxStore reff | eff))

-- | Shallowly compare to objects.  If the third argument is true it skips
-- | comapring the `key` property which should not be accessed on a property
-- | object.
foreign import unsafeShallowEqual :: forall a. Fn3 Boolean a a Boolean

-- | Compare two objects using strict equality `===`
foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

type RedoxContext state dsl reff eff =
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

newtype ConnectState state = ConnectState { state :: state, sid :: Maybe SubscriptionId }

derive instance newtypeConnectState :: Newtype (ConnectState state) _

_connect
  :: forall state state' dsl props props' reff eff
   . (ReactThis props' (ConnectState state')
      -> Eff
        (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff)
        (RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff)
     )
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = componentDidMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      void $ writeState this $ over ConnectState (_ { state = view _lns state }) st

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to ctxEff
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure (ConnectState { state: view _lns state, sid: Nothing })

    -- | Subscription to redox store happens in `componentDidMount`, rather than
    -- | on `componentWillMount`.  This is because `componentWillUnmount` and
    -- | `componentDidMount` do not fire in SSR. Otherwise we'd have a memory
    -- | leak.  Note that if a child triggers an action in its
    -- | `componentWillMount` it's change might be
    -- | missed.
    componentDidMount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      st <- readState this
      void $ writeState this (over ConnectState (_ { sid = Just sid }) st)

    componentWillUnmount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      ConnectState { sid: msid } <- R.readState this
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    shouldComponentUpdate this nPr (ConnectState nSt) = do
      pr <- getProps this
      ConnectState st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn3 unsafeShallowEqual false pr nPr)

    renderFn this = do
      props' <- R.getProps this
      children <- R.getChildren this
      ctx <- unsafeCoerceEff $ ctxEff this
      ConnectState { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') children

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' dsl props props' reff eff
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = _.redox <$> ctx
      where
        ctx = readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })) this

connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p _lns _iso cls = accessContext $ R.createClass $ connect' p _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' reff eff
   . Store state
  -> DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure {store, dispatch: dispatch_}) _lns _iso cls

dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Canceler (context :: CONTEXT, redox :: RedoxStore reff | eff))
dispatch this dsl = do
  { dispatch: disp } <- _.redox <$> readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) }) ) this
  disp dsl

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, runFn2, runFn3)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Canceler (redox :: RedoxStore reff | eff))

-- | Shallowly compare to objects.  If the third argument is true it skips
-- | comapring the `key` property which should not be accessed on a property
-- | object.
foreign import unsafeShallowEqual :: forall a. Fn3 Boolean a a Boolean

-- | Compare two objects using strict equality `===`
foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

type RedoxContext state dsl reff eff =
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

type ConnectState state = { state :: state, sid :: Maybe SubscriptionId }

_connect
  :: forall state state' dsl props props' reff eff
   . (ReactThis props' (ConnectState state')
      -> Eff
        (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff)
        (RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff)
     )
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = componentDidMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      void $ writeState this (st { state = view _lns state })

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to ctxEff
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    -- | Subscription to redox store happens in `componentDidMount`, rather than
    -- | on `componentWillMount`.  This is because `componentWillUnmount` and
    -- | `componentDidMount` do not fire in SSR. Otherwise we'd have a memory
    -- | leak.  Note that if a child triggers an action in its
    -- | `componentWillMount` it's change might be
    -- | missed.
    componentDidMount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      st <- readState this
      void $ writeState this (st { sid = Just sid })

    componentWillUnmount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      { sid: msid } <- R.readState this
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    shouldComponentUpdate this nPr nSt = do
      pr <- getProps this
      st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn3 unsafeShallowEqual false pr nPr)

    renderFn this = do
      props' <- R.getProps this
      children <- R.getChildren this
      ctx <- unsafeCoerceEff $ ctxEff this
      { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') children

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' dsl props props' reff eff
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = _.redox <$> ctx
      where
        ctx = readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })) this

connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p _lns _iso cls = accessContext $ R.createClass $ connect' p _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' reff eff
   . Store state
  -> DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure {store, dispatch: dispatch_}) _lns _iso cls

dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Canceler (context :: CONTEXT, redox :: RedoxStore reff | eff))
dispatch this dsl = do
  { dispatch: disp } <- _.redox <$> readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) }) ) this
  disp dsl


View signer in a table

View signer in a table

module App.View where

import App.State (Event(..), State)
import App.State.FileInputs as FileInputs
import App.State.Files as Files
import App.State.Signers as Signers
import Data.Map (toUnfoldable)
import Data.Maybe (Maybe(..), maybe)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Lib.SignHash.Types (HashSigner(..), ProofMethod, ProofVerification(..))
import Prelude (Unit, discard, show, unit, ($), (<>))
import Pux.DOM.Events (onChange, onDragOver, onDrop)
import Pux.DOM.HTML (HTML, child)
import Text.Smolder.HTML
import Text.Smolder.HTML.Attributes (className, for, id, type')
import Text.Smolder.Markup (text, (!), (#!))

loading :: String
loading = "Loading..."

renderRow :: forall a. String -> String -> HTML a
renderRow label value =
  tr $ do
    th $ text label
    td $ text value

view :: State -> HTML Event
view { file, signer } =
  do
    div ! className "content" $ do
      h1 $ text "SignHash"
      hr
      child FileInput viewFileInput unit
      hr
      h4 $ text "File status"
      div fileStatus
      hr
      h4 $ text "Signers"
      div signerStatus

  where
    fileStatus = case file of
      Nothing ->
        div $ text "Please provide a file"
      Just value -> viewFile value

    signerStatus = case signer of
      Nothing -> div $ text "No signer"
      Just value -> child Signer viewSigner value

viewFileInput :: Unit -> HTML FileInputs.Event
viewFileInput _ =
  div do
    label
      ! for "file-upload"
      ! className "file-upload"
      #! onDrop FileInputs.newFilesEvent
      #! onDragOver (FileInputs.PreventDefault FileInputs.NoOp)
      $ div do
        h3 $ text "Click or drag and drop files"

    input
      ! id "file-upload"
      ! type' "file"
      #! onChange FileInputs.newFilesEvent

viewFile :: Files.State -> HTML Event
viewFile { meta, result, signer } =
  table ! className "u-full-width" $ tbody $ do
    renderRow "FileName" meta.name
    renderRow "Size" $ show meta.size <> " Bytes"
    renderRow "SHA256" $ maybe loading _.hash result
    renderRow "Signer address" $ maybe loading renderSigner signer

  where
    renderSigner (HashSigner address) = address
    renderSigner NoSigner = "Not signed"

viewSigner :: Signers.State -> HTML Signers.Event
viewSigner { address, proofs } = do
  div $ do
    h5 $ text $ "#" <> address
    viewProofs proofs

viewProofs :: Signers.SignerProofs -> HTML Signers.Event
viewProofs proofs =
  table ! className "u-full-width" $ do
    thead $ tr do
      th $ text "Method"
      th $ text "Verification"
    tbody $ for_ unfolded renderProof
  where
    unfolded :: Array (Tuple ProofMethod Signers.ProofState)
    unfolded = toUnfoldable proofs

    renderProof (Tuple method state) = do
      tr do
        td $ text $ show method
        td $ text $ viewProofState state

    viewProofState Signers.Pending = "Pending..."
    viewProofState Signers.NetworkError = "Network error"
    viewProofState (Signers.Finished (Verified msg)) =
      "Verified: " <> msg
    viewProofState (Signers.Finished (Unverified msg)) =
      "Verification failed: " <> msg
    viewProofState (Signers.Finished Unavailable) =
      "No proof defined"

module App.View where

import App.State (Event(..), State)
import App.State.FileInputs as FileInputs
import App.State.Files as Files
import App.State.Signers as Signers
import Data.Map (toUnfoldable)
import Data.Maybe (Maybe(..), maybe)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Lib.SignHash.Types (HashSigner(..), ProofMethod, ProofVerification(..))
import Prelude hiding (div,id)
import Pux.DOM.Events (onChange, onDragOver, onDrop)
import Pux.DOM.HTML (HTML, child)
import Text.Smolder.HTML (div, h1, h3, h4, hr, input, label, li, table, tbody, td, th, tr, ul)
import Text.Smolder.HTML.Attributes (className, for, id, type')
import Text.Smolder.Markup (text, (!), (#!))

view :: State -> HTML Event
view { file, signer } =
  do
    div ! className "content" $ do
      h1 $ text "SignHash"
      hr
      child FileInput viewFileInput unit
      hr
      h4 $ text "File status"
      div fileStatus
      hr
      div signerStatus

  where
    fileStatus = case file of
      Nothing ->
        div $ text "Please provide a file"
      Just value -> viewFile value

    signerStatus = case signer of
      Nothing -> div $ text "No signer"
      Just value -> child Signer viewSigner value

viewFileInput :: Unit -> HTML FileInputs.Event
viewFileInput _ =
  div do
    label
      ! for "file-upload"
      ! className "file-upload"
      #! onDrop FileInputs.newFilesEvent
      #! onDragOver (FileInputs.PreventDefault FileInputs.NoOp)
      $ div do
        h3 $ text "Click or drag and drop files"

    input
      ! id "file-upload"
      ! type' "file"
      #! onChange FileInputs.newFilesEvent

viewFile :: Files.State -> HTML Event
viewFile { meta, result, signer } =
  div do
    table ! className "u-full-width" $ tbody $ do
      renderRow "FileName" meta.name
      renderRow "Size" $ show meta.size <> " Bytes"
      renderRow "SHA256" $ maybe loading _.hash result
      renderRow "Signer address" $ maybe loading renderSigner signer

  where
    loading = "Loading..."
    renderRow label value =
      tr $ do
        th $ text label
        td $ text value

    renderSigner (HashSigner address) = address
    renderSigner NoSigner = "Not signed"

viewSigner :: Signers.State -> HTML Signers.Event
viewSigner { address, proofs } =
  div do
    div $ text "Signer"
    div $ text ("Address: " <> address)
    div $ text "Proofs:"
    viewProofs proofs

viewProofs :: Signers.SignerProofs -> HTML Signers.Event
viewProofs proofs =
  ul $ for_ unfolded renderProof
  where
    unfolded :: Array (Tuple ProofMethod Signers.ProofState)
    unfolded = toUnfoldable proofs
    renderProof (Tuple method state) = do
      li do
        div $ text ("Method: " <> show method)
        div $ text ("Verification: " <> viewProofState state)

    viewProofState Signers.Pending = "Pending..."
    viewProofState Signers.NetworkError = "Network error"
    viewProofState (Signers.Finished (Verified msg)) =
      "Verified: " <> msg
    viewProofState (Signers.Finished (Unverified msg)) =
      "Verification failed: " <> msg
    viewProofState (Signers.Finished Unavailable) =
      "No proof defined"


Fixed setIntF bug and refactored the debug traces into a separate function

module Core where

import Prelude
import Data.Int.Bits
import Data.Tuple
import Data.Maybe
import Data.Either
import Control.Monad.Eff

import Types
import MainMem
import Ops
import OpCodeMap
import Gpu
import Utils
import Control.Monad.Rec.Class

import Debug

reset :: forall e. Array I8 -> Eff (canvas :: Canvas | e) Z80State
reset rom = do
  resetScreen
  return
    cleanState {
      mem = cleanMem {
        mainMem = setRom rom cleanMainMem
      }
    }

run :: forall e. Int -> Z80State -> Eff (canvas :: Canvas | e) Z80State
run interval state = tailRecM go { intr : interval, st : state }
 where
  go { st = st@{stop = true} } = return $ Right state
  go { intr, st } | intr <= 0 = return $ Right state
  go { intr, st } = do
    st' <- step st
    let elapsed = st'.totalM - st.totalM
    return $ Left { intr : (intr - elapsed), st : st' }

--NOTE Reg r should be increased by 1?
step :: forall e. Z80State -> Eff (canvas :: Canvas | e) Z80State
step state@{ mem = oldMem@{regs = oldRegs} } =
  hndlGpu <<< incTime <<< incPc oldRegs.pc <<< op $
    traceState $ state
 where
  incTime st@{totalM} = st
    { totalM = st.totalM + st.mem.regs.m }

  hndlGpu st = do
    gpu' <- gpuStep st.mem.regs.m (getGpu st.mem.mainMem)
    let intF' = (if gpu'.vblIntrr then (0x01 .|. _) else id) $ getIntF st.mem.mainMem
    return $ st { mem = st.mem { mainMem =
          setIntF intF'
      <<< setGpu (gpu' { vblIntrr = false })
       $  st.mem.mainMem } }

  op st = if shldHndlIntrr st
    then interruptOp st
    else regularOp st

  shldHndlIntrr st = getIme st.mem.mainMem && intBits st /= 0

  regularOp st = getOpcode (opCode st) basicOps $ st
  opCode st = rd8 st.mem.regs.pc st.mem.mainMem

  interruptOp :: Z80State -> Z80State
  interruptOp st = snd res $
    st { mem = st.mem {
      mainMem = setIme false <<< setIntF (fst res $ getIntF st.mem.mainMem) $ st.mem.mainMem } }
   where
    res :: Tuple (Int -> Int) (Z80State -> Z80State)
    res = fromMaybe (Tuple id id) mRes
    mRes = getOnBit (intBits st) >>= \x -> case x of
             1  -> Just $ Tuple (0xFE .&. _) (mm2op $ callRoutine 0x40)
             2  -> Just $ Tuple (0xFD .&. _) (mm2op $ callRoutine 0x48)
             4  -> Just $ Tuple (0xFB .&. _) (mm2op $ callRoutine 0x50)
             8  -> Just $ Tuple (0xF7 .&. _) (mm2op $ callRoutine 0x58)
             16 -> Just $ Tuple (0xEF .&. _) (mm2op $ callRoutine 0x60)
             otherwise -> Nothing -- NOTE log this

  intBits st = getIntE st.mem.mainMem .&. getIntF st.mem.mainMem

  --NOTE is there a better way to set nested properties?
  --consider checking the lens-equivalent in purescript.
  incPc oldPc st =
    if oldPc /= st.mem.regs.pc
      then st
      else
        st {
          mem = st.mem {
            regs = st.mem.regs {
              pc = 65535 .&. (st.mem.regs.pc + 1)
            }
          }
        }

cleanState :: Z80State
cleanState =
  { mem : cleanMem
  , totalM : 0
  , halt : false
  , stop : false
  }

cleanMem :: Mem
cleanMem =
  { regs : cleanRegs
  , svdRegs : cleanSavedRegs
  , mainMem : cleanMainMem
  }

cleanRegs :: Regs
cleanRegs =
  { pc : 0x0200
  , sp : 0xCFF7
  , ime : true
  , m  : 0
  , a  : 0
  , b  : 0
  , c  : 0
  , d  : 0
  , e  : 0xD8
  , h  : 0x97
  , l  : 0xFF
  , f  : 0x80
  }

cleanSavedRegs :: SavedRegs
cleanSavedRegs =
  { a  : 0
  , b  : 0
  , c  : 0
  , d  : 0
  , e  : 0
  , h  : 0
  , l  : 0
  , f  : 0
  }

--Debug functions

traceState :: Z80State -> Z80State
traceState state@{ mem = oldMem@{regs = oldRegs} } =
  condTr shldTrc (\_ -> "-----------") $
  condTr shldTrc (\_ -> "totalM: "++show state.totalM) $

  {--condTr shldTrc (\_ -> tileMap0Str mem) $--}

  condTr shldTrc (\_ -> ioArea oldMem) $
  condTr shldTrc (\_ -> pcArea oldMem) $
  condTr shldTrc (\_ -> spArea oldMem) $

  {--condTr shldTrc (\_ -> "IntF: " ++ toHexStr 2 intF) $--}
  {--condTr shldTrc (\_ -> "IntE: " ++ toHexStr 2 intE) $--}
  {--condTr shldTrc (\_ -> "Ime: " ++ show (getIme state.mem.mainMem)) $--}
  {--condTr shldTrc (\_ -> "IntBits: " ++ toHexStr 2 intBits) $--}
  {--condTr shldTrc (\_ -> "getOnBit: " ++ show (getOnBit intBits)) $--}
  {--condTr shldTrc (\_ -> "shldHndlIntrr: " ++ show (shldHndlIntrr state)) $--}
  {--condTr shldTrc (\_ -> "intF after interruptop: " ++ toHexStr 2 (getIntF (interruptOp state).mem.mainMem)) $--}
  condTr shldTrc (\_ -> regsStr oldRegs) $
  {--condTr shldTrc (\_ -> rd8RangeStr "FF85" 0xFF85 0xFF85 mem) $--}
  state
 where
  shldTrc = true
  {--shldTrc = state.totalM >= 125000--}
  {--shldTrc = oldRegs.pc == 0x0371 || oldRegs.pc == 0x0200--}
  {--shldTrc2 = regs.pc == 0x0407--}

regsStr :: Regs -> String
regsStr regs = "af: " ++ af
          ++ "\nbc: " ++ bc
          ++ "\nde: " ++ de
          ++ "\nhl: " ++ hl
          ++ "\nsp: " ++ sp
          ++ "\npc: " ++ pc
 where
  af = toHexStr 4 $ joinRegs a f regs
  bc = toHexStr 4 $ joinRegs b c regs
  de = toHexStr 4 $ joinRegs d e regs
  hl = toHexStr 4 $ joinRegs h l regs
  sp = toHexStr 4 $ regs.sp
  pc = toHexStr 4 $ regs.pc

module Core where

import Prelude
import Data.Int.Bits
import Data.Tuple
import Data.Maybe
import Data.Either
import Control.Monad.Eff

import Types
import MainMem
import Ops
import OpCodeMap
import Gpu
import Utils
import Control.Monad.Rec.Class

import Debug

reset :: forall e. Array I8 -> Eff (canvas :: Canvas | e) Z80State
reset rom = do
  resetScreen
  return
    cleanState {
      mem = cleanMem {
        mainMem = setRom rom cleanMainMem
      }
    }

run :: forall e. Int -> Z80State -> Eff (canvas :: Canvas | e) Z80State
run interval state = tailRecM go { intr : interval, st : state }
 where
  go { st = st@{stop = true} } = return $ Right state
  go { intr, st } | intr <= 0 = return $ Right state
  go { intr, st } = do
    st' <- step st
    let elapsed = st'.totalM - st.totalM
    return $ Left { intr : (intr - elapsed), st : st' }

--NOTE Reg r should be increased by 1?
step :: forall e. Z80State -> Eff (canvas :: Canvas | e) Z80State
step state@{ mem=mem@{regs} } =
  hndlGpu <<< incTime <<< incPc (regs.pc) <<< op $
    {--trace (gpuRegsStr mem) \_ ->--}
    {--trace (pcArea mem) \_ ->--}
    {--trace (spArea mem) \_ ->--}
    {--trace (regsStr regs) \_ ->--}
    state
 where
  -- NOTE: change fromMaybe with something that will log exceptional cases.

  incTime st@{totalM} = st
    { totalM = st.totalM + regs.m }

  hndlGpu st = do
    gpu' <- gpuStep regs.m (getGpu st.mem.mainMem)
    let intF' = (if gpu'.vblIntrr then (0x01 .|. _) else id) $ intF
    return $ st { mem = st.mem { mainMem =
          setIntF intF'
      <<< setGpu (gpu' { vblIntrr = false })
       $  st.mem.mainMem } }

  op = if shldHndlIntrr
    then interruptOp
    else regularOp

  regularOp = getOpcode opCode basicOps
  opCode = rd8 regs.pc mem.mainMem

  --disable ime
  interruptOp :: Z80State -> Z80State
  interruptOp st = snd res $
    st { mem = st.mem {
      mainMem = setIme false <<< setIntF (fst res) $ st.mem.mainMem } }
   where
    res :: Tuple Int (Z80State -> Z80State)
    res = fromMaybe (Tuple intF id) mRes
    mRes = getOnBit intBits >>= \x -> case x of
             1  -> Just $ Tuple (0xFE .&. intF) (mm2op $ callRoutine 0x40)
             2  -> Just $ Tuple (0xFD .&. intF) (mm2op $ callRoutine 0x48)
             4  -> Just $ Tuple (0xFB .&. intF) (mm2op $ callRoutine 0x50)
             8  -> Just $ Tuple (0xF7 .&. intF) (mm2op $ callRoutine 0x58)
             16 -> Just $ Tuple (0xEF .&. intF) (mm2op $ callRoutine 0x60)
             otherwise -> Nothing -- NOTE log this

  shldHndlIntrr = getIme state.mem.mainMem && intBits /= 0
  intBits = intE .&. intF
  intE = getIntE state.mem.mainMem
  intF = getIntF state.mem.mainMem

  --NOTE is there a better way to set nested properties?
  --consider checking the lens-equivalent in purescript.
  incPc oldPc newState =
    if oldPc /= newState.mem.regs.pc
      then newState
      else
        newState {
          mem = newState.mem {
            regs = newState.mem.regs {
              pc = 65535 .&. (newState.mem.regs.pc + 1)
            }
          }
        }

cleanState :: Z80State
cleanState =
  { mem : cleanMem
  , totalM : 0
  , halt : false
  , stop : false
  }

cleanMem :: Mem
cleanMem =
  { regs : cleanRegs
  , svdRegs : cleanSavedRegs
  , mainMem : cleanMainMem
  }

cleanRegs :: Regs
cleanRegs =
  { pc : 0x0200
  , sp : 0xCFF7
  , ime : true
  , m  : 0
  , a  : 0
  , b  : 0
  , c  : 0
  , d  : 0
  , e  : 0xD8
  , h  : 0x97
  , l  : 0xFF
  , f  : 0x80
  }

cleanSavedRegs :: SavedRegs
cleanSavedRegs =
  { a  : 0
  , b  : 0
  , c  : 0
  , d  : 0
  , e  : 0
  , h  : 0
  , l  : 0
  , f  : 0
  }


reduce debug log

reduce debug log

module Main (main,run) where

import Debug.Trace

import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Data.Foldable (for_)

import Ace
import Ace.Types
import qualified Ace.Editor as Editor
import qualified Ace.EditSession as Session
import qualified Ace.Range as Range

import qualified Graphics.WebGL as GL
import qualified Control.Monad.JQuery as J

import WebSocket
import DefaultText
import Data.Either
import Sample

import Data.Maybe
import Data.StrMap
import Data.Tuple
import Data.Array(filter,head)

import Backend
import IR
import Mesh
import Type
import Input

import PipelineJsonDecode
import qualified Data.Argonaut as A

import qualified Data.Matrix as M
import qualified Data.Matrix4 as M

main = return unit
{-
  done - websocket setup
  done - compile button
  done - lc compiler in snap server
  done - json serializer for Pipeline
  done - embed lambdacube-webgl
    done - setup pipeline input
    done - compile/replace pipeline
  show error messages
  trace result
-}

{-
  control-b - compile/build
  control-n - new
-}
foreign import addCommand """
  function addCommand(editor) {
    return function(cmdName) {
      return function(winKey) {
        return function(macKey) {
          return function(cmd) {
            return function() {
              editor.commands.addCommand({
                name: cmdName,
                bindKey: {win: winKey,  mac: macKey},
                exec: function(editor) {
                  cmd(editor)();
                }
              });
            };
          };
        };
      };
    };
  }
""" :: forall eff . Editor -> String -> String -> String -> (Editor -> Eff (ace :: EAce | eff) Unit) -> Eff (ace :: EAce | eff) Unit

foreign import tokenTooltip """
  function tokenTooltip(editor) {
    return function(getTy) {
      return function() {
          editor.tokenTooltip = new myTokenTooltip(editor,getTy);
      };
    };
  }
""" :: forall eff . Editor -> (Int -> Int -> Eff (ace :: EAce | eff) TypeInfoRecord) -> Eff (ace :: EAce | eff) Unit

run = GL.runWebGL "glcanvas" (\s -> trace s) $ \context -> do
  -- setup pipeline input
  let inputSchema =
        { slots : fromList [ Tuple "stream"  {primitive: Triangles, attributes: fromList [Tuple "position"  TV3F, Tuple "normal" TV3F, Tuple "UVTex" TV2F]}
                           , Tuple "stream4" {primitive: Triangles, attributes: fromList [Tuple "position4" TV4F, Tuple "vertexUV" TV2F]}
                           ]
        , uniforms : fromList [Tuple "MVP" M44F, Tuple "MVP2" M44F]
        }
  pplInput <- mkWebGLPipelineInput inputSchema
  let mvp = V4 (V4 0.4692207 (-0.28573585) (-0.9593549) (-0.9574381)) (V4 0.0 2.395976 (-0.122928835) (-0.12268323)) (V4 (-1.719497) (-7.797232e-2) (-0.2617912) (-0.26126814)) (V4 0.0 0.0 3.8834958 4.0755367)
  uniformM44F "MVP" pplInput.uniformSetter mvp

  gpuCube <- compileMesh myCube

  addMesh pplInput "stream4" gpuCube []

  -- setup ace editor
  editor <- Ace.edit "editor" ace
  session <- Editor.getSession editor
  Editor.setTheme "ace/theme/terminal" editor
  Session.setMode "ace/mode/haskell" session
  Session.setValue defaultSrc session
  range <- Range.create 8 0 9 0
  Session.addMarker range "lc_error" "line" false session
  typeInfoRef <- newRef []
  let getTypeInfo l c = do
        x <- readRef typeInfoRef
        return $ case head $ flip filter x $ \(TypeInfo i) -> i.startLine == l && l == i.endLine && i.startColumn <= c && c <= i.endColumn of
          Nothing ->
              { startLine   : 10
              , startColumn : 2
              , endLine     : 10
              , endColumn   : 10
              , text        : ""
              }
          Just a -> case a of
            TypeInfo i -> i
  tokenTooltip editor getTypeInfo

  b <- J.body
  ui <- J.find "ui" b
  btnCompile <- J.create "<button>"
  J.setText "Compile" btnCompile
  btnCompile `J.append` b

  let compile s = do
        src <- Session.getValue session
        send s src

      render ir = do
        trace "WebGL ready"
        ppl <- allocPipeline ir -- gfx03Pipeline -- samplePipeline
        trace "Pipeline allocated"

        setPipelineInput ppl (Just pplInput)
        sortSlotObjects pplInput
        trace "Setup pipeline input"

        renderPipeline ppl
        trace "WebGL completed"
        disposePipeline ppl
        trace "Pipeline disposed"

  socket <- webSocket "ws://localhost:8000/compile" $
    { onOpen    : \s -> do
        trace "socket is ready"
        compile s
    , onClose   : trace "socket is closed"
    , onMessage : \s m -> do
        case A.jsonParser m >>= A.decodeJson of
          Left e -> trace $ "decode error: " ++ e
          Right (MyLeft e) -> trace $ "compile error: " ++ e
          Right (MyRight p infos) -> do
            render p
            writeRef typeInfoRef infos
    , onError   : \s m -> trace m
    }
  case socket of
    Left m -> trace $ "error: " ++ m
    Right ws -> do
      flip (J.on "click") btnCompile $ \_ _ -> do
        compile ws
        trace "clicked compile"
      addCommand editor "Compile" "Ctrl-B" "Command-B" (\_ -> compile ws)
      return unit

module Main (main,run) where

import Debug.Trace

import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Data.Foldable (for_)

import Ace
import Ace.Types
import qualified Ace.Editor as Editor
import qualified Ace.EditSession as Session
import qualified Ace.Range as Range

import qualified Graphics.WebGL as GL
import qualified Control.Monad.JQuery as J

import WebSocket
import DefaultText
import Data.Either
import Sample

import Data.Maybe
import Data.StrMap
import Data.Tuple
import Data.Array(filter,head)

import Backend
import IR
import Mesh
import Type
import Input

import PipelineJsonDecode
import qualified Data.Argonaut as A

import qualified Data.Matrix as M
import qualified Data.Matrix4 as M

main = return unit
{-
  done - websocket setup
  done - compile button
  done - lc compiler in snap server
  done - json serializer for Pipeline
  done - embed lambdacube-webgl
    done - setup pipeline input
    done - compile/replace pipeline
  show error messages
  trace result
-}

{-
  control-b - compile/build
  control-n - new
-}
foreign import addCommand """
  function addCommand(editor) {
    return function(cmdName) {
      return function(winKey) {
        return function(macKey) {
          return function(cmd) {
            return function() {
              editor.commands.addCommand({
                name: cmdName,
                bindKey: {win: winKey,  mac: macKey},
                exec: function(editor) {
                  cmd(editor)();
                }
              });
            };
          };
        };
      };
    };
  }
""" :: forall eff . Editor -> String -> String -> String -> (Editor -> Eff (ace :: EAce | eff) Unit) -> Eff (ace :: EAce | eff) Unit

foreign import tokenTooltip """
  function tokenTooltip(editor) {
    return function(getTy) {
      return function() {
          editor.tokenTooltip = new myTokenTooltip(editor,getTy);
      };
    };
  }
""" :: forall eff . Editor -> (Int -> Int -> Eff (ace :: EAce | eff) TypeInfoRecord) -> Eff (ace :: EAce | eff) Unit

run = GL.runWebGL "glcanvas" (\s -> trace s) $ \context -> do
  -- setup pipeline input
  let inputSchema =
        { slots : fromList [ Tuple "stream"  {primitive: Triangles, attributes: fromList [Tuple "position"  TV3F, Tuple "normal" TV3F, Tuple "UVTex" TV2F]}
                           , Tuple "stream4" {primitive: Triangles, attributes: fromList [Tuple "position4" TV4F, Tuple "vertexUV" TV2F]}
                           ]
        , uniforms : fromList [Tuple "MVP" M44F, Tuple "MVP2" M44F]
        }
  pplInput <- mkWebGLPipelineInput inputSchema
  let mvp = V4 (V4 0.4692207 (-0.28573585) (-0.9593549) (-0.9574381)) (V4 0.0 2.395976 (-0.122928835) (-0.12268323)) (V4 (-1.719497) (-7.797232e-2) (-0.2617912) (-0.26126814)) (V4 0.0 0.0 3.8834958 4.0755367)
  uniformM44F "MVP" pplInput.uniformSetter mvp

  gpuCube <- compileMesh myCube

  addMesh pplInput "stream4" gpuCube []

  -- setup ace editor
  editor <- Ace.edit "editor" ace
  session <- Editor.getSession editor
  Editor.setTheme "ace/theme/terminal" editor
  Session.setMode "ace/mode/haskell" session
  Session.setValue defaultSrc session
  range <- Range.create 8 0 9 0
  Session.addMarker range "lc_error" "line" false session
  typeInfoRef <- newRef []
  let getTypeInfo l c = do
        x <- readRef typeInfoRef
        return $ case head $ flip filter x $ \(TypeInfo i) -> i.startLine == l && l == i.endLine && i.startColumn <= c && c <= i.endColumn of
          Nothing ->
              { startLine   : 10
              , startColumn : 2
              , endLine     : 10
              , endColumn   : 10
              , text        : ""
              }
          Just a -> case a of
            TypeInfo i -> i
  tokenTooltip editor getTypeInfo

  b <- J.body
  ui <- J.find "ui" b
  btnCompile <- J.create "<button>"
  J.setText "Compile" btnCompile
  btnCompile `J.append` b

  let compile s = do
        src <- Session.getValue session
        send s src

      render ir = do
        trace "WebGL ready"
        ppl <- allocPipeline ir -- gfx03Pipeline -- samplePipeline
        trace "Pipeline allocated"

        setPipelineInput ppl (Just pplInput)
        sortSlotObjects pplInput
        trace "Setup pipeline input"

        renderPipeline ppl
        trace "WebGL completed"
        disposePipeline ppl
        trace "Pipeline disposed"

  socket <- webSocket "ws://localhost:8000/compile" $
    { onOpen    : \s -> do
        trace "socket is ready"
        compile s
    , onClose   : trace "socket is closed"
    , onMessage : \s m -> do
        trace m
        case A.jsonParser m >>= A.decodeJson of
          Left e -> trace $ "decode error: " ++ e
          Right (MyLeft e) -> trace $ "compile error: " ++ e
          Right (MyRight p infos) -> do
            render p
            writeRef typeInfoRef infos
    , onError   : \s m -> trace m
    }
  case socket of
    Left m -> trace $ "error: " ++ m
    Right ws -> do
      flip (J.on "click") btnCompile $ \_ _ -> do
        compile ws
        trace "clicked compile"
      addCommand editor "Compile" "Ctrl-B" "Command-B" (\_ -> compile ws)
      return unit


format entry

format entry

module Main
  ( main
  ) where

import Prelude

import Bouzuya.CommandLineOption as CommandLineOption
import Control.Promise (Promise)
import Control.Promise as Promise
import Data.Array as Array
import Data.Either as Either
import Data.Maybe (Maybe)
import Data.Maybe as Maybe
import Effect (Effect)
import Effect.Aff as Aff
import Effect.Class.Console as Console
import Effect.Exception as Exception
import Foreign.Object as Object
import Node.Process as Process
import Record as Record

foreign import data Client :: Type
foreign import data Response :: Type
foreign import newClient ::
  { apiKey :: String
  , authType :: String -- basic or wsse
  , blogId :: String
  , hatenaId :: String
  } -> Effect Client
foreign import create ::
  forall r. { | r } -> Client -> Effect (Promise Response)
foreign import delete :: String -> Client -> Effect (Promise Response)
foreign import edit ::
  forall r. String -> { | r } -> Client -> Effect (Promise Response)
foreign import list ::
  Client ->
  Effect
    (Promise
      (Array
        { authorName :: String
        , content :: String
        , contentType :: String
        , draft :: Boolean
        , editUrl :: String
        , edited :: String
        , formattedContent :: String
        , htmlUrl :: String
        , id :: String
        , published :: String
        , summary :: String
        , title :: String
        , updated :: String
        }))
foreign import retrieve :: String -> Client -> Effect (Promise Response)

type Config =
  { apiKey :: String
  , blogId :: String
  , hatenaId :: String
  }

loadConfig :: Effect (Maybe Config)
loadConfig = do
  env <- Process.getEnv
  pure do
    apiKey <- Object.lookup "HATENA_API_KEY" env
    blogId <- Object.lookup "HATENA_BLOG_ID" env
    hatenaId <- Object.lookup "HATENA_ID" env
    pure { apiKey, blogId, hatenaId }
main :: Effect Unit
main = do
  configMaybe <- loadConfig
  config <- Maybe.maybe (Exception.throw "invalid config") pure configMaybe
  client <- newClient (Record.merge config { authType: "wsse" })
  args <- map (Array.drop 2) Process.argv
  { arguments } <-
    Either.either
      (const (Exception.throw "invalid option"))
      pure
      (CommandLineOption.parse {} args)
  command <-
    Maybe.maybe
      (Exception.throw "no command")
      pure
      (Array.index arguments 0)
  case command of
    "index" -> Aff.launchAff_ do
      response <- Promise.toAffE (list client)
      Console.log
        (Array.intercalate
          "\n"
          (map (\{ published, title } -> published <> " " <> title) response))
    _ -> -- TODO
      Console.log command

module Main
  ( main
  ) where

import Prelude

import Bouzuya.CommandLineOption as CommandLineOption
import Control.Promise (Promise)
import Control.Promise as Promise
import Data.Array as Array
import Data.Either as Either
import Data.Maybe (Maybe)
import Data.Maybe as Maybe
import Effect (Effect)
import Effect.Aff as Aff
import Effect.Class.Console as Console
import Effect.Exception as Exception
import Foreign.Object as Object
import Node.Process as Process
import Record as Record

foreign import data Client :: Type
foreign import data Response :: Type
foreign import newClient ::
  { apiKey :: String
  , authType :: String -- basic or wsse
  , blogId :: String
  , hatenaId :: String
  } -> Effect Client
foreign import create ::
  forall r. { | r } -> Client -> Effect (Promise Response)
foreign import delete :: String -> Client -> Effect (Promise Response)
foreign import edit ::
  forall r. String -> { | r } -> Client -> Effect (Promise Response)
foreign import list ::
  Client ->
  Effect
    (Promise
      (Array
        { authorName :: String
        , content :: String
        , contentType :: String
        , draft :: Boolean
        , editUrl :: String
        , edited :: String
        , formattedContent :: String
        , htmlUrl :: String
        , id :: String
        , published :: String
        , summary :: String
        , title :: String
        , updated :: String
        }))
foreign import retrieve :: String -> Client -> Effect (Promise Response)

type Config =
  { apiKey :: String
  , blogId :: String
  , hatenaId :: String
  }

loadConfig :: Effect (Maybe Config)
loadConfig = do
  env <- Process.getEnv
  pure do
    apiKey <- Object.lookup "HATENA_API_KEY" env
    blogId <- Object.lookup "HATENA_BLOG_ID" env
    hatenaId <- Object.lookup "HATENA_ID" env
    pure { apiKey, blogId, hatenaId }
main :: Effect Unit
main = do
  configMaybe <- loadConfig
  config <- Maybe.maybe (Exception.throw "invalid config") pure configMaybe
  client <- newClient (Record.merge config { authType: "wsse" })
  args <- map (Array.drop 2) Process.argv
  { arguments } <-
    Either.either
      (const (Exception.throw "invalid option"))
      pure
      (CommandLineOption.parse {} args)
  command <-
    Maybe.maybe
      (Exception.throw "no command")
      pure
      (Array.index arguments 0)
  case command of
    "index" -> Aff.launchAff_ do
      response <- Promise.toAffE (list client)
      Console.logShow response -- TODO: format
    _ -> -- TODO
      Console.log command


Added strMapToYaml instance

Added strMapToYaml instance

module Data.YAML.Foreign.Encode where

import Data.Map as M
import Data.StrMap as StrMap
import Data.Array (toUnfoldable)
import Data.Function.Uncurried (Fn4, runFn4)
import Data.List (List)
import Data.Maybe (Maybe, maybe)
import Data.StrMap (StrMap, insert)
import Data.Tuple (Tuple(..), fst, snd)
import Prelude (class Eq, class Show, map, show, ($), (<>), (==), (<<<))
import Unsafe.Coerce (unsafeCoerce)

type YObject = M.Map String YValue
type YArray = Array YValue
foreign import data YAML :: Type

data YValue
    = YObject YObject
    | YArray YArray
    | YString String
    | YNumber Number
    | YInt Int
    | YBoolean Boolean
    | YNull

instance showYValue :: Show YValue where
    show (YObject m) = "YObject " <> show m
    show (YArray vs) = "YArray " <> show vs
    show (YString s) = "YString " <> show s
    show (YNumber n) = "YNumber " <> show n
    show (YInt i) = "YInt " <> show i
    show (YBoolean b) = "YBoolean " <> show b
    show YNull = "YNull"

instance eqYValue :: Eq YValue where
    eq (YObject a) (YObject b) = a == b
    eq (YArray a) (YArray b) = a == b
    eq (YString a) (YString b) = a == b
    eq (YNumber a) (YNumber b) = a == b
    eq (YInt a) (YInt b) = a == b
    eq (YBoolean a) (YBoolean b) = a == b
    eq YNull YNull = true
    eq _ _ = false

class ToYAML a where
    toYAML :: a -> YValue

instance strMapToYAML :: (ToYAML a) => ToYAML (StrMap a) where
    toYAML strMap = YObject $ StrMap.fold (\acc key value -> M.insert key (toYAML value) acc) M.empty strMap

instance booleanToYAML :: ToYAML Boolean where
    toYAML = YBoolean

instance intToYAML :: ToYAML Int where
    toYAML = YInt

instance numberToYAML :: ToYAML Number where
    toYAML = YNumber

instance stringToYAML :: ToYAML String where
    toYAML = YString

instance arrayToYAML :: (ToYAML a) => ToYAML (Array a) where
    toYAML = YArray <<< map toYAML

instance maybeToYAML :: (ToYAML a) => ToYAML (Maybe a) where
    toYAML = maybe YNull toYAML

type Pair = Tuple String YValue

-- | Helper function to create a key-value tuple for a YAML object.
-- |
-- | `name = "Name" := "This is the name"`
entry :: forall a. (ToYAML a) => String -> a -> Pair
entry name value = Tuple name (toYAML value)

infixl 4 entry as :=

-- | Helper function to create a YAML object.
-- |
-- | `obj = object [ "Name" := "This is the name", "Size" := 1.5 ]`
object :: Array Pair -> YValue
object ps = YObject $ M.fromFoldable (toUnfoldable ps :: List Pair)

foreign import jsNull :: YAML
foreign import objToHash ::
    Fn4 (YValue -> YAML)
        (Tuple String YValue -> String)
        (Tuple String YValue -> YValue)
        (Array (Tuple String YValue))
        YAML

valueToYAML :: YValue -> YAML
valueToYAML (YObject o) = runFn4 objToHash valueToYAML fst snd $ M.toUnfoldable o
valueToYAML (YArray a) = unsafeCoerce $ map valueToYAML a
valueToYAML (YString s) = unsafeCoerce s
valueToYAML (YNumber n) = unsafeCoerce n
valueToYAML (YInt i) = unsafeCoerce i
valueToYAML (YBoolean b) = unsafeCoerce b
valueToYAML YNull = jsNull

foreign import toYAMLImpl :: YAML -> String

printYAML :: forall a. (ToYAML a) => a -> String
printYAML = toYAMLImpl <<< valueToYAML <<< toYAML

module Data.YAML.Foreign.Encode where

import Data.Map as M
import Data.Array (toUnfoldable)
import Data.Function.Uncurried (Fn4, runFn4)
import Data.List (List)
import Data.Maybe (Maybe, maybe)
import Data.Tuple (Tuple(..), fst, snd)
import Prelude (class Eq, class Show, map, show, ($), (<>), (==), (<<<))
import Unsafe.Coerce (unsafeCoerce)

type YObject = M.Map String YValue
type YArray = Array YValue
foreign import data YAML :: Type

data YValue
    = YObject YObject
    | YArray YArray
    | YString String
    | YNumber Number
    | YInt Int
    | YBoolean Boolean
    | YNull

instance showYValue :: Show YValue where
    show (YObject m) = "YObject " <> show m
    show (YArray vs) = "YArray " <> show vs
    show (YString s) = "YString " <> show s
    show (YNumber n) = "YNumber " <> show n
    show (YInt i) = "YInt " <> show i
    show (YBoolean b) = "YBoolean " <> show b
    show YNull = "YNull"

instance eqYValue :: Eq YValue where
    eq (YObject a) (YObject b) = a == b
    eq (YArray a) (YArray b) = a == b
    eq (YString a) (YString b) = a == b
    eq (YNumber a) (YNumber b) = a == b
    eq (YInt a) (YInt b) = a == b
    eq (YBoolean a) (YBoolean b) = a == b
    eq YNull YNull = true
    eq _ _ = false

class ToYAML a where
    toYAML :: a -> YValue

instance booleanToYAML :: ToYAML Boolean where
    toYAML = YBoolean

instance intToYAML :: ToYAML Int where
    toYAML = YInt

instance numberToYAML :: ToYAML Number where
    toYAML = YNumber

instance stringToYAML :: ToYAML String where
    toYAML = YString

instance arrayToYAML :: (ToYAML a) => ToYAML (Array a) where
    toYAML = YArray <<< map toYAML

instance maybeToYAML :: (ToYAML a) => ToYAML (Maybe a) where
    toYAML = maybe YNull toYAML

type Pair = Tuple String YValue

-- | Helper function to create a key-value tuple for a YAML object.
-- |
-- | `name = "Name" := "This is the name"`
entry :: forall a. (ToYAML a) => String -> a -> Pair
entry name value = Tuple name (toYAML value)

infixl 4 entry as :=

-- | Helper function to create a YAML object.
-- |
-- | `obj = object [ "Name" := "This is the name", "Size" := 1.5 ]`
object :: Array Pair -> YValue
object ps = YObject $ M.fromFoldable (toUnfoldable ps :: List Pair)

foreign import jsNull :: YAML
foreign import objToHash ::
    Fn4 (YValue -> YAML)
        (Tuple String YValue -> String)
        (Tuple String YValue -> YValue)
        (Array (Tuple String YValue))
        YAML

valueToYAML :: YValue -> YAML
valueToYAML (YObject o) = runFn4 objToHash valueToYAML fst snd $ M.toUnfoldable o
valueToYAML (YArray a) = unsafeCoerce $ map valueToYAML a
valueToYAML (YString s) = unsafeCoerce s
valueToYAML (YNumber n) = unsafeCoerce n
valueToYAML (YInt i) = unsafeCoerce i
valueToYAML (YBoolean b) = unsafeCoerce b
valueToYAML YNull = jsNull

foreign import toYAMLImpl :: YAML -> String

printYAML :: forall a. (ToYAML a) => a -> String
printYAML = toYAMLImpl <<< valueToYAML <<< toYAML


Fix warnings

Fix warnings

module Yesod.Auth
  ( Endpoint()
  , LoginSuccess(..)
  , LoginError(..)
  , login
  , login'
  , logout
  , logout'
  ) where

import Control.Monad.Aff (Aff())
import DOM (DOM())
import Data.Maybe (Maybe(Just, Nothing))
import Network.HTTP.Affjax (AJAX())
import Network.HTTP.Affjax (post, post') as Ajax
import Prelude (class Eq, class Show, Unit, (>>>), map, (<$>), (<<<))

import Data.Generic (class Generic, gShow, gEq)
import Data.Tuple (Tuple(..))
import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.String as String
import Data.Foreign.Class (readProp) as Foreign
import Network.HTTP.Affjax.Response (class Respondable, ResponseType(..))
import Network.HTTP.MimeType.Common as Mime

import Data.FormURLEncoded (FormURLEncoded(..))

import Data.URI (printURI)
import Data.URI.Types (Authority, URIScheme, HierarchicalPart(HierarchicalPart), URI(URI))
import Data.Path.Pathy (Sandboxed, RelFile, AbsDir, file, (</>))

-- | Identifies the location of the authentication plugin.
-- | Example:
-- |
-- |     -- http://localhost:4000/auth/page/hardcoded/
-- |     myEndpoint =
-- |       { scheme: Just (URIScheme "http"
-- |       , authority:
-- |           Just (Authority
-- |                   Nothing
-- |                   [ Tuple (NameAddress "localhost" (Just 4000)) ])
-- |       , path: rootDir </> dir "auth" </> dir "page" </> dir "hardcoded"
-- |       }
type Endpoint
  = { scheme :: Maybe URIScheme
    , authority :: Maybe Authority
    , path :: AbsDir Sandboxed
    }

runEndpoint :: Endpoint -> RelFile Sandboxed -> URI
runEndpoint { scheme, authority, path } file =
  URI scheme
      (HierarchicalPart authority (Just (Left (path </> file))))
      Nothing
      Nothing

-- | Makes login query to the '/login' of the provided endpoint using given
-- | username/password. The result is returned, and the token is persisted in
-- | the session.
-- |
-- |     login myEndpoint "username" "password"
login
  :: ∀ eff.
     Endpoint
  -> String
  -> String
  -> Aff (ajax :: AJAX, dom :: DOM | eff) (Either LoginError LoginSuccess)
login endpoint = login' (printURI (runEndpoint endpoint (file "login")))

-- | This version of `login` allows to just provide URI of the '/login' endpoint
-- | as a `String`. No fancy types involved.
-- |
-- |     login' "http://localhost:7000/auth/page/hardcoded/login" "username" "password"
login'
  :: ∀ eff.
     String -- ^ URI of the login endpoint
  -> String -- ^ Username
  -> String -- ^ Password
  -> Aff (ajax :: AJAX, dom :: DOM | eff) (Either LoginError LoginSuccess)
login' uri username password =
   runLoginResponse <<< _.response <$> Ajax.post uri formquery
  where
    formquery =
      FormURLEncoded
        [ Tuple "username" (Just username)
        , Tuple "password" (Just password) ]

-- | Makes logout query to the '/logout' of the provided endpoint using given
-- | username/password.
-- |
-- |     logout myEndpoint
logout :: ∀ eff. Endpoint -> Aff (ajax :: AJAX | eff) Unit
logout endpoint = logout' (printURI (runEndpoint endpoint (file "logout")))

-- | This version of `logout` allows to just provide URI of the '/logout' endpoint
-- | as a `String`. No fancy types involved.
-- |
-- |     logout' "http://localhost:7000/auth/page/hardcoded/logout"
logout' :: ∀ eff. String -> Aff (ajax :: AJAX | eff) Unit
logout' uri = _.response <$> Ajax.post' uri (Nothing :: Maybe Unit)

newtype LoginResponse = LoginResponse (Either LoginError LoginSuccess)

runLoginResponse :: LoginResponse -> Either LoginError LoginSuccess
runLoginResponse (LoginResponse a) = a

data LoginSuccess
  = LoginSuccess

data LoginError
  = LoginError String
  | LoginUsernameNotFound String
  | LoginInvalid

derive instance genericLoginSuccess :: Generic LoginSuccess
instance showLoginSuccess :: Show LoginSuccess where show = gShow
instance eqLoginSuccess :: Eq LoginSuccess where eq = gEq

derive instance genericLoginError :: Generic LoginError
instance showLoginError :: Show LoginError where show = gShow
instance eqLoginError :: Eq LoginError where eq = gEq

derive instance genericLoginResponse :: Generic LoginResponse
instance showLoginResponse :: Show LoginResponse where show = gShow
instance eqLoginResponse :: Eq LoginResponse where eq = gEq

instance respondableLoginResponse :: Respondable LoginResponse where
  responseType = Tuple (Just Mime.applicationJSON) JSONResponse
  fromResponse = Foreign.readProp "message" >>> map (fromMessage >>> LoginResponse)
    where
      fromMessage "Login Successful" = Right LoginSuccess
      fromMessage "Invalid username/password combination" = Left LoginInvalid
      fromMessage msg =
        case String.stripPrefix "Login not found: " msg of
          Just username -> Left (LoginUsernameNotFound username)
          Nothing -> Left (LoginError msg)

module Yesod.Auth
  ( Endpoint()
  , LoginSuccess(..)
  , LoginError(..)
  , login
  , login'
  , logout
  , logout'
  ) where

import Control.Monad.Aff (Aff())
import DOM (DOM())
import Data.Maybe (Maybe(Just, Nothing))
import Network.HTTP.Affjax (AJAX())
import Network.HTTP.Affjax (post, post') as Ajax
import Prelude (class Eq, class Show, Unit, (>>>), map, (<>), (<$>), (<<<))

import Data.Generic (class Generic, gShow, gEq)
import Data.Tuple (Tuple(..))
import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.String as String
import Data.Foreign.Class (readProp) as Foreign
import Network.HTTP.Affjax.Response (class Respondable, ResponseType(..))
import Network.HTTP.MimeType.Common as Mime

import Data.FormURLEncoded (FormURLEncoded(..))

import Data.URI
import Data.URI.Types
import Data.Path.Pathy

-- | Identifies the location of the used authentication plugin.
-- | Example:
-- |
-- |     -- http://localhost:4000/auth/page/hardcoded/
-- |     myEndpoint =
-- |       { scheme: Just (URIScheme "http"
-- |       , authority:
-- |           Just (Authority
-- |                   Nothing
-- |                   [ Tuple (NameAddress "localhost" (Just 4000)) ])
-- |       , path: rootDir </> dir "auth" </> dir "page" </> dir "hardcoded"
-- |       }
type Endpoint
  = { scheme :: Maybe URIScheme
    , authority :: Maybe Authority
    , path :: AbsDir Sandboxed
    }

runEndpoint :: Endpoint -> RelFile Sandboxed -> URI
runEndpoint { scheme, authority, path } file =
  URI scheme
      (HierarchicalPart authority (Just (Left (path </> file))))
      Nothing
      Nothing

-- | Makes login query to the '/login' of the provided endpoint using given
-- | username/password. The result is returned, and the token is persisted in
-- | the session.
-- |
-- |     login myEndpoint "username" "password"
login
  :: ∀ eff.
     Endpoint
  -> String
  -> String
  -> Aff (ajax :: AJAX, dom :: DOM | eff) (Either LoginError LoginSuccess)
login endpoint = login' (printURI (runEndpoint endpoint (file "login")))

-- | This version of `login` allows to just provide URI of the '/login' endpoint
-- | as a `String`. No fancy types involved.
-- |
-- |     login' "http://localhost:7000/auth/page/hardcoded/login" "username" "password"
login'
  :: ∀ eff.
     String -- ^ URI of the login endpoint
  -> String -- ^ Username
  -> String -- ^ Password
  -> Aff (ajax :: AJAX, dom :: DOM | eff) (Either LoginError LoginSuccess)
login' uri username password =
   runLoginResponse <<< _.response <$> Ajax.post uri formquery
  where
    formquery =
      FormURLEncoded
        [ Tuple "username" (Just username)
        , Tuple "password" (Just password) ]

-- | Makes logout query to the '/logout' of the provided endpoint using given
-- | username/password.
-- |
-- |     logout myEndpoint
logout :: ∀ eff. Endpoint -> Aff (ajax :: AJAX | eff) Unit
logout endpoint = logout' (printURI (runEndpoint endpoint (file "logout")))

-- | This version of `logout` allows to just provide URI of the '/logout' endpoint
-- | as a `String`. No fancy types involved.
-- |
-- |     logout' "http://localhost:7000/auth/page/hardcoded/logout"
logout' :: ∀ eff. String -> Aff (ajax :: AJAX | eff) Unit
logout' uri = _.response <$> Ajax.post' uri (Nothing :: Maybe Unit)

newtype LoginResponse = LoginResponse (Either LoginError LoginSuccess)

runLoginResponse :: LoginResponse -> Either LoginError LoginSuccess
runLoginResponse (LoginResponse a) = a

data LoginSuccess
  = LoginSuccess

data LoginError
  = LoginError String
  | LoginUsernameNotFound String
  | LoginInvalid

derive instance genericLoginSuccess :: Generic LoginSuccess
instance showLoginSuccess :: Show LoginSuccess where show = gShow
instance eqLoginSuccess :: Eq LoginSuccess where eq = gEq

derive instance genericLoginError :: Generic LoginError
instance showLoginError :: Show LoginError where show = gShow
instance eqLoginError :: Eq LoginError where eq = gEq

derive instance genericLoginResponse :: Generic LoginResponse
instance showLoginResponse :: Show LoginResponse where show = gShow
instance eqLoginResponse :: Eq LoginResponse where eq = gEq

instance respondableLoginResponse :: Respondable LoginResponse where
  responseType = Tuple (Just Mime.applicationJSON) JSONResponse
  fromResponse = Foreign.readProp "message" >>> map (fromMessage >>> LoginResponse)
    where
      fromMessage "Login Successful" = Right LoginSuccess
      fromMessage "Invalid username/password combination" = Left LoginInvalid
      fromMessage msg =
        case String.stripPrefix "Login not found: " msg of
          Just username -> Left (LoginUsernameNotFound username)
          Nothing -> Left (LoginError msg)


Create an element from a redux class with no store

module React.Redux
  ( ReduxReactClass
  , Effects
  , REDUX
  , Reducer
  , Enhancer
  , Enhancer_
  , Store
  , createClass
  , createElement
  , createElement'
  , createStore
  , createStore'
  , reducerOptic

  , Spec
  , Render
  , GetInitialState
  , ComponentWillMount
  , ComponentDidMount
  , ComponentWillReceiveProps
  , ShouldComponentUpdate
  , ComponentWillUpdate
  , ComponentDidUpdate
  , ComponentWillUnmount
  , spec
  , spec'
  ) where

import Prelude (Unit, (<<<), (>>=), const, pure, id, unit)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)

import Data.Either (Either, either)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn2, runFn3)
import Data.Lens (Getter', Lens', Prism', matching, set, view)

import Unsafe.Coerce (unsafeCoerce)

import React as React

type Reducer action state = action -> state -> state

type Enhancer eff action state = (Reducer action state -> state -> Eff (Effects eff) (Store action state)) -> (Reducer action state -> state -> Eff (Effects eff) (Store action state))

type Enhancer_ eff action state = (Fn2 (Reducer action state) state (Eff (Effects eff) (Store action state))) -> (Fn2 (Reducer action state) state (Eff (Effects eff) (Store action state)))

type Effects eff = (redux :: REDUX | eff)

type Render props state eff f action = (f action -> f action) -> React.Render props state eff

type GetInitialState props state eff f action = (f action -> f action) -> React.GetInitialState props state eff

type ComponentWillMount props state eff f action = (f action -> f action) -> React.ComponentWillMount props state eff

type ComponentDidMount props state eff f action = (f action -> f action) -> React.ComponentDidMount props state eff

type ComponentWillReceiveProps props state eff f action = (f action -> f action) -> React.ComponentWillReceiveProps props state eff

type ShouldComponentUpdate props state eff f action = (f action -> f action) -> React.ShouldComponentUpdate props state eff

type ComponentWillUpdate props state eff f action = (f action -> f action) -> React.ComponentWillUpdate props state eff

type ComponentDidUpdate props state eff f action = (f action -> f action) -> React.ComponentDidUpdate props state eff

type ComponentWillUnmount props state eff f action = (f action -> f action) -> React.ComponentWillUnmount props state eff

type Spec props state eff f action =
  { render :: Render props state eff f action
  , displayName :: String
  , getInitialState :: GetInitialState props state eff f action
  , componentWillMount :: ComponentWillMount props state eff f action
  , componentDidMount :: ComponentDidMount props state eff f action
  , componentWillReceiveProps :: ComponentWillReceiveProps props state eff f action
  , shouldComponentUpdate :: ShouldComponentUpdate props state eff f action
  , componentWillUpdate :: ComponentWillUpdate props state eff f action
  , componentDidUpdate :: ComponentDidUpdate props state eff f action
  , componentWillUnmount :: ComponentWillUnmount props state eff f action
  }

spec ::
  forall props state eff f action.
    GetInitialState props state eff f action ->
    Render props state eff f action ->
    Spec props state eff f action
spec getInitialState render =
  { render: render
  , displayName: ""
  , getInitialState: getInitialState
  , componentWillMount: \_ _ -> pure unit
  , componentDidMount: \_ _ -> pure unit
  , componentWillReceiveProps: \_ _ _ -> pure unit
  , shouldComponentUpdate: \_ _ _ _ -> pure true
  , componentWillUpdate: \_ _ _ _ -> pure unit
  , componentDidUpdate: \_ _ _ _ -> pure unit
  , componentWillUnmount: \_ _ -> pure unit
  }

spec' :: forall props eff f action. Render props Unit eff f action -> Spec props Unit eff f action
spec' = spec (\_ _ -> pure unit)

createClass :: forall props state eff f action state'. MonadEff (Effects eff) f => Getter' state' props -> Spec props state eff f action -> ReduxReactClass state' props
createClass lens spec_ = connect (view lens) reactClass
  where
  reactClass :: React.ReactClass props
  reactClass =
    React.createClass { render: \this -> spec_.render (dispatch this) this
                      , displayName: spec_.displayName
                      , getInitialState: \this -> spec_.getInitialState (dispatch this) this
                      , componentWillMount: \this -> spec_.componentWillMount (dispatch this) this
                      , componentDidMount: \this -> spec_.componentDidMount (dispatch this) this
                      , componentWillReceiveProps: \this -> spec_.componentWillReceiveProps (dispatch this) this
                      , shouldComponentUpdate: \this -> spec_.shouldComponentUpdate (dispatch this) this
                      , componentWillUpdate: \this -> spec_.componentWillUpdate (dispatch this) this
                      , componentDidUpdate: \this -> spec_.componentDidUpdate (dispatch this) this
                      , componentWillUnmount: \this -> spec_.componentWillUnmount (dispatch this) this
                      }
    where
    dispatch :: React.ReactThis props state -> f action -> f action
    dispatch this action = action >>= liftEff <<< runFn2 dispatch_ this

createElement :: forall props action state'. Store action state' -> ReduxReactClass state' props -> React.ReactElement
createElement store reduxClass = React.createElement providerClass { store: store } [ reduxEl ]
  where
  reduxEl :: React.ReactElement
  reduxEl = React.createElement (unsafeCoerce reduxClass) (unsafeCoerce unit) []

createElement' :: forall props state'. ReduxReactClass state' props -> React.ReactElement
createElement' reduxClass = React.createElement (unsafeCoerce reduxClass) (unsafeCoerce unit) []

createStore :: forall eff action state. Reducer action state -> state -> Eff (Effects eff) (Store action state)
createStore reducer state = createStore' reducer state id

createStore' :: forall eff action state. Reducer action state -> state -> Enhancer eff action state -> Eff (Effects eff) (Store action state)
createStore' reducer state enhancer = runFn3 createStore_ reducer state (mkFn2 <<< enhancer <<< runFn2)

reducerOptic :: forall state state' action action'. Lens' state state' -> Prism' action action' -> Reducer action' state' -> Reducer action state
reducerOptic lens prism k action state = either (const state) (\a -> set lens (k a state') state) action'
  where
  state' :: state'
  state' = view lens state

  action' :: Either action action'
  action' = matching prism action

foreign import data REDUX :: !

foreign import data Store :: * -> * -> *

foreign import data ReduxReactClass :: * -> * -> *

foreign import connect :: forall state' props. (state' -> props) -> React.ReactClass props -> ReduxReactClass state' props

foreign import dispatch_ :: forall eff props action state. Fn2 (React.ReactThis props state) action (Eff (Effects eff) action)

foreign import providerClass :: forall action state'. React.ReactClass { store :: Store action state' }

foreign import createStore_ :: forall eff action state. Fn3 (Reducer action state) state (Enhancer_ eff action state) (Eff (Effects eff) (Store action state))

module React.Redux
  ( ReduxReactClass
  , Effects
  , REDUX
  , Reducer
  , Enhancer
  , Enhancer_
  , Store
  , createClass
  , createElement
  , createStore
  , createStore'
  , reducerOptic

  , Spec
  , Render
  , GetInitialState
  , ComponentWillMount
  , ComponentDidMount
  , ComponentWillReceiveProps
  , ShouldComponentUpdate
  , ComponentWillUpdate
  , ComponentDidUpdate
  , ComponentWillUnmount
  , spec
  , spec'
  ) where

import Prelude (Unit, (<<<), (>>=), const, pure, id, unit)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)

import Data.Either (Either, either)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn2, runFn3)
import Data.Lens (Getter', Lens', Prism', matching, set, view)

import Unsafe.Coerce (unsafeCoerce)

import React as React

type Reducer action state = action -> state -> state

type Enhancer eff action state = (Reducer action state -> state -> Eff (Effects eff) (Store action state)) -> (Reducer action state -> state -> Eff (Effects eff) (Store action state))

type Enhancer_ eff action state = (Fn2 (Reducer action state) state (Eff (Effects eff) (Store action state))) -> (Fn2 (Reducer action state) state (Eff (Effects eff) (Store action state)))

type Effects eff = (redux :: REDUX | eff)

type Render props state eff f action = (f action -> f action) -> React.Render props state eff

type GetInitialState props state eff f action = (f action -> f action) -> React.GetInitialState props state eff

type ComponentWillMount props state eff f action = (f action -> f action) -> React.ComponentWillMount props state eff

type ComponentDidMount props state eff f action = (f action -> f action) -> React.ComponentDidMount props state eff

type ComponentWillReceiveProps props state eff f action = (f action -> f action) -> React.ComponentWillReceiveProps props state eff

type ShouldComponentUpdate props state eff f action = (f action -> f action) -> React.ShouldComponentUpdate props state eff

type ComponentWillUpdate props state eff f action = (f action -> f action) -> React.ComponentWillUpdate props state eff

type ComponentDidUpdate props state eff f action = (f action -> f action) -> React.ComponentDidUpdate props state eff

type ComponentWillUnmount props state eff f action = (f action -> f action) -> React.ComponentWillUnmount props state eff

type Spec props state eff f action =
  { render :: Render props state eff f action
  , displayName :: String
  , getInitialState :: GetInitialState props state eff f action
  , componentWillMount :: ComponentWillMount props state eff f action
  , componentDidMount :: ComponentDidMount props state eff f action
  , componentWillReceiveProps :: ComponentWillReceiveProps props state eff f action
  , shouldComponentUpdate :: ShouldComponentUpdate props state eff f action
  , componentWillUpdate :: ComponentWillUpdate props state eff f action
  , componentDidUpdate :: ComponentDidUpdate props state eff f action
  , componentWillUnmount :: ComponentWillUnmount props state eff f action
  }

spec ::
  forall props state eff f action.
    GetInitialState props state eff f action ->
    Render props state eff f action ->
    Spec props state eff f action
spec getInitialState render =
  { render: render
  , displayName: ""
  , getInitialState: getInitialState
  , componentWillMount: \_ _ -> pure unit
  , componentDidMount: \_ _ -> pure unit
  , componentWillReceiveProps: \_ _ _ -> pure unit
  , shouldComponentUpdate: \_ _ _ _ -> pure true
  , componentWillUpdate: \_ _ _ _ -> pure unit
  , componentDidUpdate: \_ _ _ _ -> pure unit
  , componentWillUnmount: \_ _ -> pure unit
  }

spec' :: forall props eff f action. Render props Unit eff f action -> Spec props Unit eff f action
spec' = spec (\_ _ -> pure unit)

createClass :: forall props state eff f action state'. MonadEff (Effects eff) f => Getter' state' props -> Spec props state eff f action -> ReduxReactClass state' props
createClass lens spec_ = connect (view lens) reactClass
  where
  reactClass :: React.ReactClass props
  reactClass =
    React.createClass { render: \this -> spec_.render (dispatch this) this
                      , displayName: spec_.displayName
                      , getInitialState: \this -> spec_.getInitialState (dispatch this) this
                      , componentWillMount: \this -> spec_.componentWillMount (dispatch this) this
                      , componentDidMount: \this -> spec_.componentDidMount (dispatch this) this
                      , componentWillReceiveProps: \this -> spec_.componentWillReceiveProps (dispatch this) this
                      , shouldComponentUpdate: \this -> spec_.shouldComponentUpdate (dispatch this) this
                      , componentWillUpdate: \this -> spec_.componentWillUpdate (dispatch this) this
                      , componentDidUpdate: \this -> spec_.componentDidUpdate (dispatch this) this
                      , componentWillUnmount: \this -> spec_.componentWillUnmount (dispatch this) this
                      }
    where
    dispatch :: React.ReactThis props state -> f action -> f action
    dispatch this action = action >>= liftEff <<< runFn2 dispatch_ this

createElement :: forall props action state'. Store action state' -> ReduxReactClass state' props -> React.ReactElement
createElement store reduxClass = React.createElement providerClass { store: store } [ reduxEl ]
  where
  reduxEl :: React.ReactElement
  reduxEl = React.createElement (unsafeCoerce reduxClass) (unsafeCoerce unit) []

createStore :: forall eff action state. Reducer action state -> state -> Eff (Effects eff) (Store action state)
createStore reducer state = createStore' reducer state id

createStore' :: forall eff action state. Reducer action state -> state -> Enhancer eff action state -> Eff (Effects eff) (Store action state)
createStore' reducer state enhancer = runFn3 createStore_ reducer state (mkFn2 <<< enhancer <<< runFn2)

reducerOptic :: forall state state' action action'. Lens' state state' -> Prism' action action' -> Reducer action' state' -> Reducer action state
reducerOptic lens prism k action state = either (const state) (\a -> set lens (k a state') state) action'
  where
  state' :: state'
  state' = view lens state

  action' :: Either action action'
  action' = matching prism action

foreign import data REDUX :: !

foreign import data Store :: * -> * -> *

foreign import data ReduxReactClass :: * -> * -> *

foreign import connect :: forall state' props. (state' -> props) -> React.ReactClass props -> ReduxReactClass state' props

foreign import dispatch_ :: forall eff props action state. Fn2 (React.ReactThis props state) action (Eff (Effects eff) action)

foreign import providerClass :: forall action state'. React.ReactClass { store :: Store action state' }

foreign import createStore_ :: forall eff action state. Fn3 (Reducer action state) state (Enhancer_ eff action state) (Eff (Effects eff) (Store action state))