define and use unsafeSetImmediate

define and use unsafeSetImmediate

module Routing.PushState
  ( PushStateEffects
  , PushStateInterface
  , LocationState
  , makeInterface
  , foldLocations
  , locations
  , foldPaths
  , paths
  , matches
  , matchesWith
  ) where

import Prelude

import Control.Monad.Eff (Eff, runPure)
import Control.Monad.Eff.Ref (REF, modifyRef, newRef, readRef, writeRef)
import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener) as DOM
import DOM.HTML (window) as DOM
import DOM.HTML.Event.EventTypes (popstate) as DOM
import DOM.HTML.History (DocumentTitle(..), URL(..), pushState, replaceState, state) as DOM
import DOM.HTML.Location (hash, pathname, search) as DOM
import DOM.HTML.Types (HISTORY)
import DOM.HTML.Types (htmlDocumentToDocument, windowToEventTarget) as DOM
import DOM.HTML.Window (document, history, location) as DOM
import DOM.Node.Document (createTextNode) as DOM
import DOM.Node.MutationObserver (mutationObserver, observe) as DOM
import DOM.Node.Node (setNodeValue) as DOM
import DOM.Node.Types (textToNode) as DOM
import Data.Foldable (class Foldable, indexl, sequence_, traverse_)
import Data.Foreign (Foreign)
import Data.List (List(..))
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Routing (match)
import Routing.Match (Match)

type PushStateEffects eff =
  ( history :: HISTORY
  , dom :: DOM
  , ref :: REF
  | eff
  )

-- | A `PushStateInterface` is a localized instance for making location changes
-- | and consuming the events. Since the DOM API does not provide a general
-- | event type for push state (only pop), you must use the coupled effects
-- | along with `listen` to receive events on all location changes.
-- |
-- | * `pushState` – pushes a new location state and path onto the history stack.
-- | * `replaceState` – replaces the location state and path in the history stack.
-- | * `locationState` – Dereferences the current history state
-- | * `listen` – Subscribes to location changes (both push and pop). Returns
-- |   an effect which removes the listener.
type PushStateInterface eff =
  { pushState :: Foreign -> String -> Eff eff Unit
  , replaceState :: Foreign -> String -> Eff eff Unit
  , locationState :: Eff eff LocationState
  , listen :: (LocationState -> Eff eff Unit) -> Eff eff (Eff eff Unit)
  }

type LocationState =
  { state :: Foreign
  , path :: String
  , pathname :: String
  , search :: String
  , hash :: String
  }

-- | Creates a new `PushStateInterface`. Generally you should only create one
-- | instance for your application. Since the DOM does not provide general
-- | events for location changes, listeners will only be notified on push when
-- | using the paired functions.
makeInterface :: forall eff. Eff (PushStateEffects eff) (PushStateInterface (PushStateEffects eff))
makeInterface = do
  freshRef <- newRef 0
  listenersRef <- newRef Map.empty

  let
    notify ev =
      traverse_ (_ $ ev) =<< readRef listenersRef

    listen k = do
      fresh <- readRef freshRef
      writeRef freshRef (fresh + 1)
      modifyRef listenersRef $ Map.insert fresh k
      pure $ modifyRef listenersRef $ Map.delete fresh

    locationState = do
      loc <- DOM.window >>= DOM.location
      state <- DOM.window >>= DOM.history >>= DOM.state
      pathname <- DOM.pathname loc
      search <- DOM.search loc
      hash <- DOM.hash loc
      let path = pathname <> search <> hash
      pure { state, pathname, search, hash, path }

  let
    stateFn op state path = do
      DOM.window
        >>= DOM.history
        >>= op state (DOM.DocumentTitle "") (DOM.URL path)
      -- The hashchange interface is asynchronous, since hashchange events are
      -- fired on the next tick of the event loop. We want the push-state
      -- interface to behave as similarly as possible, so we use the microtask
      -- queue via MutationObserver to schedule callbacks. Alternatively we could
      -- just use a setTimeout, but it would not be as prompt. We use a fresh
      -- counter so that the text change mutation always fires.
      unsafeSetImmediate $ notify =<< locationState

    listener =
      DOM.eventListener \_ -> notify =<< locationState

  DOM.window
    >>= DOM.windowToEventTarget
    >>> DOM.addEventListener DOM.popstate listener false

  pure
    { pushState: stateFn DOM.pushState
    , replaceState: stateFn DOM.replaceState
    , locationState
    , listen
    }

-- | Folds effectfully over location changes given callbacks for handling
-- | changes and the initial location. Returns an effect which removes the
-- | listener.
foldLocations
  :: forall eff a
   . (a -> LocationState -> Eff (PushStateEffects eff) a)
  -> (LocationState -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldLocations cb init psi = do
  ref <- newRef =<< init =<< psi.locationState
  psi.listen (\loc -> writeRef ref =<< flip cb loc =<< readRef ref)

-- | Runs the callback on every location change providing the previous location
-- | and the latest location. Returns an effect which removes the listener.
locations
  :: forall eff
   . (Maybe LocationState -> LocationState -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
locations cb = foldLocations go (go Nothing)
  where
  go a b = Just b <$ cb a b

-- | Folds effectfully over path changes given callbacks for handling changes
-- | and the initial path. Returns an effect which removes the listener.
foldPaths
  :: forall eff a
   . (a -> String -> Eff (PushStateEffects eff) a)
  -> (String -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldPaths cb init = foldLocations (\a -> cb a <<< _.path) (init <<< _.path)

-- | Runs the callback on every path change providing the previous path and
-- | the latest path. Returns an effect which removes the listener.
paths
  :: forall eff
   . (Maybe String -> String -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
paths = matchesWith Just

-- | Runs the callback on every path change using a given `Match` parser to
-- | extract a route from the path. If a path fails to parse, it is ignored.
-- | To avoid dropping paths, provide a fallback alternative in your parser.
-- | Returns an effect which removes the listener.
matches
  :: forall eff a
   . Match a
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matches = matchesWith <<< match

-- | Runs the callback on every path change using a given custom parser to
-- | extract a route from the path. If a path fails to parse, it is ignored.
-- | To avoid dropping paths, provide a fallback alternative in your parser.
-- | Returns an effect which removes the listener.
matchesWith
  :: forall eff f a
   . Foldable f
  => (String -> f a)
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matchesWith parser cb = foldPaths go (go Nothing)
  where
  go a =
    maybe (pure a) (\b -> Just b <$ cb a b)
      <<< indexl 0
      <<< parser

-- It's not that unsafe actually, but we use unsafeRunRef so it's still unsafe.
unsafeSetImmediate
  :: forall r
  . Eff (ref :: REF, dom :: DOM |r) Unit -> Eff (ref :: REF, dom :: DOM |r) Unit
unsafeSetImmediate =
  let
    freshRef = runPure $ unsafeRunRef $ newRef 0
    effRef = runPure $ unsafeRunRef $ newRef Nil
    nodeRef = runPure $ unsafeRunRef $ newRef Nothing
  in \eff -> do
    modifyRef effRef $ Cons eff
    obsvNode <- readRef nodeRef >>= case _ of
      Nothing -> do
        obsvNode <-
          DOM.window
            >>= DOM.document
            >>> map DOM.htmlDocumentToDocument
            >>= DOM.createTextNode ""
            >>> map DOM.textToNode
        observer <- DOM.mutationObserver \_ _ -> do
          readRef effRef >>= sequence_
          writeRef effRef Nil
        DOM.observe obsvNode { characterData: true } observer
        pure obsvNode
      Just obsvNode ->
        pure obsvNode
    fresh ← readRef freshRef
    writeRef freshRef (fresh + 1)
    DOM.setNodeValue (show fresh) obsvNode

module Routing.PushState
  ( PushStateEffects
  , PushStateInterface
  , LocationState
  , makeInterface
  , foldLocations
  , locations
  , foldPaths
  , paths
  , matches
  , matchesWith
  ) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (REF, modifyRef, newRef, readRef, writeRef)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener) as DOM
import DOM.HTML (window) as DOM
import DOM.HTML.Event.EventTypes (popstate) as DOM
import DOM.HTML.History (DocumentTitle(..), URL(..), pushState, replaceState, state) as DOM
import DOM.HTML.Location (hash, pathname, search) as DOM
import DOM.HTML.Types (HISTORY)
import DOM.HTML.Types (htmlDocumentToDocument, windowToEventTarget) as DOM
import DOM.HTML.Window (document, history, location) as DOM
import DOM.Node.Document (createTextNode) as DOM
import DOM.Node.MutationObserver (mutationObserver, observe) as DOM
import DOM.Node.Node (setNodeValue) as DOM
import DOM.Node.Types (textToNode) as DOM
import Data.Foldable (class Foldable, indexl, traverse_)
import Data.Foreign (Foreign)
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Routing (match)
import Routing.Match (Match)

type PushStateEffects eff =
  ( history :: HISTORY
  , dom :: DOM
  , ref :: REF
  | eff
  )

-- | A `PushStateInterface` is a localized instance for making location changes
-- | and consuming the events. Since the DOM API does not provide a general
-- | event type for push state (only pop), you must use the coupled effects
-- | along with `listen` to receive events on all location changes.
-- |
-- | * `pushState` – pushes a new location state and path onto the history stack.
-- | * `replaceState` – replaces the location state and path in the history stack.
-- | * `locationState` – Dereferences the current history state
-- | * `listen` – Subscribes to location changes (both push and pop). Returns
-- |   an effect which removes the listener.
type PushStateInterface eff =
  { pushState :: Foreign -> String -> Eff eff Unit
  , replaceState :: Foreign -> String -> Eff eff Unit
  , locationState :: Eff eff LocationState
  , listen :: (LocationState -> Eff eff Unit) -> Eff eff (Eff eff Unit)
  }

type LocationState =
  { state :: Foreign
  , path :: String
  , pathname :: String
  , search :: String
  , hash :: String
  }

-- | Creates a new `PushStateInterface`. Generally you should only create one
-- | instance for your application. Since the DOM does not provide general
-- | events for location changes, listeners will only be notified on push when
-- | using the paired functions.
makeInterface :: forall eff. Eff (PushStateEffects eff) (PushStateInterface (PushStateEffects eff))
makeInterface = do
  schedRef <- newRef false
  freshRef <- newRef 0
  listenersRef <- newRef Map.empty

  let
    notify ev =
      traverse_ (_ $ ev) =<< readRef listenersRef

    listen k = do
      fresh <- readRef freshRef
      writeRef freshRef (fresh + 1)
      modifyRef listenersRef $ Map.insert fresh k
      pure $ modifyRef listenersRef $ Map.delete fresh

    locationState = do
      loc <- DOM.window >>= DOM.location
      state <- DOM.window >>= DOM.history >>= DOM.state
      pathname <- DOM.pathname loc
      search <- DOM.search loc
      hash <- DOM.hash loc
      let path = pathname <> search <> hash
      pure { state, pathname, search, hash, path }

  -- The hashchange interface is asynchronous, since hashchange events are
  -- fired on the next tick of the event loop. We want the push-state
  -- interface to behave as similarly as possible, so we use the microtask
  -- queue via MutationObserver to schedule callbacks. Alternatively we could
  -- just use a setTimeout, but it would not be as prompt. We use a fresh
  -- counter so that the text change mutation always fires.
  schedule <- do
    obsvNode <-
      DOM.window
        >>= DOM.document
        >>> map DOM.htmlDocumentToDocument
        >>= DOM.createTextNode ""
        >>> map DOM.textToNode
    observer <- DOM.mutationObserver \_ _ -> do
      writeRef schedRef false
      notify =<< locationState
    DOM.observe obsvNode { characterData: true } observer
    pure $ unlessM (readRef schedRef) do
      writeRef schedRef true
      fresh ← readRef freshRef
      writeRef freshRef (fresh + 1)
      DOM.setNodeValue (show fresh) obsvNode

  let
    stateFn op state path = do
      DOM.window
        >>= DOM.history
        >>= op state (DOM.DocumentTitle "") (DOM.URL path)
      schedule

    listener =
      DOM.eventListener \_ -> notify =<< locationState

  DOM.window
    >>= DOM.windowToEventTarget
    >>> DOM.addEventListener DOM.popstate listener false

  pure
    { pushState: stateFn DOM.pushState
    , replaceState: stateFn DOM.replaceState
    , locationState
    , listen
    }

-- | Folds effectfully over location changes given callbacks for handling
-- | changes and the initial location. Returns an effect which removes the
-- | listener.
foldLocations
  :: forall eff a
   . (a -> LocationState -> Eff (PushStateEffects eff) a)
  -> (LocationState -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldLocations cb init psi = do
  ref <- newRef =<< init =<< psi.locationState
  psi.listen (\loc -> writeRef ref =<< flip cb loc =<< readRef ref)

-- | Runs the callback on every location change providing the previous location
-- | and the latest location. Returns an effect which removes the listener.
locations
  :: forall eff
   . (Maybe LocationState -> LocationState -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
locations cb = foldLocations go (go Nothing)
  where
  go a b = Just b <$ cb a b

-- | Folds effectfully over path changes given callbacks for handling changes
-- | and the initial path. Returns an effect which removes the listener.
foldPaths
  :: forall eff a
   . (a -> String -> Eff (PushStateEffects eff) a)
  -> (String -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldPaths cb init = foldLocations (\a -> cb a <<< _.path) (init <<< _.path)

-- | Runs the callback on every path change providing the previous path and
-- | the latest path. Returns an effect which removes the listener.
paths
  :: forall eff
   . (Maybe String -> String -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
paths = matchesWith Just

-- | Runs the callback on every path change using a given `Match` parser to
-- | extract a route from the path. If a path fails to parse, it is ignored.
-- | To avoid dropping paths, provide a fallback alternative in your parser.
-- | Returns an effect which removes the listener.
matches
  :: forall eff a
   . Match a
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matches = matchesWith <<< match

-- | Runs the callback on every path change using a given custom parser to
-- | extract a route from the path. If a path fails to parse, it is ignored.
-- | To avoid dropping paths, provide a fallback alternative in your parser.
-- | Returns an effect which removes the listener.
matchesWith
  :: forall eff f a
   . Foldable f
  => (String -> f a)
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matchesWith parser cb = foldPaths go (go Nothing)
  where
  go a =
    maybe (pure a) (\b -> Just b <$ cb a b)
      <<< indexl 0
      <<< parser


simplify the attrs

simplify the attrs

module Main where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import DOM.Event.Types (Event, TouchEvent)
import DOM.HTML.Types (HTMLElement)
import Data.Array ((..))
import Data.Char (toCharCode)
import Data.Generic (gShow, class Generic)
import Data.Int (toNumber)

type Selector = String
foreign import data Peers :: *        -- a D3Selection that's passed back in some callbacks
foreign import data DomElement :: *   -- the `this` pointer in a callback, DOM element receiving an event

data Callback d b =   Lambda (d -> b)
                    | DIfn   (d -> Number -> b)
                    | DINEfn (d -> Number -> Peers -> DomElement -> b)

data ValueOrCallback d b =  V b | CB (Callback d b)

data D3Selection d = DocumentSelect Selector
                   | SubSelect (D3Selection d) Selector
                   | Merge     (D3Selection d) (D3Selection d)
                   | Data      (D3Selection d) d
                   | Remove    (D3Selection d)
                   | Append    (D3ElementType d)

data D3ElementType d =  Circle (Attrs d)
                      | Rect (Attrs d)
                      | Path (Attrs d)
                      | Image (Attrs d)
                      | Text (Attrs d)
                      | Group (Array (D3ElementType d))

type Attrs d = Array (Attr d)

data Attr d  = CX (ValueOrCallback d Number)
             | CY (ValueOrCallback d Number)
             | R  (ValueOrCallback d Number)
             | Style String (ValueOrCallback d String)
             | EventHandlerS Event (Callback d String)
             | EventHandlerN Event (Callback d Number)

-- we're going to validate the Attr against the ElementType they're being
-- invoked on - so that you can't put a radius on text etc. This will be runtime
-- exception, unfortunately but it will be deterministic at least, seems like
-- maybe GADT's are what's needed for this? not sure.

type MyData = { x :: Number, y :: Number, radius :: Number, something :: Number }

-- | examples
hoy :: ValueOrCallback MyData Number
hoy = V 5.0

ist :: ValueOrCallback Char Number
ist = CB $ Lambda \d -> toNumber $ toCharCode d

jud = Circle []

kef =  Circle [CX hoy
             , CY (CB $ Lambda \d -> d.y)
             , R  (CB $ DIfn \d i -> d.something)]

-- | end of examples

instance showD3Selection :: Show d => Show (D3Selection d) where
  show (DocumentSelect s)          = "DocumentSelect " <> " \"" <> s <> "\""
  show (SubSelect selection s)     = "SubSelect (" <> show selection <> ") \"" <> s <> "\""
  show (Merge selection selection2) = "Merge: \n\t" <> show selection <> "\n\t" <> show selection2
  show (Data selection d)          = "Data " <> show d <> " bound to " <> show selection
  show (Remove selection)          = "Remove " <> show selection
  show (Append _)                  = "Append"

-- | if you could define a Semigroup for Selections then you could <> them
-- | but would it make sense for all the constructors above?
-- | could be that the constructors should be chosen so that you can have associativity

d3Select :: ∀ a. String -> D3Selection a
d3Select selector = DocumentSelect selector

d3SelectAll :: ∀ a. String -> D3Selection a
d3SelectAll selector = DocumentSelect selector

d3SubSelect :: ∀ a. D3Selection a -> String -> D3Selection a
d3SubSelect selection selector = SubSelect selection selector

d3SubSelectAll :: ∀ a. D3Selection a -> String -> D3Selection a
d3SubSelectAll selection selector = SubSelect selection selector

bindData :: ∀ a. D3Selection a -> a -> D3Selection a
bindData s a = Data s a

infixr 5 bindData as <->

awn :: forall t7. D3Selection t7
awn = DocumentSelect ".svg"

bel :: forall t9. D3Selection t9
bel = SubSelect awn "circle"

cep :: D3Selection (Array Int)
cep = bel <-> 1..10

dof :: D3Selection (Array Int)
dof = bel <-> 5..20

erg :: D3Selection (Array Int)
erg = Merge dof cep

fub :: D3Selection (Array Int)
fub = Remove erg

gid = Remove $ Merge (bel <-> 1..10) (bel <-> 5..12)

main :: forall e. Eff (console :: CONSOLE | e) Unit
main = do
  -- log $ show fub
  log "hello sailor"

module Main where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import DOM.Event.Types (Event, TouchEvent)
import DOM.HTML.Types (HTMLElement)
import Data.Array ((..))
import Data.Char (toCharCode)
import Data.Generic (gShow, class Generic)
import Data.Int (toNumber)

type Selector = String
foreign import data Peers :: *        -- a D3Selection that's passed back in some callbacks
foreign import data DomElement :: *   -- the `this` pointer in a callback, DOM element receiving an event

data Callback d b =   Lambda (d -> b)
                    | DIfn   (d -> Number -> b)
                    | DINEfn (d -> Number -> Peers -> DomElement -> b)

data ValueOrCallback d b =  V b | CB (Callback d b)

data D3Selection d = DocumentSelect Selector
                   | SubSelect (D3Selection d) Selector
                   | Merge     (D3Selection d) (D3Selection d)
                   | Data      (D3Selection d) d
                   | Remove    (D3Selection d)
                   | Append    (D3ElementRecipe d)

data D3ElementType d =  Circle
                      | Rect
                      | Path
                      | Image
                      | Group (Array (D3ElementRecipe d))
                      | Text

data D3ElementRecipe d = D3Recipe (D3ElementType d) (Array (Attr d))
--
data Attr d  = CX (ValueOrCallback d Number)
             | CY (ValueOrCallback d Number)
             | R  (ValueOrCallback d Number)
             | Style String (ValueOrCallback d String)
             | EventHandlerS Event (Callback d String)
             | EventHandlerN Event (Callback d Number)

-- we're going to validate the Attr against the ElementType they're being
-- invoked on - this will be runtime exception, unfortunately but it will be
-- deterministic at least, seems like maybe GADT's are what's needed for this?
-- not sure.

type MyData = { x :: Number, y :: Number, radius :: Number, something :: Number }

-- | examples
hoy :: ValueOrCallback MyData Number
hoy = V 5.0

ist :: ValueOrCallback Char Number
ist = CB $ Lambda \d -> toNumber $ toCharCode d

jud = D3Recipe Circle []

kef = D3Recipe Circle [CX hoy
                     , CY (CB $ Lambda \d -> d.y)
                     , R  (CB $ DIfn \d i -> d.something)]

-- exampleRecipe = D3Recipe Circle [ CX hoy, CY (CB (Lambda \d -> d.y)), R (CB (DIfn \d i -> d.something)) ]

-- | end of examples

instance showD3Selection :: Show d => Show (D3Selection d) where
  show (DocumentSelect s)          = "DocumentSelect " <> " \"" <> s <> "\""
  show (SubSelect selection s)     = "SubSelect (" <> show selection <> ") \"" <> s <> "\""
  show (Merge selection selection2) = "Merge: \n\t" <> show selection <> "\n\t" <> show selection2
  show (Data selection d)          = "Data " <> show d <> " bound to " <> show selection
  show (Remove selection)          = "Remove " <> show selection
  show (Append _)                  = "Append"

-- | if you could define a Semigroup for Selections then you could <> them
-- | but would it make sense for all the constructors above?
-- | could be that the constructors should be chosen so that you can have associativity

d3Select :: ∀ a. String -> D3Selection a
d3Select selector = DocumentSelect selector

d3SelectAll :: ∀ a. String -> D3Selection a
d3SelectAll selector = DocumentSelect selector

d3SubSelect :: ∀ a. D3Selection a -> String -> D3Selection a
d3SubSelect selection selector = SubSelect selection selector

d3SubSelectAll :: ∀ a. D3Selection a -> String -> D3Selection a
d3SubSelectAll selection selector = SubSelect selection selector

bindData :: ∀ a. D3Selection a -> a -> D3Selection a
bindData s a = Data s a

infixr 5 bindData as <->

awn :: forall t7. D3Selection t7
awn = DocumentSelect ".svg"

bel :: forall t9. D3Selection t9
bel = SubSelect awn "circle"

cep :: D3Selection (Array Int)
cep = bel <-> 1..10

dof :: D3Selection (Array Int)
dof = bel <-> 5..20

erg :: D3Selection (Array Int)
erg = Merge dof cep

fub :: D3Selection (Array Int)
fub = Remove erg

gid = Remove $ Merge (bel <-> 1..10) (bel <-> 5..12)

main :: forall e. Eff (console :: CONSOLE | e) Unit
main = do
  -- log $ show fub
  log "hello sailor"


better info positioning

better info positioning

module Main (main,run) where

import Debug.Trace

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

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 lessEqPos l c l' c' = l < l' || l == l' && c <= c'
  let lessPos l c l' c' = l < l' || l == l' && c < c'
  let getTypeInfo l c = do
        x <- readRef typeInfoRef
        let ps = flip filter x $ \(TypeInfo i) -> lessEqPos i.startLine i.startColumn l c && lessPos l c i.endLine i.endColumn
        let f Nothing (TypeInfo i) = Just i
            f (Just d) (TypeInfo i)
                | lessPos d.startLine d.startColumn i.startLine i.startColumn = Just i
                | otherwise = Just d
        return $ case foldl f Nothing ps of
          Nothing ->
              { startLine   : 0
              , startColumn : 0
              , endLine     : 0
              , endColumn   : 0
              , text        : ""
              }
          Just a -> a
  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
        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


Silent PromptClosed error

Silent PromptClosed error

{-
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.GlobalMenu.Component
  ( comp
  , MenuSlot
  , QueryP
  , StateP
  , ChildQuery
  , Query(..)
  , ChildSlot
  , ChildState
  , module SlamData.GlobalMenu.Component.State
  ) where

import SlamData.Prelude

import Data.Time.Duration (Milliseconds(Milliseconds))

import Control.UI.Browser as Browser
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus

import Halogen as H
import Halogen.HTML.Core (className)
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.Menu.Component (MenuQuery(..), menuComponent) as HalogenMenu
import Halogen.Menu.Component.State (MenuItem, makeMenu)
import Halogen.Menu.Submenu.Component (SubmenuQuery(..)) as HalogenMenu

import OIDC.Crypt as Crypt

import Quasar.Advanced.Types (ProviderR)

import SlamData.Monad (Slam)
import SlamData.Quasar as Api
import SlamData.Notification (NotificationOptions)
import SlamData.Notification as Notification
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Auth.Authentication (AuthenticationError(..))
import SlamData.Quasar.Auth.Store as AuthStore
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.GlobalMenu.Component.State (State, initialState)
import SlamData.GlobalMenu.Menu.Component.Query (QueryP) as MenuQuery
import SlamData.GlobalMenu.Menu.Component.State as MenuState
import SlamData.Wiring (Wiring(Wiring))

data Query a
  = DismissSubmenu a
  | Init a

type QueryP = Coproduct Query (H.ChildF MenuSlot ChildQuery)

data MenuSlot = MenuSlot

derive instance genericMenuSlot ∷ Generic MenuSlot
derive instance eqMenuSlot ∷ Eq MenuSlot
derive instance ordMenuSlot ∷ Ord MenuSlot

type ChildSlot = MenuSlot

type ChildQuery = MenuQuery.QueryP

type ChildState g = MenuState.StateP g

type StateP = H.ParentState State (ChildState Slam) Query ChildQuery Slam ChildSlot
type GlobalMenuHTML = H.ParentHTML (ChildState Slam) Query ChildQuery Slam ChildSlot
type GlobalMenuDSL = H.ParentDSL State (ChildState Slam) Query ChildQuery Slam ChildSlot

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

render ∷ State → GlobalMenuHTML
render state =
  HH.div
    [ HP.classes $ [ className "sd-global-menu" ] ]
    [ HH.slot MenuSlot \_ →
        { component: HalogenMenu.menuComponent
        , initialState: H.parentState $ makeMenu helpMenu
        }
    ]

eval ∷ Query ~> GlobalMenuDSL
eval (DismissSubmenu next) = dismissAll $> next
eval (Init next) = update $> next

update ∷ GlobalMenuDSL Unit
update = do
  mbIdToken ← H.liftH $ H.liftH $ Auth.getIdToken
  maybe
    retrieveProvidersAndUpdateMenu
    putEmailToMenu
    mbIdToken
  where
  putEmailToMenu ∷ Crypt.IdToken → GlobalMenuDSL Unit
  putEmailToMenu token = do
    queryMenu
      $ H.action
      $ HalogenMenu.SetMenu
      $ makeMenu
      $ [ { label:
              fromMaybe "unknown user"
              $ map Crypt.runEmail
              $ Crypt.pluckEmail token
          , submenu:
              [ { label: "🔒 Sign out"
                , shortcutLabel: Nothing
                , value: MenuState.Authenticate Nothing
                }
              ]
          }
        ] <> helpMenu
    H.modify (_{loggedIn = true})

  retrieveProvidersAndUpdateMenu ∷ GlobalMenuDSL Unit
  retrieveProvidersAndUpdateMenu = do
    eProviders ← Api.retrieveAuthProviders
    queryMenu
      $ H.action
      $ HalogenMenu.SetMenu
      $ makeMenu
      $ case eProviders of
          Right (Just providers) →
            [ { label: "🔓 Sign in"
              , submenu: MenuState.makeAuthenticateSubmenuItem <$> providers
              }
            ] <> helpMenu
          _ → helpMenu

helpMenu ∷ Array (MenuItem MenuState.AuthenticateOrPresentHelp)
helpMenu =
  [ { label: "Help"
    , submenu:
      [ { label: "User guide"
        , shortcutLabel: Nothing
        , value:
            MenuState.PresentHelp
              "http://docs.slamdata.com/en/v3.0/users-guide.html"
        }
      , { label: "Administrator guide"
        , shortcutLabel: Nothing
        , value:
            MenuState.PresentHelp
              "http://docs.slamdata.com/en/v3.0/administration-guide.html"
        }
      , { label: "Developer guide"
        , shortcutLabel: Nothing
        , value:
            MenuState.PresentHelp
              "http://docs.slamdata.com/en/v3.0/developers-guide.html"
        }
      , { label: "Helpful tips"
        , shortcutLabel: Nothing
        , value:
            MenuState.PresentHelp
              "http://docs.slamdata.com/en/v3.0/helpful-tips.html"
        }
      , { label: "SQL² reference"
        , shortcutLabel: Nothing
        , value:
            MenuState.PresentHelp
              "http://docs.slamdata.com/en/v3.0/sql-squared-reference.html"
        }
      , { label: "SlamDown reference"
        , shortcutLabel: Nothing
        , value:
            MenuState.PresentHelp
              "http://docs.slamdata.com/en/v3.0/slamdown-reference.html"
        }
      , { label: "Troubleshooting FAQ"
        , shortcutLabel: Nothing
        , value:
            MenuState.PresentHelp
              "http://docs.slamdata.com/en/v3.0/troubleshooting-faq.html"
        }
      ]
    }
  ]

dismissAll ∷ GlobalMenuDSL Unit
dismissAll =
  queryMenu $
    H.action HalogenMenu.DismissSubmenu

menuPeek ∷ ∀ a. MenuQuery.QueryP a → GlobalMenuDSL Unit
menuPeek =
  coproduct
    (const (pure unit))
    (submenuPeek ∘ H.runChildF)

submenuPeek
  ∷ ∀ a
  . HalogenMenu.SubmenuQuery MenuState.AuthenticateOrPresentHelp a
  → GlobalMenuDSL Unit
submenuPeek (HalogenMenu.SelectSubmenuItem authenticateOrPresentHelp _) = do
   case authenticateOrPresentHelp of
     MenuState.Authenticate providerR → authenticate providerR
     MenuState.PresentHelp uri → presentHelp uri

queryMenu
  ∷ HalogenMenu.MenuQuery MenuState.AuthenticateOrPresentHelp Unit
  → GlobalMenuDSL Unit
queryMenu q = void $ H.query MenuSlot (left q)

authenticate ∷ Maybe ProviderR → GlobalMenuDSL Unit
authenticate =
  maybe logOut logIn
  where
  logOut ∷ GlobalMenuDSL Unit
  logOut = do
    H.fromEff do
      AuthStore.clearIdToken
      AuthStore.clearUnhashedNonce
      AuthStore.clearProvider
      Browser.reload

  logIn ∷ ProviderR → GlobalMenuDSL Unit
  logIn providerR = do
    Wiring wiringR ← H.liftH $ H.liftH $ ask
    idToken ← H.fromAff AVar.makeVar
    H.fromAff $ Bus.write { providerR, idToken, prompt: true } wiringR.requestNewIdTokenBus
    either signInFailure (const $ signInSuccess) =<< (H.fromAff $ AVar.takeVar idToken)

  -- TODO: Reattempt failed actions without loosing state, remove reload.
  signInSuccess ∷ GlobalMenuDSL Unit
  signInSuccess = do
    Wiring wiringR ← H.liftH $ H.liftH $ ask
    (H.fromAff $ Bus.write SignInSuccess $ wiringR.signInBus)
      *> update
      *> H.fromEff Browser.reload

  signInFailure ∷ AuthenticationError → GlobalMenuDSL Unit
  signInFailure error = do
    Wiring wiringR ← H.liftH $ H.liftH $ ask
    H.fromAff $ maybe (pure unit) (flip Bus.write wiringR.notify) (toNotificationOptions error)
    H.fromAff $ (Bus.write SignInFailure $ wiringR.signInBus)

  toNotificationOptions ∷ AuthenticationError → Maybe NotificationOptions
  toNotificationOptions =
    case _ of
      IdTokenInvalid →
        Just
          { notification: Notification.Error $ "Sign in failed: Authentication provider provided invalid id token."
          , detail: Nothing
          , timeout
          }
      IdTokenUnavailable detail →
        Just
          { notification: Notification.Error $ "Sign in failed: Authentication provider didn't provide a token."
          , detail: Just detail
          , timeout
          }
      PromptDismissed →
        Just
          { notification: Notification.Warning $ "Sign in prompt closed."
          , detail: Nothing
          , timeout
          }
      ProviderError detail →
        Just
          { notification: Notification.Error $ "Sign in failed: There was a problem with your provider configuration, please update your SlamData configuration and try again."
          , detail: Just detail
          , timeout
          }
      DOMError _ → Nothing
    where
    timeout = Just $ Milliseconds 5000.0

presentHelp ∷ String → GlobalMenuDSL Unit
presentHelp = H.fromEff ∘ Browser.newTab

{-
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.GlobalMenu.Component
  ( comp
  , MenuSlot
  , QueryP
  , StateP
  , ChildQuery
  , Query(..)
  , ChildSlot
  , ChildState
  , module SlamData.GlobalMenu.Component.State
  ) where

import SlamData.Prelude

import Data.Time.Duration (Milliseconds(Milliseconds))

import Control.UI.Browser as Browser
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus

import Halogen as H
import Halogen.HTML.Core (className)
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.Menu.Component (MenuQuery(..), menuComponent) as HalogenMenu
import Halogen.Menu.Component.State (MenuItem, makeMenu)
import Halogen.Menu.Submenu.Component (SubmenuQuery(..)) as HalogenMenu

import OIDC.Crypt as Crypt

import Quasar.Advanced.Types (ProviderR)

import SlamData.Monad (Slam)
import SlamData.Quasar as Api
import SlamData.Notification (NotificationOptions)
import SlamData.Notification as Notification
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Auth.Authentication (AuthenticationError(..))
import SlamData.Quasar.Auth.Store as AuthStore
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.GlobalMenu.Component.State (State, initialState)
import SlamData.GlobalMenu.Menu.Component.Query (QueryP) as MenuQuery
import SlamData.GlobalMenu.Menu.Component.State as MenuState
import SlamData.Wiring (Wiring(Wiring))

data Query a
  = DismissSubmenu a
  | Init a

type QueryP = Coproduct Query (H.ChildF MenuSlot ChildQuery)

data MenuSlot = MenuSlot

derive instance genericMenuSlot ∷ Generic MenuSlot
derive instance eqMenuSlot ∷ Eq MenuSlot
derive instance ordMenuSlot ∷ Ord MenuSlot

type ChildSlot = MenuSlot

type ChildQuery = MenuQuery.QueryP

type ChildState g = MenuState.StateP g

type StateP = H.ParentState State (ChildState Slam) Query ChildQuery Slam ChildSlot
type GlobalMenuHTML = H.ParentHTML (ChildState Slam) Query ChildQuery Slam ChildSlot
type GlobalMenuDSL = H.ParentDSL State (ChildState Slam) Query ChildQuery Slam ChildSlot

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

render ∷ State → GlobalMenuHTML
render state =
  HH.div
    [ HP.classes $ [ className "sd-global-menu" ] ]
    [ HH.slot MenuSlot \_ →
        { component: HalogenMenu.menuComponent
        , initialState: H.parentState $ makeMenu helpMenu
        }
    ]

eval ∷ Query ~> GlobalMenuDSL
eval (DismissSubmenu next) = dismissAll $> next
eval (Init next) = update $> next

update ∷ GlobalMenuDSL Unit
update = do
  mbIdToken ← H.liftH $ H.liftH $ Auth.getIdToken
  maybe
    retrieveProvidersAndUpdateMenu
    putEmailToMenu
    mbIdToken
  where
  putEmailToMenu ∷ Crypt.IdToken → GlobalMenuDSL Unit
  putEmailToMenu token = do
    queryMenu
      $ H.action
      $ HalogenMenu.SetMenu
      $ makeMenu
      $ [ { label:
              fromMaybe "unknown user"
              $ map Crypt.runEmail
              $ Crypt.pluckEmail token
          , submenu:
              [ { label: "🔒 Sign out"
                , shortcutLabel: Nothing
                , value: MenuState.Authenticate Nothing
                }
              ]
          }
        ] <> helpMenu
    H.modify (_{loggedIn = true})

  retrieveProvidersAndUpdateMenu ∷ GlobalMenuDSL Unit
  retrieveProvidersAndUpdateMenu = do
    eProviders ← Api.retrieveAuthProviders
    queryMenu
      $ H.action
      $ HalogenMenu.SetMenu
      $ makeMenu
      $ case eProviders of
          Right (Just providers) →
            [ { label: "🔓 Sign in"
              , submenu: MenuState.makeAuthenticateSubmenuItem <$> providers
              }
            ] <> helpMenu
          _ → helpMenu

helpMenu ∷ Array (MenuItem MenuState.AuthenticateOrPresentHelp)
helpMenu =
  [ { label: "Help"
    , submenu:
      [ { label: "User guide"
        , shortcutLabel: Nothing
        , value:
            MenuState.PresentHelp
              "http://docs.slamdata.com/en/v3.0/users-guide.html"
        }
      , { label: "Administrator guide"
        , shortcutLabel: Nothing
        , value:
            MenuState.PresentHelp
              "http://docs.slamdata.com/en/v3.0/administration-guide.html"
        }
      , { label: "Developer guide"
        , shortcutLabel: Nothing
        , value:
            MenuState.PresentHelp
              "http://docs.slamdata.com/en/v3.0/developers-guide.html"
        }
      , { label: "Helpful tips"
        , shortcutLabel: Nothing
        , value:
            MenuState.PresentHelp
              "http://docs.slamdata.com/en/v3.0/helpful-tips.html"
        }
      , { label: "SQL² reference"
        , shortcutLabel: Nothing
        , value:
            MenuState.PresentHelp
              "http://docs.slamdata.com/en/v3.0/sql-squared-reference.html"
        }
      , { label: "SlamDown reference"
        , shortcutLabel: Nothing
        , value:
            MenuState.PresentHelp
              "http://docs.slamdata.com/en/v3.0/slamdown-reference.html"
        }
      , { label: "Troubleshooting FAQ"
        , shortcutLabel: Nothing
        , value:
            MenuState.PresentHelp
              "http://docs.slamdata.com/en/v3.0/troubleshooting-faq.html"
        }
      ]
    }
  ]

dismissAll ∷ GlobalMenuDSL Unit
dismissAll =
  queryMenu $
    H.action HalogenMenu.DismissSubmenu

menuPeek ∷ ∀ a. MenuQuery.QueryP a → GlobalMenuDSL Unit
menuPeek =
  coproduct
    (const (pure unit))
    (submenuPeek ∘ H.runChildF)

submenuPeek
  ∷ ∀ a
  . HalogenMenu.SubmenuQuery MenuState.AuthenticateOrPresentHelp a
  → GlobalMenuDSL Unit
submenuPeek (HalogenMenu.SelectSubmenuItem authenticateOrPresentHelp _) = do
   case authenticateOrPresentHelp of
     MenuState.Authenticate providerR → authenticate providerR
     MenuState.PresentHelp uri → presentHelp uri

queryMenu
  ∷ HalogenMenu.MenuQuery MenuState.AuthenticateOrPresentHelp Unit
  → GlobalMenuDSL Unit
queryMenu q = void $ H.query MenuSlot (left q)

authenticate ∷ Maybe ProviderR → GlobalMenuDSL Unit
authenticate =
  maybe logOut logIn
  where
  logOut ∷ GlobalMenuDSL Unit
  logOut = do
    H.fromEff do
      AuthStore.clearIdToken
      AuthStore.clearUnhashedNonce
      AuthStore.clearProvider
      Browser.reload

  logIn ∷ ProviderR → GlobalMenuDSL Unit
  logIn providerR = do
    Wiring wiringR ← H.liftH $ H.liftH $ ask
    idToken ← H.fromAff AVar.makeVar
    H.fromAff $ Bus.write { providerR, idToken, prompt: true } wiringR.requestNewIdTokenBus
    either signInFailure (const $ signInSuccess) =<< (H.fromAff $ AVar.takeVar idToken)

  -- TODO: Reattempt failed actions without loosing state, remove reload.
  signInSuccess ∷ GlobalMenuDSL Unit
  signInSuccess = do
    Wiring wiringR ← H.liftH $ H.liftH $ ask
    (H.fromAff $ Bus.write SignInSuccess $ wiringR.signInBus)
      *> update
      *> H.fromEff Browser.reload

  signInFailure ∷ AuthenticationError → GlobalMenuDSL Unit
  signInFailure error = do
    Wiring wiringR ← H.liftH $ H.liftH $ ask
    H.fromAff $ (Bus.write (toNotificationOptions error) wiringR.notify)
    H.fromAff $ (Bus.write SignInFailure $ wiringR.signInBus)

  toNotificationOptions ∷ AuthenticationError → NotificationOptions
  toNotificationOptions =
    case _ of
      IdTokenInvalid →
        { notification: Notification.Error $ "Sign in failed: Authentication provider provided invalid id token."
        , detail: Nothing
        , timeout
        }
      IdTokenUnavailable detail →
        { notification: Notification.Error $ "Sign in failed: Authentication provider didn't provide a token."
        , detail: Just detail
        , timeout
        }
      PromptDismissed →
        { notification: Notification.Warning $ "Sign in prompt closed."
        , detail: Nothing
        , timeout
        }
      DOMError detail →
        { notification: Notification.Error $ "Sign in failed: Your browser is incompatible with SlamData please try again with another browser."
        , detail: Just detail
        , timeout
        }
      ProviderError detail →
        { notification: Notification.Error $ "Sign in failed: There was a problem with your provider configuration, please update your SlamData configuration and try again."
        , detail: Just detail
        , timeout
        }
    where
    timeout = Just $ Milliseconds 5000.0

presentHelp ∷ String → GlobalMenuDSL Unit
presentHelp = H.fromEff ∘ Browser.newTab


kill whitespace

kill whitespace

module Test.Mocha
  ( Describe(..), DoDescribe(..)
  , It(..), DoIt(..)
  , itIs, itIsNot, Done(..), DoneToken(..)
  , it, itAsync, itSkip, itOnly
  , describe, describeSkip, describeOnly
  , before, beforeEach, Before(..)
  , after, afterEach, After(..)) where

import Control.Monad.Eff
import Data.Foreign.EasyFFI

foreign import data Describe  :: !
type DoDescribe               = forall e a. String -> Eff e a -> Eff (describe :: Describe | e) Unit

describe                      :: DoDescribe
describe                      = unsafeForeignProcedure ["description", "fn", ""] "window.describe(description, fn);"
describeOnly                  :: DoDescribe
describeOnly                  = unsafeForeignProcedure ["description", "fn", ""] "window.describe.only(description, fn);"
describeSkip                  :: DoDescribe
describeSkip                  = unsafeForeignProcedure ["description", "fn", ""] "window.describe.skip(description, fn);"

foreign import data It        :: !
type DoIt                     = forall e a. String -> Eff e a -> Eff (it :: It | e) Unit

it                            :: DoIt
it                            = unsafeForeignProcedure ["description", "fn", ""] "window.it(description, fn);"
itOnly                        :: DoIt
itOnly                        = unsafeForeignProcedure ["description", "fn", ""] "window.it.only(description, fn);"
itSkip                        :: DoIt
itSkip                        = unsafeForeignProcedure ["description", "fn", ""] "window.it.skip(description, fn);"

foreign import data Done :: !
data DoneToken = DoneToken

foreign import itAsync
  "function itAsync(d) {                          \
  \    return function (fn) {                     \
  \       return function(){                      \
  \         return window.it(d, function(done){   \
  \           return fn(done)();                  \
  \         });                                   \
  \       };                                      \
  \    };                                         \
  \}" :: forall a eff.
         String ->
         (DoneToken -> Eff (done :: Done | eff) a) ->
         Eff (it :: It | eff) Unit

foreign import itIs
  "function itIs(d){ return function(){d();} }" :: forall eff.
                                       DoneToken ->
                                       Eff (done :: Done | eff) Unit

foreign import itIsNot
  "function itIsNot(d){ return function(){}; }" :: forall eff.
                                       DoneToken ->
                                       Eff (done :: Done | eff) Unit

    --- HOOKS

foreign import data Before     :: !
before                         :: forall e a. Eff e a -> Eff (before :: Before | e) Unit
before                         = unsafeForeignProcedure ["fn", ""] "window.before(fn);"

beforeEach                     :: forall e a. Eff e a -> Eff (before :: Before | e) Unit
beforeEach                     = unsafeForeignProcedure ["fn", ""] "window.beforeEach(fn);"

foreign import data After      :: !
after                          :: forall e a. Eff e a -> Eff (after :: After | e) Unit
after                          = unsafeForeignProcedure ["fn", ""] "window.after(fn);"

afterEach                      :: forall e a. Eff e a -> Eff (after :: After | e) Unit
afterEach                      = unsafeForeignProcedure ["fn", ""] "window.afterEach(fn);"


Remove out of date comment

Remove out of date comment

The `Field Unit` instance was removed with https://github.com/purescript/purescript-prelude/commit/4eb5a275c89ba80a1e9138bb57e1d3ee6663630e#diff-0daf98ff48cd03daf3f176366e341d09L28.

module Data.Field
  ( class Field
  , module Data.CommutativeRing
  , module Data.EuclideanRing
  , module Data.Ring
  , module Data.Semiring
  ) where

import Data.CommutativeRing (class CommutativeRing)
import Data.EuclideanRing (class EuclideanRing, degree, div, mod, (/), gcd, lcm)
import Data.Ring (class Ring, negate, sub)
import Data.Semiring (class Semiring, add, mul, one, zero, (*), (+))

-- | The `Field` class is for types that are commutative fields.
-- |
-- | Instances must satisfy the following law in addition to the
-- | `EuclideanRing` laws:
-- |
-- | - Non-zero multiplicative inverse: ``a `mod` b = zero`` for all `a` and `b`
class EuclideanRing a <= Field a

instance fieldNumber :: Field Number

module Data.Field
  ( class Field
  , module Data.CommutativeRing
  , module Data.EuclideanRing
  , module Data.Ring
  , module Data.Semiring
  ) where

import Data.CommutativeRing (class CommutativeRing)
import Data.EuclideanRing (class EuclideanRing, degree, div, mod, (/), gcd, lcm)
import Data.Ring (class Ring, negate, sub)
import Data.Semiring (class Semiring, add, mul, one, zero, (*), (+))

-- | The `Field` class is for types that are commutative fields.
-- |
-- | Instances must satisfy the following law in addition to the
-- | `EuclideanRing` laws:
-- |
-- | - Non-zero multiplicative inverse: ``a `mod` b = zero`` for all `a` and `b`
-- |
-- | The `Unit` instance is provided for backwards compatibility, but it is
-- | not law-abiding, because `Unit` does not obey the `EuclideanRing` laws.
-- | This instance will be removed in a future release.
class EuclideanRing a <= Field a

instance fieldNumber :: Field Number


Ugly but working hand UI

Ugly but working hand UI

module App.BoardView where

import Data.Maybe
import App.FixedMatrix72 as FM
import App.Turn as Turn
import Data.Array as Array
import Pux.CSS as C
import Pux.Html as H
import App.Board (Pit, PitRef, Player, Board, getStore)
import App.FixedMatrix72 (Row(B, A))
import App.Hand (Hand)
import App.Turn (Turn)
import Data.Traversable (sequence)
import Prelude (bind, const, pure, show, ($), (<), (<$>), (<<<), (<>), (==))
import Pux.CSS (Color, backgroundColor, em, hsl, lighten, padding, px, rotateHue, style)
import Pux.Html (Attribute, Html, div, text)
import Pux.Html.Events (onClick)

class BoardView state action | state -> action where
  getBoard :: state -> Board
  getHand :: state -> Maybe Hand
  getTurn :: state -> Maybe Turn
  getCurrentPlayer :: state -> Maybe Player
  getPitAction :: state -> PitRef -> Maybe action

isPlaying :: forall state action. BoardView state action => state -> Player -> Boolean
isPlaying state player = fromMaybe false $ do
  currentPlayer <- getCurrentPlayer state
  pure $ player == currentPlayer

type PitState = Maybe Turn

pitState :: forall state action. BoardView state action
         => state -> PitRef -> PitState
pitState state ref = do
  hand <- getHand state
  if ref == hand.pitRef
    then getTurn state
    else Nothing

pitColor :: PitState -> Color
pitColor = go
  where go (Just Turn.Capture) = rotateHue 50.0 $ go (Just Turn.Lift)
        go (Just Turn.Lift) = rotateHue 100.0 $ go Nothing
        go (Just Turn.Sow) = lighten 0.3 $ go Nothing
        go _ = hsl 40.0 1.0 0.3

view :: forall action state. BoardView state action
     => state -> Html action
view state =
  div []
  [ viewStore state A
  , viewHandRow A
  , viewRow A
  , viewRow B
  , viewHandRow B
  , viewStore state B
  ]
  where
    board =
      getBoard state
    viewHandRow player =
      div [css] $ FM.mapRowWithIndex player (\ref pit -> viewHandInPit state ref) board.cells
    viewRow player =
      div [css] $ FM.mapRowWithIndex player (viewPit state) board.cells
    css = style $ do
            apply4 C.padding (em 0.5)

viewStore :: forall action state. BoardView state action
          => state -> Row -> Html action
viewStore state player = div [css] [text s]
    where s = viewPlayer player
                <> " with "
                <> show seeds
                <> " seeds."
          seeds = getStore player board
          board = getBoard state
          css = style $ do
            backgroundColor color
            apply4 padding (em 0.5)
          color = if isPlaying state player
                  then pitColor (Just Turn.Sow)
                  else pitColor Nothing

viewPlayer :: Player -> String
viewPlayer player = "Player " <> show player <> " " <> viewPlayerEmoji (Just player)

viewPlayerEmoji :: Maybe Player -> String
viewPlayerEmoji (Just A) = "🐼"
viewPlayerEmoji (Just B) = "🐔"
viewPlayerEmoji Nothing = numberPadded 0

viewPitEmoji :: forall action state. BoardView state action
              => state -> PitRef -> String
viewPitEmoji state ref = viewPlayerEmoji $ do
  hand <- getHand state
  if hand.pitRef == ref
    then pure hand.player
    else Nothing

viewPit :: forall action state. BoardView state action
          => state -> PitRef -> Pit -> Html action
viewPit state ref count =
  H.pre (getJusts [css, event]) [body]
  where
    body = text $ numberPadded count
    event = onClick <$> const <$> getPitAction state ref
    color = pitColor $ pitState state ref
    css = Just $ cellStyle color

numberPadded :: Int -> String
numberPadded n =
  if n < 10
    then " " <> show n <> extra
    else show n <> extra
      where extra = "  "

cellStyle :: forall a. Color -> Attribute a
cellStyle color = style do
    C.display C.inline
    C.fontSize (em 2.0)
    C.backgroundColor color
    C.padding (em 0.0) (em padding) (em 0.0) (em padding)
    C.border C.solid (px 1.0) C.black
    where
      padding = 0.5

viewHandInPit :: forall action state. BoardView state action
              => state -> PitRef -> Html action
viewHandInPit state ref =
  H.pre [cellStyle color] [ text s ]
    where color = C.white
          s = fromMaybe (viewPlayerEmoji Nothing) do
                hand <- getHand state
                if hand.pitRef == ref
                  then pure $ (viewPlayerEmoji $ Just hand.player) <> show hand.seeds
                  else Nothing

getJusts :: forall a. Array (Maybe a) -> Array a
getJusts = fromMaybe [] <<< sequence <<< Array.filter isJust

apply4 :: forall a b. (a -> a -> a -> a -> b) -> a -> b
apply4 f a = f a a a a

module App.BoardView where

import Data.Maybe
import App.FixedMatrix72 as FM
import App.Turn as Turn
import Data.Array as Array
import Pux.CSS as C
import Pux.Html as H
import App.Board (Pit, PitRef, Player, Board, getStore)
import App.FixedMatrix72 (Row(B, A))
import App.Hand (Hand)
import App.Turn (Turn)
import Data.Traversable (sequence)
import Prelude (bind, const, pure, show, ($), (<), (<$>), (<<<), (<>), (==))
import Pux.CSS (Color, backgroundColor, em, hsl, lighten, padding, px, rotateHue, style)
import Pux.Html (Html, div, text)
import Pux.Html.Events (onClick)

class BoardView state action | state -> action where
  getBoard :: state -> Board
  getHand :: state -> Maybe Hand
  getTurn :: state -> Maybe Turn
  getCurrentPlayer :: state -> Maybe Player
  getPitAction :: state -> PitRef -> Maybe action

isPlaying :: forall state action. BoardView state action => state -> Player -> Boolean
isPlaying state player = fromMaybe false $ do
  currentPlayer <- getCurrentPlayer state
  pure $ player == currentPlayer

type PitState = Maybe Turn

pitState :: forall state action. BoardView state action
         => state -> PitRef -> PitState
pitState state ref = do
  hand <- getHand state
  if ref == hand.pitRef
    then getTurn state
    else Nothing

pitColor :: PitState -> Color
pitColor = go
  where go (Just Turn.Capture) = rotateHue 50.0 $ go (Just Turn.Lift)
        go (Just Turn.Lift) = rotateHue 100.0 $ go Nothing
        go (Just Turn.Sow) = lighten 0.3 $ go Nothing
        go _ = hsl 40.0 1.0 0.3

view :: forall action state. BoardView state action
     => state -> Html action
view state =
  div []
  [ viewStore state A
  , viewRow A
  , viewRow B
  , viewStore state B
  ]
  where
    board = getBoard state
    viewRow player = div [css] $ rows
      where rows = FM.mapRowWithIndex player viewCell' board.cells
            viewCell' ref = viewCell state ref
            css = style $ do
              apply4 C.padding (em 0.5)

viewStore :: forall action state. BoardView state action
          => state -> Row -> Html action
viewStore state player = div [css] [text s]
    where s = viewPlayer player
                <> " with "
                <> show seeds
                <> " seeds."
          seeds = getStore player board
          board = getBoard state
          css = style $ do
            backgroundColor color
            apply4 padding (em 0.5)
          color = if isPlaying state player
                  then pitColor (Just Turn.Sow)
                  else pitColor Nothing

viewPlayer :: Player -> String
viewPlayer player = "Player " <> show player <> " " <> viewPlayerEmoji (Just player)

viewPlayerEmoji :: Maybe Player -> String
viewPlayerEmoji (Just A) = "🐼"
viewPlayerEmoji (Just B) = "🐔"
viewPlayerEmoji Nothing = "❀"

viewCellEmoji :: forall action state. BoardView state action
              => state -> PitRef -> String
viewCellEmoji state ref = viewPlayerEmoji $ do
  hand <- getHand state
  if hand.pitRef == ref
    then pure hand.player
    else Nothing

viewCell :: forall action state. BoardView state action
          => state -> PitRef -> Pit -> Html action
viewCell state ref count =
  H.pre (getJusts [css, event]) [body]
  where
    body = text $ viewCellEmoji state ref <> numberPadded count
    event = onClick <$> const <$> getPitAction state ref
    numberPadded num =
      if num < 10
        then " " <> show num
        else show num
    css = Just $ style do
      C.display C.inline
      C.fontSize (em 2.0)
      C.backgroundColor color
      C.padding (em 0.0) (em padding) (em 0.0) (em padding)
      C.border C.solid (px 1.0) C.black
      where
        color = pitColor $ pitState state ref
        padding = 0.5

getJusts :: forall a. Array (Maybe a) -> Array a
getJusts = fromMaybe [] <<< sequence <<< Array.filter isJust

apply4 :: forall a b. (a -> a -> a -> a -> b) -> a -> b
apply4 f a = f a a a a


Delay the evaluation of lambda expressions

Maybe this will help to discern what happens, when a lambda
expression is applied/evaluated.

module Evaluator
  ( Path(..)
  , Env()
  , evalPath1
  , defsToEnv
  ) where

import Data.Array    (head, mapMaybe, (!!), updateAt, elemIndex)
import Data.StrMap   (StrMap(), empty, lookup, insert)
import Data.Tuple
import Data.Maybe
import Data.Foldable (foldl, foldMap, any)

import Math (pow)

import Control.Apply ((*>))
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Trans

import AST

data Path = Start Path | Nth Number Path | Fst Path | Snd Path | End

select :: Path -> (Expr -> Maybe Expr) -> Expr -> Maybe Expr
select (Start p) eval expr = select p eval expr
select End       eval expr = eval expr

select (Fst p) eval expr = case expr of
  Binary op e1 e2 -> Binary op <$> (select p eval e1) <*> Just e2
  Unary op e      -> Unary op <$> select p eval e
  SectL e op      -> SectL <$> (select p eval e) <*> Just op
  SectR op e      -> SectR op <$> (select p eval) e
  Lambda bs body  -> Lambda bs <$> select p eval body
  App e es        -> App <$> (select p eval e) <*> Just es
  _               -> Nothing
select (Snd p) eval expr = case expr of
  Binary op e1 e2 -> Binary op e1 <$> select p eval e2
  _               -> Nothing
select (Nth n p) eval expr = case expr of
  List es  -> List <$> mapMIndex n (select p eval) es
  App e es -> App e <$> mapMIndex n (select p eval) es
  _        -> Nothing

mapMIndex :: forall m a. Number -> (a -> Maybe a) -> [a] -> Maybe [a]
mapMIndex i f as = do
  a <- (as !! i) >>= f
  return $ updateAt i a as

evalPath1 :: Env -> Path -> Expr -> Maybe Expr
evalPath1 env path expr = select path (eval1 env) expr

type Env = StrMap [Tuple [Binding] Expr]

defsToEnv :: [Definition] -> Env
defsToEnv = foldl insertDef empty

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case lookup name env of
  Nothing   -> insert name [Tuple bindings body] env
  Just defs -> insert name (defs ++ [Tuple bindings body]) env

eval1 :: Env -> Expr -> Maybe Expr
eval1 env expr = case expr of
  (Binary op e1 e2)             -> binary op e1 e2
  (Unary op e)                  -> unary op e
  (Atom (Name name))            -> apply env name []
  (Lambda [] body)              -> Just body
  (App (Binary Composition f g) [e]) -> Just $ App f [App g [e]]
  (App (Lambda binds body) args) -> Lambda <$> Just [] <*> matchls binds args body
  (App (SectL e1 op) [e2])      -> Just $ Binary op e1 e2
  (App (SectR op e2) [e1])      -> Just $ Binary op e1 e2
  (App (Prefix op) [e1, e2])    -> Just $ Binary op e1 e2
  (App (Atom (Name name)) args) -> apply env name args
  (App (App func es) es')       -> Just $ App func (es ++ es')
  _                 -> Nothing

binary :: Op -> Expr -> Expr -> Maybe Expr
binary = go
  where
  go Power (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ pow i j

  go Mul (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i * j
  go Div (Atom (Num i)) (Atom (Num 0)) = Nothing
  go Div (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ Math.floor (i / j)
  go Mod (Atom (Num i)) (Atom (Num 0)) = Nothing
  go Mod (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i % j

  go Add (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i + j
  go Sub (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i - j

  go Cons   e          (List es)  = Just $ List $ e:es
  go Append (List es1) (List es2) = Just $ List $ es1 ++ es2

  go Eq  (Atom a1) (Atom a2) = Just $ Atom $ Bool $ a1 == a2
  go Neq (Atom a1) (Atom a2) = Just $ Atom $ Bool $ a1 /= a2
  go Leq (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i <= j
  go Lt  (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i < j
  go Geq (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i >= j
  go Gt  (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i > j

  go And (Atom (Bool true))  b = Just b
  go And (Atom (Bool false)) _ = Just $ Atom $ Bool $ false

  go Or  (Atom (Bool true))  _ = Just $ Atom $ Bool $ true
  go Or  (Atom (Bool false)) b = Just b

  go Dollar f e = Just $ App f [e]

  go _       _               _               = Nothing

unary :: Op -> Expr -> Maybe Expr
unary Sub (Atom (Num i)) = Just $ Atom $ Num (-i)
unary _   _              = Nothing

apply :: Env -> String -> [Expr] -> Maybe Expr
apply env name args = case lookup name env of
  Nothing    -> Nothing
  Just cases -> head $ mapMaybe app cases
    where
    app :: Tuple [Binding] Expr -> Maybe Expr
    app (Tuple binds body) = matchls binds args body

matchls :: [Binding] -> [Expr] -> Expr -> Maybe Expr
matchls []     []     expr = Just expr
matchls (b:bs) (e:es) expr = do
  expr' <- execStateT (match b e) expr
  matchls bs es expr'
matchls []     es     expr = Just $ App expr es
matchls _ _ _ = Nothing

match :: Binding -> Expr -> StateT Expr Maybe Unit
match (Lit (Name x))   e                = modify (replace x e)
match (Lit (Num i))    (Atom (Num j))   | i == j  = return unit
match (Lit (Bool b))   (Atom (Bool b')) | b == b' = return unit
match (ConsLit b bs)   (List (e:es))    = match b e *> match bs (List es)
match (ConsLit b bs)   (Binary Cons e es) = match b e *> match bs es
match (ListLit [])     (List [])        = return unit
match (ListLit (b:bs)) (List (e:es))    = match b e *> match (ListLit bs) (List es)
match (ListLit (b:bs)) (Binary Cons e es) = match b e *> match (ListLit bs) es
match _                _                = lift Nothing

boundNames :: Binding -> [String]
boundNames = go
  where
  go (Lit (Name name)) = [name]
  go (ConsLit b1 b2)   = go b1 ++ go b2
  go (ListLit bs)      = foldMap go bs

isNameBound :: String -> Binding -> Boolean
isNameBound name binding = (elemIndex name $ boundNames binding) >= 0

replace :: String -> Expr -> Expr -> Expr
replace name value = go
  where
  go expr = case expr of
    a@(Atom (Name str)) -> if str == name then value else a
    (List exprs)        -> List (go <$> exprs)
    (Binary op e1 e2)   -> Binary op (go e1) (go e2)
    (Unary op e)        -> Unary op (go e)
    (SectL e op)        -> SectL (go e) op
    (SectR op e)        -> SectR op (go e)
    l@(Lambda binds body) -> if any (isNameBound name) binds
                               then l
                               else Lambda binds (go body)
    (App func exprs)    -> App (go func) (go <$> exprs)
    e                   -> e

module Evaluator
  ( Path(..)
  , Env()
  , evalPath1
  , defsToEnv
  ) where

import Data.Array    (head, mapMaybe, (!!), updateAt, elemIndex)
import Data.StrMap   (StrMap(), empty, lookup, insert)
import Data.Tuple
import Data.Maybe
import Data.Foldable (foldl, foldMap, any)

import Math (pow)

import Control.Apply ((*>))
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Trans

import AST

data Path = Start Path | Nth Number Path | Fst Path | Snd Path | End

select :: Path -> (Expr -> Maybe Expr) -> Expr -> Maybe Expr
select (Start p) eval expr = select p eval expr
select End       eval expr = eval expr

select (Fst p) eval expr = case expr of
  Binary op e1 e2 -> Binary op <$> (select p eval e1) <*> Just e2
  Unary op e      -> Unary op <$> select p eval e
  SectL e op      -> SectL <$> (select p eval e) <*> Just op
  SectR op e      -> SectR op <$> (select p eval) e
  Lambda bs body  -> Lambda bs <$> select p eval body
  App e es        -> App <$> (select p eval e) <*> Just es
  _               -> Nothing
select (Snd p) eval expr = case expr of
  Binary op e1 e2 -> Binary op e1 <$> select p eval e2
  _               -> Nothing
select (Nth n p) eval expr = case expr of
  List es  -> List <$> mapMIndex n (select p eval) es
  App e es -> App e <$> mapMIndex n (select p eval) es
  _        -> Nothing

mapMIndex :: forall m a. Number -> (a -> Maybe a) -> [a] -> Maybe [a]
mapMIndex i f as = do
  a <- (as !! i) >>= f
  return $ updateAt i a as

evalPath1 :: Env -> Path -> Expr -> Maybe Expr
evalPath1 env path expr = select path (eval1 env) expr

type Env = StrMap [Tuple [Binding] Expr]

defsToEnv :: [Definition] -> Env
defsToEnv = foldl insertDef empty

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case lookup name env of
  Nothing   -> insert name [Tuple bindings body] env
  Just defs -> insert name (defs ++ [Tuple bindings body]) env

eval1 :: Env -> Expr -> Maybe Expr
eval1 env expr = case expr of
  (Binary op e1 e2)             -> binary op e1 e2
  (Unary op e)                  -> unary op e
  (Atom (Name name))            -> apply env name []
  (App (Binary Composition f g) [e]) -> Just $ App f [App g [e]]
  (App (Lambda binds body) args) -> matchls binds args body
  (App (SectL e1 op) [e2])      -> Just $ Binary op e1 e2
  (App (SectR op e2) [e1])      -> Just $ Binary op e1 e2
  (App (Prefix op) [e1, e2])    -> Just $ Binary op e1 e2
  (App (Atom (Name name)) args) -> apply env name args
  (App (App func es) es')       -> Just $ App func (es ++ es')
  _                 -> Nothing

binary :: Op -> Expr -> Expr -> Maybe Expr
binary = go
  where
  go Power (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ pow i j

  go Mul (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i * j
  go Div (Atom (Num i)) (Atom (Num 0)) = Nothing
  go Div (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ Math.floor (i / j)
  go Mod (Atom (Num i)) (Atom (Num 0)) = Nothing
  go Mod (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i % j

  go Add (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i + j
  go Sub (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i - j

  go Cons   e          (List es)  = Just $ List $ e:es
  go Append (List es1) (List es2) = Just $ List $ es1 ++ es2

  go Eq  (Atom a1) (Atom a2) = Just $ Atom $ Bool $ a1 == a2
  go Neq (Atom a1) (Atom a2) = Just $ Atom $ Bool $ a1 /= a2
  go Leq (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i <= j
  go Lt  (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i < j
  go Geq (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i >= j
  go Gt  (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Bool $ i > j

  go And (Atom (Bool true))  b = Just b
  go And (Atom (Bool false)) _ = Just $ Atom $ Bool $ false

  go Or  (Atom (Bool true))  _ = Just $ Atom $ Bool $ true
  go Or  (Atom (Bool false)) b = Just b

  go Dollar f e = Just $ App f [e]

  go _       _               _               = Nothing

unary :: Op -> Expr -> Maybe Expr
unary Sub (Atom (Num i)) = Just $ Atom $ Num (-i)
unary _   _              = Nothing

apply :: Env -> String -> [Expr] -> Maybe Expr
apply env name args = case lookup name env of
  Nothing    -> Nothing
  Just cases -> head $ mapMaybe app cases
    where
    app :: Tuple [Binding] Expr -> Maybe Expr
    app (Tuple binds body) = matchls binds args body

matchls :: [Binding] -> [Expr] -> Expr -> Maybe Expr
matchls []     []     expr = Just expr
matchls (b:bs) (e:es) expr = do
  expr' <- execStateT (match b e) expr
  matchls bs es expr'
matchls []     es     expr = Just $ App expr es
matchls _ _ _ = Nothing

match :: Binding -> Expr -> StateT Expr Maybe Unit
match (Lit (Name x))   e                = modify (replace x e)
match (Lit (Num i))    (Atom (Num j))   | i == j  = return unit
match (Lit (Bool b))   (Atom (Bool b')) | b == b' = return unit
match (ConsLit b bs)   (List (e:es))    = match b e *> match bs (List es)
match (ConsLit b bs)   (Binary Cons e es) = match b e *> match bs es
match (ListLit [])     (List [])        = return unit
match (ListLit (b:bs)) (List (e:es))    = match b e *> match (ListLit bs) (List es)
match (ListLit (b:bs)) (Binary Cons e es) = match b e *> match (ListLit bs) es
match _                _                = lift Nothing

boundNames :: Binding -> [String]
boundNames = go
  where
  go (Lit (Name name)) = [name]
  go (ConsLit b1 b2)   = go b1 ++ go b2
  go (ListLit bs)      = foldMap go bs

isNameBound :: String -> Binding -> Boolean
isNameBound name binding = (elemIndex name $ boundNames binding) >= 0

replace :: String -> Expr -> Expr -> Expr
replace name value = go
  where
  go expr = case expr of
    a@(Atom (Name str)) -> if str == name then value else a
    (List exprs)        -> List (go <$> exprs)
    (Binary op e1 e2)   -> Binary op (go e1) (go e2)
    (Unary op e)        -> Unary op (go e)
    (SectL e op)        -> SectL (go e) op
    (SectR op e)        -> SectR op (go e)
    l@(Lambda binds body) -> if any (isNameBound name) binds
                               then l
                               else Lambda binds (go body)
    (App func exprs)    -> App (go func) (go <$> exprs)
    e                   -> e