Add more HTML5 input attributes

Add more HTML5 input attributes

* required
* spellcheck
* readonly

-- | This module enumerates some common HTML attributes, and provides additional
-- | helper functions for working with CSS classes.

module Halogen.HTML.Attributes
  ( ClassName()
  , className
  , runClassName

  , AttributeName()
  , attributeName
  , runAttributeName

  , EventName()
  , eventName
  , runEventName

  , Styles()
  , styles
  , runStyles

  , IsAttribute
  , toAttrString

  , ExistsR()
  , mkExistsR
  , runExistsR

  , AttrF(..)
  , HandlerF(..)

  , Attr(..)

  , attr
  , handler
  , initializer
  , finalizer

  , alt
  , charset
  , class_
  , classes
  , colSpan
  , rowSpan
  , content
  , for
  , height
  , href
  , httpEquiv
  , id_
  , name
  , rel
  , src
  , target
  , title
  , type_
  , value
  , width
  , disabled
  , required
  , readonly
  , spellcheck
  , enabled
  , checked
  , selected
  , placeholder
  , style
  ) where

import DOM

import Data.Maybe
import Data.Tuple
import Data.Either (either)
import Data.Foreign
import Data.StrMap (StrMap(), toList)
import Data.Monoid (mempty)
import Data.Array (map)
import Data.String (joinWith)
import Data.Traversable (mapAccumL)
import Data.Exists

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

import Halogen.Internal.VirtualDOM
import Halogen.HTML.Events.Types
import Halogen.HTML.Events.Handler

-- | We need a variant of `Exists` which works for type constructors which accept a _row_ of types.
data ExistsR (f :: # * -> *)

foreign import unsafeCoerce
  "function unsafeCoerce(x) {\
  \  return x;\
  \}" :: forall a b. a -> b

runExistsR :: forall f r. (forall a. f a -> r) -> ExistsR f -> r
runExistsR = unsafeCoerce

mkExistsR :: forall f a. f a -> ExistsR f
mkExistsR = unsafeCoerce

-- | The data which represents a typed attribute, hidden inside an existential package in
-- | the `Attr` type.
data AttrF value = AttrF (AttributeName value -> value -> String) (AttributeName value) value

-- | The data which represents a typed event handler, hidden inside an existential package in
-- | the `Attr` type.
data HandlerF i fields = HandlerF (EventName fields) (Event fields -> EventHandler i)

-- | A single attribute is either
-- |
-- | - An attribute
-- | - An event handler
data Attr i
  = Attr (Exists AttrF)
  | Handler (ExistsR (HandlerF i))
  | Initializer i
  | Finalizer i

instance functorAttr :: Functor Attr where
  (<$>) _ (Attr e) = Attr e
  (<$>) f (Handler e) = runExistsR (\(HandlerF name k) -> Handler (mkExistsR (HandlerF name (\e -> f <$> k e)))) e
  (<$>) f (Initializer i) = Initializer (f i)
  (<$>) f (Finalizer i) = Finalizer (f i)

-- | Create an attribute
attr :: forall value i. (IsAttribute value) => AttributeName value -> value -> Attr i
attr name v = Attr (mkExists (AttrF toAttrString name v))

-- | Create an event handler
handler :: forall fields i. EventName fields -> (Event fields -> EventHandler i) -> Attr i
handler name k = Handler (mkExistsR (HandlerF name k))

-- | Attach an initializer.
initializer :: forall i. i -> Attr i
initializer = Initializer

-- | Attach a finalizer.
finalizer :: forall i. i -> Attr i
finalizer = Finalizer

-- | A wrapper for strings which are used as CSS classes
newtype ClassName = ClassName String

-- Create a class name
className :: String -> ClassName
className = ClassName

-- | Unpack a class name
runClassName :: ClassName -> String
runClassName (ClassName s) = s

-- | A type-safe wrapper for attribute names
-- |
-- | The phantom type `value` describes the type of value which this attribute requires.
newtype AttributeName value = AttributeName String

-- | Create an attribute name
attributeName :: forall value. String -> AttributeName value
attributeName = AttributeName

-- | Unpack an attribute name
runAttributeName :: forall value. AttributeName value -> String
runAttributeName (AttributeName s) = s

-- | A type-safe wrapper for event names.
-- |
-- | The phantom type `fields` describes the event type which we can expect to exist on events
-- | corresponding to this name.
newtype EventName (fields :: # *) = EventName String

-- Create an event name
eventName :: forall fields. String -> EventName fields
eventName = EventName

-- | Unpack an event name
runEventName :: forall fields. EventName fields -> String
runEventName (EventName s) = s

-- | A newtype for CSS styles
newtype Styles = Styles (StrMap String)

-- Create CSS styles
styles :: StrMap String -> Styles
styles = Styles

-- | Unpack CSS styles
runStyles :: Styles -> StrMap String
runStyles (Styles m) = m

-- | This type class captures those types which can be used as attribute values.
-- |
-- | `toAttrString` is an alternative to `show`, and is needed by `attr` in the string renderer.
class IsAttribute a where
  toAttrString :: AttributeName a -> a -> String

instance stringIsAttribute :: IsAttribute String where
  toAttrString _ s = s

instance numberIsAttribute :: IsAttribute Number where
  toAttrString _ n = show n

instance booleanIsAttribute :: IsAttribute Boolean where
  toAttrString name true = runAttributeName name
  toAttrString _ false = ""

instance stylesIsAttribute :: IsAttribute Styles where
  toAttrString _ (Styles m) = joinWith "; " $ (\(Tuple key value) -> key <> ": " <> value) <$> toList m

-- Smart constructors

alt :: forall i. String -> Attr i
alt = attr $ attributeName "alt"

charset :: forall i. String -> Attr i
charset = attr $ attributeName "charset"

class_ :: forall i. ClassName -> Attr i
class_ = attr (attributeName "className") <<< runClassName

classes :: forall i. [ClassName] -> Attr i
classes ss = attr (attributeName "className") (joinWith " " $ map runClassName ss)

colSpan :: forall i. Number -> Attr i
colSpan = attr (attributeName "colSpan") <<< show

rowSpan :: forall i. Number -> Attr i
rowSpan = attr (attributeName "rowSpan") <<< show

content :: forall i. String -> Attr i
content = attr $ attributeName "content"

for :: forall i. String -> Attr i
for = attr $ attributeName "for"

height :: forall i. Number -> Attr i
height = attr (attributeName "height") <<< show

href :: forall i. String -> Attr i
href = attr $ attributeName "href"

httpEquiv :: forall i. String -> Attr i
httpEquiv = attr $ attributeName "http-equiv"

id_ :: forall i. String -> Attr i
id_ = attr $ attributeName "id"

name :: forall i. String -> Attr i
name = attr $ attributeName "name"

rel :: forall i. String -> Attr i
rel = attr $ attributeName "rel"

src :: forall i. String -> Attr i
src = attr $ attributeName "src"

target :: forall i. String -> Attr i
target = attr $ attributeName "target"

title :: forall i. String -> Attr i
title = attr $ attributeName "title"

type_ :: forall i. String -> Attr i
type_ = attr $ attributeName "type"

value :: forall i. String -> Attr i
value = attr $ attributeName "value"

width :: forall i. Number -> Attr i
width = attr (attributeName "width") <<< show

disabled :: forall i. Boolean -> Attr i
disabled = attr $ attributeName "disabled"

required :: forall i. Boolean -> Attr i
required = attr $ attributeName "required"

readonly :: forall i. Boolean -> Attr i
readonly = attr $ attributeName "readonly"

spellcheck :: forall i. Boolean -> Attr i
spellcheck = attr $ attributeName "spellcheck"

enabled :: forall i. Boolean -> Attr i
enabled = disabled <<< not

checked :: forall i. Boolean -> Attr i
checked = attr $ attributeName "checked"

selected :: forall i. Boolean -> Attr i
selected = attr $ attributeName "selected"

placeholder :: forall i. String -> Attr i
placeholder = attr $ attributeName "placeholder"

style :: forall i. Styles -> Attr i
style = attr $ attributeName "style"

-- | This module enumerates some common HTML attributes, and provides additional
-- | helper functions for working with CSS classes.

module Halogen.HTML.Attributes
  ( ClassName()
  , className
  , runClassName

  , AttributeName()
  , attributeName
  , runAttributeName

  , EventName()
  , eventName
  , runEventName

  , Styles()
  , styles
  , runStyles

  , IsAttribute
  , toAttrString

  , ExistsR()
  , mkExistsR
  , runExistsR

  , AttrF(..)
  , HandlerF(..)

  , Attr(..)

  , attr
  , handler
  , initializer
  , finalizer

  , alt
  , charset
  , class_
  , classes
  , colSpan
  , rowSpan
  , content
  , for
  , height
  , href
  , httpEquiv
  , id_
  , name
  , rel
  , src
  , target
  , title
  , type_
  , value
  , width
  , disabled
  , enabled
  , checked
  , selected
  , placeholder
  , style
  ) where

import DOM

import Data.Maybe
import Data.Tuple
import Data.Either (either)
import Data.Foreign
import Data.StrMap (StrMap(), toList)
import Data.Monoid (mempty)
import Data.Array (map)
import Data.String (joinWith)
import Data.Traversable (mapAccumL)
import Data.Exists

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

import Halogen.Internal.VirtualDOM
import Halogen.HTML.Events.Types
import Halogen.HTML.Events.Handler

-- | We need a variant of `Exists` which works for type constructors which accept a _row_ of types.
data ExistsR (f :: # * -> *)

foreign import unsafeCoerce
  "function unsafeCoerce(x) {\
  \  return x;\
  \}" :: forall a b. a -> b

runExistsR :: forall f r. (forall a. f a -> r) -> ExistsR f -> r
runExistsR = unsafeCoerce

mkExistsR :: forall f a. f a -> ExistsR f
mkExistsR = unsafeCoerce

-- | The data which represents a typed attribute, hidden inside an existential package in
-- | the `Attr` type.
data AttrF value = AttrF (AttributeName value -> value -> String) (AttributeName value) value

-- | The data which represents a typed event handler, hidden inside an existential package in
-- | the `Attr` type.
data HandlerF i fields = HandlerF (EventName fields) (Event fields -> EventHandler i)

-- | A single attribute is either
-- |
-- | - An attribute
-- | - An event handler
data Attr i
  = Attr (Exists AttrF)
  | Handler (ExistsR (HandlerF i))
  | Initializer i
  | Finalizer i

instance functorAttr :: Functor Attr where
  (<$>) _ (Attr e) = Attr e
  (<$>) f (Handler e) = runExistsR (\(HandlerF name k) -> Handler (mkExistsR (HandlerF name (\e -> f <$> k e)))) e
  (<$>) f (Initializer i) = Initializer (f i)
  (<$>) f (Finalizer i) = Finalizer (f i)

-- | Create an attribute
attr :: forall value i. (IsAttribute value) => AttributeName value -> value -> Attr i
attr name v = Attr (mkExists (AttrF toAttrString name v))

-- | Create an event handler
handler :: forall fields i. EventName fields -> (Event fields -> EventHandler i) -> Attr i
handler name k = Handler (mkExistsR (HandlerF name k))

-- | Attach an initializer.
initializer :: forall i. i -> Attr i
initializer = Initializer

-- | Attach a finalizer.
finalizer :: forall i. i -> Attr i
finalizer = Finalizer

-- | A wrapper for strings which are used as CSS classes
newtype ClassName = ClassName String

-- Create a class name
className :: String -> ClassName
className = ClassName

-- | Unpack a class name
runClassName :: ClassName -> String
runClassName (ClassName s) = s

-- | A type-safe wrapper for attribute names
-- |
-- | The phantom type `value` describes the type of value which this attribute requires.
newtype AttributeName value = AttributeName String

-- | Create an attribute name
attributeName :: forall value. String -> AttributeName value
attributeName = AttributeName

-- | Unpack an attribute name
runAttributeName :: forall value. AttributeName value -> String
runAttributeName (AttributeName s) = s

-- | A type-safe wrapper for event names.
-- |
-- | The phantom type `fields` describes the event type which we can expect to exist on events
-- | corresponding to this name.
newtype EventName (fields :: # *) = EventName String

-- Create an event name
eventName :: forall fields. String -> EventName fields
eventName = EventName

-- | Unpack an event name
runEventName :: forall fields. EventName fields -> String
runEventName (EventName s) = s

-- | A newtype for CSS styles
newtype Styles = Styles (StrMap String)

-- Create CSS styles
styles :: StrMap String -> Styles
styles = Styles

-- | Unpack CSS styles
runStyles :: Styles -> StrMap String
runStyles (Styles m) = m

-- | This type class captures those types which can be used as attribute values.
-- |
-- | `toAttrString` is an alternative to `show`, and is needed by `attr` in the string renderer.
class IsAttribute a where
  toAttrString :: AttributeName a -> a -> String

instance stringIsAttribute :: IsAttribute String where
  toAttrString _ s = s

instance numberIsAttribute :: IsAttribute Number where
  toAttrString _ n = show n

instance booleanIsAttribute :: IsAttribute Boolean where
  toAttrString name true = runAttributeName name
  toAttrString _ false = ""

instance stylesIsAttribute :: IsAttribute Styles where
  toAttrString _ (Styles m) = joinWith "; " $ (\(Tuple key value) -> key <> ": " <> value) <$> toList m

-- Smart constructors

alt :: forall i. String -> Attr i
alt = attr $ attributeName "alt"

charset :: forall i. String -> Attr i
charset = attr $ attributeName "charset"

class_ :: forall i. ClassName -> Attr i
class_ = attr (attributeName "className") <<< runClassName

classes :: forall i. [ClassName] -> Attr i
classes ss = attr (attributeName "className") (joinWith " " $ map runClassName ss)

colSpan :: forall i. Number -> Attr i
colSpan = attr (attributeName "colSpan") <<< show

rowSpan :: forall i. Number -> Attr i
rowSpan = attr (attributeName "rowSpan") <<< show

content :: forall i. String -> Attr i
content = attr $ attributeName "content"

for :: forall i. String -> Attr i
for = attr $ attributeName "for"

height :: forall i. Number -> Attr i
height = attr (attributeName "height") <<< show

href :: forall i. String -> Attr i
href = attr $ attributeName "href"

httpEquiv :: forall i. String -> Attr i
httpEquiv = attr $ attributeName "http-equiv"

id_ :: forall i. String -> Attr i
id_ = attr $ attributeName "id"

name :: forall i. String -> Attr i
name = attr $ attributeName "name"

rel :: forall i. String -> Attr i
rel = attr $ attributeName "rel"

src :: forall i. String -> Attr i
src = attr $ attributeName "src"

target :: forall i. String -> Attr i
target = attr $ attributeName "target"

title :: forall i. String -> Attr i
title = attr $ attributeName "title"

type_ :: forall i. String -> Attr i
type_ = attr $ attributeName "type"

value :: forall i. String -> Attr i
value = attr $ attributeName "value"

width :: forall i. Number -> Attr i
width = attr (attributeName "width") <<< show

disabled :: forall i. Boolean -> Attr i
disabled = attr $ attributeName "disabled"

enabled :: forall i. Boolean -> Attr i
enabled = disabled <<< not

checked :: forall i. Boolean -> Attr i
checked = attr $ attributeName "checked"

selected :: forall i. Boolean -> Attr i
selected = attr $ attributeName "selected"

placeholder :: forall i. String -> Attr i
placeholder = attr $ attributeName "placeholder"

style :: forall i. Styles -> Attr i
style = attr $ attributeName "style"


Fix warnings

Fix warnings

module Node.ChildProcess.Signal
  ( Signal(..)
  , sigabrt
  , sigalrm
  , sigbus
  , sigchld
  , sigcld
  , sigcont
  , sigemt
  , sigfpe
  , sighup
  , sigill
  , siginfo
  , sigint
  , sigio
  , sigiot
  , sigkill
  , siglost
  , sigpipe
  , sigpoll
  , sigprof
  , sigpwr
  , sigquit
  , sigsegv
  , sigstkflt
  , sigstop
  , sigsys
  , sigterm
  , sigtrap
  , sigtstp
  , sigttin
  , sigttou
  , sigunused
  , sigurg
  , sigusr1
  , sigusr2
  , sigvtalrm
  , sigwinch
  , sigxcpu
  , sigxfsz
  ) where

import Prelude (Show)

newtype Signal = Signal String

sigabrt  :: Signal
sigabrt   = Signal "SIGABRT"
sigalrm  :: Signal
sigalrm   = Signal "SIGALRM"
sigbus   :: Signal
sigbus    = Signal "SIGBUS"
sigchld  :: Signal
sigchld   = Signal "SIGCHLD"
sigcld   :: Signal
sigcld    = Signal "SIGCLD"
sigcont  :: Signal
sigcont   = Signal "SIGCONT"
sigemt   :: Signal
sigemt    = Signal "SIGEMT"
sigfpe   :: Signal
sigfpe    = Signal "SIGFPE"
sighup   :: Signal
sighup    = Signal "SIGHUP"
sigill   :: Signal
sigill    = Signal "SIGILL"
siginfo  :: Signal
siginfo   = Signal "SIGINFO"
sigint   :: Signal
sigint    = Signal "SIGINT"
sigio    :: Signal
sigio     = Signal "SIGIO"
sigiot   :: Signal
sigiot    = Signal "SIGIOT"
sigkill  :: Signal
sigkill   = Signal "SIGKILL"
siglost  :: Signal
siglost   = Signal "SIGLOST"
sigpipe  :: Signal
sigpipe   = Signal "SIGPIPE"
sigpoll  :: Signal
sigpoll   = Signal "SIGPOLL"
sigprof  :: Signal
sigprof   = Signal "SIGPROF"
sigpwr   :: Signal
sigpwr    = Signal "SIGPWR"
sigquit  :: Signal
sigquit   = Signal "SIGQUIT"
sigsegv  :: Signal
sigsegv   = Signal "SIGSEGV"
sigstkflt:: Signal
sigstkflt = Signal "SIGSTKFLT"
sigstop  :: Signal
sigstop   = Signal "SIGSTOP"
sigsys   :: Signal
sigsys    = Signal "SIGSYS"
sigterm  :: Signal
sigterm   = Signal "SIGTERM"
sigtrap  :: Signal
sigtrap   = Signal "SIGTRAP"
sigtstp  :: Signal
sigtstp   = Signal "SIGTSTP"
sigttin  :: Signal
sigttin   = Signal "SIGTTIN"
sigttou  :: Signal
sigttou   = Signal "SIGTTOU"
sigunused:: Signal
sigunused = Signal "SIGUNUSED"
sigurg   :: Signal
sigurg    = Signal "SIGURG"
sigusr1  :: Signal
sigusr1   = Signal "SIGUSR1"
sigusr2  :: Signal
sigusr2   = Signal "SIGUSR2"
sigvtalrm:: Signal
sigvtalrm = Signal "SIGVTALRM"
sigwinch :: Signal
sigwinch  = Signal "SIGWINCH"
sigxcpu  :: Signal
sigxcpu   = Signal "SIGXCPU"
sigxfsz  :: Signal
sigxfsz   = Signal "SIGXFSZ"

instance showSignal :: Show Signal where
  show (Signal sig) = sig

module Node.ChildProcess.Signal
  ( Signal(..)
  , sigabrt
  , sigalrm
  , sigbus
  , sigchld
  , sigcld
  , sigcont
  , sigemt
  , sigfpe
  , sighup
  , sigill
  , siginfo
  , sigint
  , sigio
  , sigiot
  , sigkill
  , siglost
  , sigpipe
  , sigpoll
  , sigprof
  , sigpwr
  , sigquit
  , sigsegv
  , sigstkflt
  , sigstop
  , sigsys
  , sigterm
  , sigtrap
  , sigtstp
  , sigttin
  , sigttou
  , sigunused
  , sigurg
  , sigusr1
  , sigusr2
  , sigvtalrm
  , sigwinch
  , sigxcpu
  , sigxfsz
  ) where

import Prelude (Show)

newtype Signal = Signal String

sigabrt   = Signal "SIGABRT"
sigalrm   = Signal "SIGALRM"
sigbus    = Signal "SIGBUS"
sigchld   = Signal "SIGCHLD"
sigcld    = Signal "SIGCLD"
sigcont   = Signal "SIGCONT"
sigemt    = Signal "SIGEMT"
sigfpe    = Signal "SIGFPE"
sighup    = Signal "SIGHUP"
sigill    = Signal "SIGILL"
siginfo   = Signal "SIGINFO"
sigint    = Signal "SIGINT"
sigio     = Signal "SIGIO"
sigiot    = Signal "SIGIOT"
sigkill   = Signal "SIGKILL"
siglost   = Signal "SIGLOST"
sigpipe   = Signal "SIGPIPE"
sigpoll   = Signal "SIGPOLL"
sigprof   = Signal "SIGPROF"
sigpwr    = Signal "SIGPWR"
sigquit   = Signal "SIGQUIT"
sigsegv   = Signal "SIGSEGV"
sigstkflt = Signal "SIGSTKFLT"
sigstop   = Signal "SIGSTOP"
sigsys    = Signal "SIGSYS"
sigterm   = Signal "SIGTERM"
sigtrap   = Signal "SIGTRAP"
sigtstp   = Signal "SIGTSTP"
sigttin   = Signal "SIGTTIN"
sigttou   = Signal "SIGTTOU"
sigunused = Signal "SIGUNUSED"
sigurg    = Signal "SIGURG"
sigusr1   = Signal "SIGUSR1"
sigusr2   = Signal "SIGUSR2"
sigvtalrm = Signal "SIGVTALRM"
sigwinch  = Signal "SIGWINCH"
sigxcpu   = Signal "SIGXCPU"
sigxfsz   = Signal "SIGXFSZ"

instance showSignal :: Show Signal where
  show (Signal sig) = sig


Bikeshedding

Bikeshedding

module Main where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Data.Maybe (Maybe(Just, Nothing))
import Data.MediaType.Common (textHTML)
import Data.Tuple (Tuple(Tuple))
import Hyper.Authentication (authenticated, withAuthentication)
import Hyper.Core (writeStatus, closeHeaders, statusOK, Port(Port))
import Hyper.HTML.DSL (p, text, html)
import Hyper.Node.BasicAuth (BasicAuth(BasicAuth))
import Hyper.Node.Server (runServer, defaultOptions)
import Hyper.Response (contentType)
import Node.Buffer (BUFFER)
import Node.HTTP (HTTP)

data User = User String

userFromBasicAuth :: forall e. Tuple String String -> Aff e (Maybe User)
userFromBasicAuth =
  case _ of
    Tuple "admin" "admin" -> pure (Just (User "Administrator"))
    _ -> pure Nothing

main :: forall e. Eff (console :: CONSOLE, http ∷ HTTP, buffer :: BUFFER | e) Unit
main =
  let
    onListening (Port port) = log ("Listening on http://localhost:" <> show port)
    onRequestError err = log ("Request failed: " <> show err)

    myProfilePage conn@{ components: { authentication: User name } } =
      writeStatus statusOK conn
      >>= contentType textHTML
      >>= closeHeaders
      >>= html (p [] (text ("You are authenticated as " <> name <> ".")))

    app = withAuthentication >=> (authenticated myProfilePage)
    components =
      { authentication: unit
      , authenticator: BasicAuth userFromBasicAuth
      }
  in runServer defaultOptions onListening onRequestError components app

module Main where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Data.Maybe (Maybe(Just, Nothing))
import Data.MediaType.Common (textHTML)
import Data.Tuple (Tuple(Tuple))
import Hyper.Authentication (authenticated, withAuthentication)
import Hyper.Core (writeStatus, closeHeaders, statusOK, Port(Port))
import Hyper.HTML.DSL (p, text, html)
import Hyper.Node.BasicAuth (BasicAuth(BasicAuth))
import Hyper.Node.Server (runServer, defaultOptions)
import Hyper.Response (contentType)
import Node.Buffer (BUFFER)
import Node.HTTP (HTTP)

data User = User String

userFromBasicAuth :: forall e. Tuple String String -> Aff e (Maybe User)
userFromBasicAuth =
  case _ of
    Tuple "admin" "admin" -> pure (Just (User "Administrator"))
    _ -> pure Nothing

main :: forall e. Eff (console :: CONSOLE, http ∷ HTTP, buffer :: BUFFER | e) Unit
main =
  let
    onListening (Port port) = log ("Listening on http://localhost:" <> show port)
    onRequestError err = log ("Request failed: " <> show err)

    myProfilePage conn@{ components: { authentication: (User name) } } =
      writeStatus statusOK conn
      >>= contentType textHTML
      >>= closeHeaders
      >>= html (p [] (text ("You are authenticated as " <> name <> ".")))

    app = withAuthentication >=> (authenticated myProfilePage)
    components =
      { authentication: unit
      , authenticator: BasicAuth userFromBasicAuth
      }
  in runServer defaultOptions onListening onRequestError components app


Fix warnings

Fix warnings

{-
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.Header.Gripper.Component where

import SlamData.Prelude

import DOM.HTML (window)
import DOM.HTML.Window as Win
import DOM.HTML.Types as Ht
import DOM.Event.EventTarget as Etr
import DOM.Event.EventTypes as Etp
import DOM.Node.ParentNode as Pn
import Data.Nullable as N
import DOM.Node.Types as Dt

import CSS.Geometry (marginTop)
import CSS.Size (px)
import CSS.String (fromString)
import CSS.Stylesheet (CSS, (?), keyframesFromTo)
import CSS.Animation (animation, iterationCount, normalAnimationDirection, forwards)
import CSS.Time (sec)
import CSS.Transition (easeOut)

import Halogen as H
import Halogen.HTML.CSS as CSS
import Halogen.HTML.Events.Handler as HEH
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA

import SlamData.Effects (Slam)

data Query a
  = Init a
  | StartDragging Number a
  | StopDragging a
  | ChangePosition Number a
  | Animated a

data Direction = Up | Down

data State
  = Closed
  | Opened
  | Dragging Direction Number Number
  | Opening Number
  | Closing Number

initialState ∷ State
initialState = Closed

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Slam

comp ∷ String → H.Component State Query Slam
comp querySelector = H.lifecycleComponent
  { render: render querySelector
  , eval: eval querySelector
  , initializer: Just (H.action Init)
  , finalizer: Nothing
  }

render ∷ String → State → HTML
render sel state =
  HH.div
    [ HP.classes
        [ HH.className "header-gripper"
        , HH.className $ className state
        ]
    , HE.onMouseDown \evt →
        HEH.preventDefault $> Just (H.action $ StartDragging evt.clientY)
    , ARIA.label $ label state
    ]
    [ CSS.stylesheet $ renderStyles sel state ]
  where
  label ∷ State → String
  label Closed = "Show header"
  label (Opening _) = "Show header"
  label (Dragging Down _ _) = "Show header"
  label _ = "Hide header"

  className ∷ State → String
  className Opened = "sd-header-gripper-opened"
  className Closed = "sd-header-gripper-closed"
  className (Opening _) = "sd-header-gripper-opening"
  className (Closing _) = "sd-header-gripper-closing"
  className (Dragging Down _ _) = "sd-header-gripper-dragging-down"
  className (Dragging Up _ _) = "sd-header-gripper-dragging-up"

maxMargin ∷ Number
maxMargin = 70.0

animationDuration ∷ Number
animationDuration = 0.5

renderStyles ∷ String → State → CSS
renderStyles sel Closed = do
  (fromString sel) ? (marginTop $ px (-maxMargin))
renderStyles sel Opened = do
  (fromString sel) ? (marginTop $ px zero)
renderStyles sel (Opening startPos) = do
  let
    marginTo = zero
    marginFrom = startPos - maxMargin
  mkAnimation sel marginFrom marginTo
renderStyles sel (Closing startPos) = do
  let
    marginTo = -maxMargin
    marginFrom = startPos - maxMargin
  mkAnimation sel marginFrom marginTo
renderStyles sel (Dragging _ start current) = do
  (fromString sel) ? do
    marginTop $ px (-maxMargin + current - start)

mkAnimation ∷ String → Number → Number → CSS
mkAnimation sel marginFrom marginTo = do
  let
    marginFromStyle = marginTop $ px marginFrom
    marginToStyle = marginTop $ px marginTo
  (fromString sel) ? do
    keyframesFromTo "header-gripper-margin" marginFromStyle marginToStyle
    animation
      (fromString "header-gripper-margin")
      (sec animationDuration)
      easeOut
      (sec zero)
      (iterationCount one)
      normalAnimationDirection
      forwards

eval ∷ String → (Query ~> DSL)
eval sel (Init next) = do
  doc ←
    H.fromEff
      $ window
      >>= Win.document

  mbNavEl ←
    H.fromEff
      $ Pn.querySelector sel (Ht.htmlDocumentToParentNode doc)
      <#> N.toMaybe
  let
    evntify ∷ ∀ a. a → { clientY ∷ Number }
    evntify = Unsafe.Coerce.unsafeCoerce

    docTarget = Ht.htmlDocumentToEventTarget doc

    attachMouseUp f =
      Etr.addEventListener Etp.mouseup (Etr.eventListener f) false docTarget
    attachMouseMove f =
      Etr.addEventListener Etp.mousemove (Etr.eventListener f) false docTarget

    handleMouseUp e =
      pure $ H.action $ StopDragging
    handleMouseMove e = do
      pure $ H.action $ ChangePosition (evntify e).clientY

  H.subscribe $ H.eventSource attachMouseUp handleMouseUp
  H.subscribe $ H.eventSource attachMouseMove handleMouseMove

  for_ mbNavEl \navEl →
    let
      attachAnimationEnd f =
        Etr.addEventListener Etp.animationend (Etr.eventListener f) false
          $ Dt.elementToEventTarget navEl

      handleAnimationEnd e =
        pure $ H.action Animated
    in
      H.subscribe $ H.eventSource attachAnimationEnd handleAnimationEnd
  pure next
eval _ (StartDragging pos next) = do
  astate ← H.get
  case astate of
    Closed → H.set (Dragging Down pos pos)
    Opened → H.set (Dragging Up (pos - maxMargin) pos)
    _ → pure unit
  pure next
eval _ (StopDragging next) = do
  astate ← H.get
  case astate of
    Dragging dir s current →
      let
        nextState Down = Opening
        nextState Up = Closing
      in
        H.set (nextState dir $ current - s)
    _ → pure unit
  pure next
eval _ (ChangePosition num next) = do
  astate ← H.get
  let
    toSet s =
      let diff = num - s
      in s + if diff < 0.0 then 0.0 else if diff > maxMargin then maxMargin else diff
    direction oldPos oldDir =
      if num ≡ oldPos then oldDir else if num > oldPos then Down  else Up
  case astate of
    Dragging oldDir s old →
      H.set (Dragging (direction old oldDir) s $ toSet s)
    _ → pure unit
  pure next
eval _ (Animated next) = do
  astate ← H.get
  case astate of
    Opening _ → H.set Opened
    Closing _ → H.set Closed
    _ → pure unit
  pure next

{-
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.Header.Gripper.Component where

import SlamData.Prelude

import DOM.HTML (window)
import DOM.HTML.Window as Win
import DOM.HTML.Types as Ht
import DOM.Event.EventTarget as Etr
import DOM.Event.EventTypes as Etp
import DOM.Node.ParentNode as Pn
import Data.Nullable as N
import DOM.Node.Types as Dt

import CSS.Geometry (marginTop)
import CSS.Size (px)
import CSS.String (fromString)
import CSS.Stylesheet (CSS, (?), keyframesFromTo)
import CSS.Animation (animation, iterationCount, normalAnimationDirection, forwards)
import CSS.Time (sec)
import CSS.Transition (easeOut)

import Halogen as H
import Halogen.HTML.CSS as CSS
import Halogen.HTML.Events.Handler as HEH
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Effects (Slam)
import SlamData.Render.Common (glyph)

data Query a
  = Init a
  | StartDragging Number a
  | StopDragging a
  | ChangePosition Number a
  | Animated a

data Direction = Up | Down

data State
  = Closed
  | Opened
  | Dragging Direction Number Number
  | Opening Number
  | Closing Number

initialState ∷ State
initialState = Closed

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Slam

comp ∷ String → H.Component State Query Slam
comp querySelector = H.lifecycleComponent
  { render: render querySelector
  , eval: eval querySelector
  , initializer: Just (H.action Init)
  , finalizer: Nothing
  }

render ∷ String → State → HTML
render sel state =
  HH.div
    [ HP.classes
        [ HH.className "header-gripper"
        , HH.className $ className state
        ]
    , HE.onMouseDown \evt →
        HEH.preventDefault $> Just (H.action $ StartDragging evt.clientY)
    , ARIA.label $ label state
    ]
    [ CSS.stylesheet $ renderStyles sel state ]
  where
  label ∷ State → String
  label Closed = "Show header"
  label (Opening _) = "Show header"
  label (Dragging Down _ _) = "Show header"
  label _ = "Hide header"

  className ∷ State → String
  className Opened = "sd-header-gripper-opened"
  className Closed = "sd-header-gripper-closed"
  className (Opening _) = "sd-header-gripper-opening"
  className (Closing _) = "sd-header-gripper-closing"
  className (Dragging Down _ _) = "sd-header-gripper-dragging-down"
  className (Dragging Up _ _) = "sd-header-gripper-dragging-up"

maxMargin ∷ Number
maxMargin = 70.0

animationDuration ∷ Number
animationDuration = 0.5

renderStyles ∷ String → State → CSS
renderStyles sel Closed = do
  (fromString sel) ? (marginTop $ px (-maxMargin))
renderStyles sel Opened = do
  (fromString sel) ? (marginTop $ px zero)
renderStyles sel (Opening startPos) = do
  let
    marginTo = zero
    marginFrom = startPos - maxMargin
  mkAnimation sel marginFrom marginTo
renderStyles sel (Closing startPos) = do
  let
    marginTo = -maxMargin
    marginFrom = startPos - maxMargin
  mkAnimation sel marginFrom marginTo
renderStyles sel (Dragging _ start current) = do
  (fromString sel) ? do
    marginTop $ px (-maxMargin + current - start)

mkAnimation ∷ String → Number → Number → CSS
mkAnimation sel marginFrom marginTo = do
  let
    marginFromStyle = marginTop $ px marginFrom
    marginToStyle = marginTop $ px marginTo
  (fromString sel) ? do
    keyframesFromTo "header-gripper-margin" marginFromStyle marginToStyle
    animation
      (fromString "header-gripper-margin")
      (sec animationDuration)
      easeOut
      (sec zero)
      (iterationCount one)
      normalAnimationDirection
      forwards

eval ∷ String → (Query ~> DSL)
eval sel (Init next) = do
  doc ←
    H.fromEff
      $ window
      >>= Win.document

  mbNavEl ←
    H.fromEff
      $ Pn.querySelector sel (Ht.htmlDocumentToParentNode doc)
      <#> N.toMaybe
  let
    evntify ∷ ∀ a. a → { clientY ∷ Number }
    evntify = Unsafe.Coerce.unsafeCoerce

    docTarget = Ht.htmlDocumentToEventTarget doc

    attachMouseUp f =
      Etr.addEventListener Etp.mouseup (Etr.eventListener f) false docTarget
    attachMouseMove f =
      Etr.addEventListener Etp.mousemove (Etr.eventListener f) false docTarget

    handleMouseUp e =
      pure $ H.action $ StopDragging
    handleMouseMove e = do
      pure $ H.action $ ChangePosition (evntify e).clientY

  H.subscribe $ H.eventSource attachMouseUp handleMouseUp
  H.subscribe $ H.eventSource attachMouseMove handleMouseMove

  for_ mbNavEl \navEl →
    let
      attachAnimationEnd f =
        Etr.addEventListener Etp.animationend (Etr.eventListener f) false
          $ Dt.elementToEventTarget navEl

      handleAnimationEnd e =
        pure $ H.action Animated
    in
      H.subscribe $ H.eventSource attachAnimationEnd handleAnimationEnd
  pure next
eval _ (StartDragging pos next) = do
  astate ← H.get
  case astate of
    Closed → H.set (Dragging Down pos pos)
    Opened → H.set (Dragging Up (pos - maxMargin) pos)
    _ → pure unit
  pure next
eval _ (StopDragging next) = do
  astate ← H.get
  case astate of
    Dragging dir s current →
      let
        nextState Down = Opening
        nextState Up = Closing
      in
        H.set (nextState dir $ current - s)
    _ → pure unit
  pure next
eval _ (ChangePosition num next) = do
  astate ← H.get
  let
    toSet s =
      let diff = num - s
      in s + if diff < 0.0 then 0.0 else if diff > maxMargin then maxMargin else diff
    direction oldPos oldDir =
      if num ≡ oldPos then oldDir else if num > oldPos then Down  else Up
  case astate of
    Dragging oldDir s old →
      H.set (Dragging (direction old oldDir) s $ toSet s)
    _ → pure unit
  pure next
eval _ (Animated next) = do
  astate ← H.get
  case astate of
    Opening _ → H.set Opened
    Closing _ → H.set Closed
    _ → pure unit
  pure next


Write model updates to eval bus

Write model updates to eval bus

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Component
  ( CardComponent
  , makeCardComponent
  , module SlamData.Workspace.Card.Component.Def
  , module SlamData.Workspace.Card.Common
  , module CQ
  , module CS
  , module EQ
  ) where

import SlamData.Prelude

import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.EventLoop (break')
import Control.Monad.Aff.Free (fromAff)

import Data.Foldable (elem)
import Data.Lens (PrismP, (.~), (?~), review, preview, clonePrism)

import DOM.HTML.HTMLElement (getBoundingClientRect)

import Halogen as H
import Halogen.Component.Utils (subscribeToBus')
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA

import SlamData.Monad (Slam)
import SlamData.Workspace.Card.CardType (CardType(..), cardClasses, cardName, darkCardGlyph)
import SlamData.Workspace.Card.Common.EvalQuery as EQ
import SlamData.Workspace.Card.Common (CardOptions)
import SlamData.Workspace.Card.Component.CSS as CSS
import SlamData.Workspace.Card.Component.Def (CardDef, makeQueryPrism, makeQueryPrism')
import SlamData.Workspace.Card.Component.Query as CQ
import SlamData.Workspace.Card.Component.State as CS
import SlamData.Workspace.Eval.Card as Card
import SlamData.Workspace.Eval.Persistence as P

-- | Type synonym for the full type of a card component.
type CardComponent = H.Component CS.CardStateP CQ.CardQueryP Slam
type CardDSL = H.ParentDSL CS.CardState CS.AnyCardState CQ.CardQuery CQ.InnerCardQuery Slam Unit
type CardHTML = H.ParentHTML CS.AnyCardState CQ.CardQuery CQ.InnerCardQuery Slam Unit

-- | Card component factory
makeCardComponent
  ∷ ∀ s f
  . CardDef s f ()
  → CardComponent
makeCardComponent def = makeCardComponentPart def render
  where
  render
    ∷ H.Component CS.AnyCardState CQ.InnerCardQuery Slam
    → CS.AnyCardState
    → CS.CardState
    → CardHTML
  render component initialState = const $
    HH.div
      [ HP.classes $ [ CSS.deckCard ]
      , ARIA.label $ (cardName def.cardType) ⊕ " card"
      , HP.ref (H.action ∘ CQ.SetElement)
      ]
      $ fold [cardLabel, card]
    where
    cardLabel ∷ Array CardHTML
    cardLabel
      | def.cardType `elem` [PendingCard, ErrorCard, NextAction, Draftboard] = []
      | otherwise =
          [ HH.div
              [ HP.classes [CSS.cardHeader]
              ]
              [ HH.div
                  [ HP.class_ CSS.cardName ]
                  [ darkCardGlyph def.cardType
                  , HH.p_ [ HH.text $ cardName def.cardType ]
                  ]
              ]
          ]
    card ∷ Array CardHTML
    card =
      [ HH.div
          [ HP.classes $ cardClasses def.cardType ]
          [ HH.slot unit \_ → { component, initialState } ]
      ]

-- | Constructs a card component from a record with the necessary properties and
-- | a render function.
makeCardComponentPart
  ∷ ∀ s f r
  . CardDef s f r
  → (H.Component CS.AnyCardState CQ.InnerCardQuery Slam
     → CS.AnyCardState
     → CS.CardState
     → CardHTML)
  → CardComponent
makeCardComponentPart def render =
  H.lifecycleParentComponent
    { render: render component initialState
    , eval
    , peek: Just (coproduct peek (const (pure unit)) ∘ H.runChildF)
    , initializer: Just (H.action CQ.Initialize)
    , finalizer: Just (H.action CQ.Finalize)
    }
  where

  displayCoord ∷ Card.DisplayCoord
  displayCoord = def.options.cursor × def.options.coord

  _State ∷ PrismP CS.AnyCardState s
  _State = clonePrism def._State

  _Query ∷ ∀ a. PrismP (CQ.InnerCardQuery a) (f a)
  _Query = clonePrism def._Query

  component ∷ H.Component CS.AnyCardState CQ.InnerCardQuery Slam
  component =
    H.transform
      (review _State) (preview _State)
      (review _Query) (preview _Query)
      def.component

  initialState ∷ CS.AnyCardState
  initialState = review _State def.initialState

  eval ∷ CQ.CardQuery ~> CardDSL
  eval = case _ of
    CQ.Initialize next → do
      cell ← H.liftH $ H.liftH $ P.getCard def.options.coord
      for_ cell \{ bus, value } → do
        queryInnerCard $ EQ.Load value.model.model
        breaker ← subscribeToBus' (H.action ∘ CQ.HandleEvalMessage) bus
        H.modify _
          { breaker = Just breaker
          , bus = Just bus
          }
      pure next
    CQ.Finalize next → do
      H.gets _.breaker >>= traverse_ (fromAff ∘ break')
      pure next
    CQ.ActivateCard next →
      queryInnerCard EQ.Activate $> next
    CQ.DeactivateCard next →
      queryInnerCard EQ.Deactivate $> next
    CQ.SetElement el next →
      H.modify (CS._element .~ el) $> next
    CQ.UpdateDimensions next → do
      H.gets _.element >>= traverse_ \el -> do
        { width, height } ← H.fromEff (getBoundingClientRect el)
        unless (width ≡ zero ∧ height ≡ zero) do
          queryInnerCard $ EQ.ReceiveDimensions { width, height }
      pure next
    CQ.HandleEvalMessage msg next → do
      case msg of
        Card.Pending evalPort → do
          queryInnerCard $ EQ.ReceiveInput evalPort
          H.modify (CS._pending .~ true)
        Card.Complete evalPort → do
          queryInnerCard $ EQ.ReceiveOutput evalPort
          H.modify (CS._pending .~ false)
        Card.StateChange evalState →
          queryInnerCard $ EQ.ReceiveState evalState
        Card.ModelChange source evalModel →
          when (source ≠ displayCoord) do
            queryInnerCard $ EQ.Load evalModel
      pure next

  peek ∷ ∀ a. EQ.CardEvalQuery a → CardDSL Unit
  peek = case _ of
    EQ.ModelUpdated EQ.EvalModelUpdate _ → do
      st ← H.get
      model ← H.query unit (left (H.request EQ.Save))
      traverse_ fromAff $
        Bus.write ∘ Card.ModelChange displayCoord <$> model <*> st.bus
    _ →
      pure unit

queryInnerCard ∷ H.Action EQ.CardEvalQuery → CardDSL Unit
queryInnerCard q =
  void $ H.query unit (left (H.action q))

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Component
  ( CardComponent
  , makeCardComponent
  , module SlamData.Workspace.Card.Component.Def
  , module SlamData.Workspace.Card.Common
  , module CQ
  , module CS
  , module EQ
  ) where

import SlamData.Prelude

import Control.Monad.Aff.EventLoop (break')
import Control.Monad.Aff.Free (fromAff)

import Data.Foldable (elem)
import Data.Lens (PrismP, (.~), (?~), review, preview, clonePrism)

import DOM.HTML.HTMLElement (getBoundingClientRect)

import Halogen as H
import Halogen.Component.Utils (subscribeToBus')
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA

import SlamData.Monad (Slam)
import SlamData.Workspace.Card.CardType (CardType(..), cardClasses, cardName, darkCardGlyph)
import SlamData.Workspace.Card.Common.EvalQuery as EQ
import SlamData.Workspace.Card.Common (CardOptions)
import SlamData.Workspace.Card.Component.CSS as CSS
import SlamData.Workspace.Card.Component.Def (CardDef, makeQueryPrism, makeQueryPrism')
import SlamData.Workspace.Card.Component.Query as CQ
import SlamData.Workspace.Card.Component.State as CS
import SlamData.Workspace.Eval.Card as Card
import SlamData.Workspace.Eval.Persistence as P

-- | Type synonym for the full type of a card component.
type CardComponent = H.Component CS.CardStateP CQ.CardQueryP Slam
type CardDSL = H.ParentDSL CS.CardState CS.AnyCardState CQ.CardQuery CQ.InnerCardQuery Slam Unit
type CardHTML = H.ParentHTML CS.AnyCardState CQ.CardQuery CQ.InnerCardQuery Slam Unit

-- | Card component factory
makeCardComponent
  ∷ ∀ s f
  . CardDef s f ()
  → CardComponent
makeCardComponent def = makeCardComponentPart def render
  where
  render
    ∷ H.Component CS.AnyCardState CQ.InnerCardQuery Slam
    → CS.AnyCardState
    → CS.CardState
    → CardHTML
  render component initialState = const $
    HH.div
      [ HP.classes $ [ CSS.deckCard ]
      , ARIA.label $ (cardName def.cardType) ⊕ " card"
      , HP.ref (H.action ∘ CQ.SetElement)
      ]
      $ fold [cardLabel, card]
    where
    cardLabel ∷ Array CardHTML
    cardLabel
      | def.cardType `elem` [PendingCard, ErrorCard, NextAction, Draftboard] = []
      | otherwise =
          [ HH.div
              [ HP.classes [CSS.cardHeader]
              ]
              [ HH.div
                  [ HP.class_ CSS.cardName ]
                  [ darkCardGlyph def.cardType
                  , HH.p_ [ HH.text $ cardName def.cardType ]
                  ]
              ]
          ]
    card ∷ Array CardHTML
    card =
      [ HH.div
          [ HP.classes $ cardClasses def.cardType ]
          [ HH.slot unit \_ → { component, initialState } ]
      ]

-- | Constructs a card component from a record with the necessary properties and
-- | a render function.
makeCardComponentPart
  ∷ ∀ s f r
  . CardDef s f r
  → (H.Component CS.AnyCardState CQ.InnerCardQuery Slam
     → CS.AnyCardState
     → CS.CardState
     → CardHTML)
  → CardComponent
makeCardComponentPart def render =
  H.lifecycleParentComponent
    { render: render component initialState
    , eval
    , peek: Nothing
    , initializer: Just (H.action CQ.Initialize)
    , finalizer: Just (H.action CQ.Finalize)
    }
  where

  displayCoord ∷ Card.DisplayCoord
  displayCoord = def.options.cursor × def.options.coord

  _State ∷ PrismP CS.AnyCardState s
  _State = clonePrism def._State

  _Query ∷ ∀ a. PrismP (CQ.InnerCardQuery a) (f a)
  _Query = clonePrism def._Query

  component ∷ H.Component CS.AnyCardState CQ.InnerCardQuery Slam
  component =
    H.transform
      (review _State) (preview _State)
      (review _Query) (preview _Query)
      def.component

  initialState ∷ CS.AnyCardState
  initialState = review _State def.initialState

  eval ∷ CQ.CardQuery ~> CardDSL
  eval = case _ of
    CQ.Initialize next → do
      cell ← H.liftH $ H.liftH $ P.getCard def.options.coord
      for_ cell \{ bus, value } → do
        queryInnerCard $ EQ.Load value.model.model
        breaker ← subscribeToBus' (H.action ∘ CQ.HandleEvalMessage) bus
        H.modify _
          { breaker = Just breaker
          , bus = Just bus
          }
      pure next
    CQ.Finalize next → do
      H.gets _.breaker >>= traverse_ (fromAff ∘ break')
      pure next
    CQ.ActivateCard next →
      queryInnerCard EQ.Activate $> next
    CQ.DeactivateCard next →
      queryInnerCard EQ.Deactivate $> next
    CQ.SetElement el next →
      H.modify (CS._element .~ el) $> next
    CQ.UpdateDimensions next → do
      H.gets _.element >>= traverse_ \el -> do
        { width, height } ← H.fromEff (getBoundingClientRect el)
        unless (width ≡ zero ∧ height ≡ zero) do
          queryInnerCard $ EQ.ReceiveDimensions { width, height }
      pure next
    CQ.HandleEvalMessage msg next → do
      case msg of
        Card.Pending evalPort → do
          queryInnerCard $ EQ.ReceiveInput evalPort
          H.modify (CS._pending .~ true)
        Card.Complete evalPort → do
          queryInnerCard $ EQ.ReceiveOutput evalPort
          H.modify (CS._pending .~ false)
        Card.StateChange evalState →
          queryInnerCard $ EQ.ReceiveState evalState
        Card.ModelChange source evalModel →
          when (source ≠ displayCoord) do
            queryInnerCard $ EQ.Load evalModel
      pure next

queryInnerCard ∷ H.Action EQ.CardEvalQuery → CardDSL Unit
queryInnerCard q =
  void $ H.query unit (left (H.action q))


Redefine range and view

Redefine range and view

module Genetics.Browser.View where

import Prelude

import Data.Array (index, (..))
import Data.Array as Array
import Data.Foldable (foldMap)
import Data.Maybe (Maybe, fromMaybe)
import Data.Monoid (mempty)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (alaF, unwrap, wrap)
import Data.Traversable (traverse)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, Point, Pos, Range)
import Graphics.Canvas (TranslateTransform, Transform)

-- type Scale r = { scale :: BpPerPixel | r }

-- type PixelsWide r = { pixels :: Number | r }

-- type ChrSize r = { chrSize :: Chr -> Number | r }

-- type View r = Range (Scale (PixelsWide r))

type Pixels = Number

-- the view is relatively abstract; containing only the end points.
-- i.e. it's not concerned with rendering, directly.
type View = { lHand :: Pos, rHand :: Pos }

-- TODO This module is probably not the best place for these functions
chrsInRange :: forall aff a r.
               Array Chr
            -> Range r
            -> (Array Chr)
chrsInRange chrs { lHand, rHand } = fromMaybe mempty do
  lI <- Array.findIndex (\x -> x.chrId == lHand.chrId) chrs
  rI <- Array.findIndex (\x -> x.chrId == rHand.chrId) chrs
  traverse (index chrs) (lI .. rI)

-- getRangeSize :: forall aff a r.
--                 Array Chr
--              -> Range r
--              -> Maybe Bp
-- getRangeSize chrs r@{ lHand, rHand } = do
--   chrs' <- chrsInRange chrs r
--   {head, tail} <- Array.uncons chrs'
--   {init, last} <- Array.unsnoc tail
--   let l = head.size - lHand.bp
--       mid = alaF Additive foldMap (_.size) init
--       r = rHand.bp
--   pure $ l + mid + r

-- we can just assume we always have all the data...
-- only special instances when that's not the case, e.g. when creating it

-- newtype View =

-- fromCanvasWidth :: forall r.
--                    Array Chr
--                 -> { lHand :: Pos, rHand :: Pos
--                    , pixelsWide :: Pixels }
--                 -> Maybe View
-- fromCanvasWidth chrs v' = do
--   totalBps <- getRangeSize chrs v'
--   let scale = wrap $ (unwrap totalBps) / v'.pixelsWide

  -- pure $ { lHand: v'.lHand, rHand: v'.rHand, pixelsWide: v'.pixelsWide, scale: scale }

browserTransform :: Number
                 -> Transform
browserTransform h = { m11: 1.0, m21:   0.0,  m31: 0.0
                     , m12: 0.0, m22: (-1.0), m32: h }

data UpdateView = ScrollBp Bp
                | ScrollPixels Number
                | SetRange (forall r. Range r)
                | ModScale (BpPerPixel -> BpPerPixel)
                | SetScale BpPerPixel

-- scaleToFit :: forall r.
--               Range (PixelsWide r)
--            -> View r
-- scaleToFit r@{ lHand, rHand, pixels } =
--   r { scale = rHand.}

-- fitToScale :: forall r.
--               Scale (PixelsWide r)
--            -> View r
-- fitToScale { scale, pixels } = ?pas

-- this should be a composition of just applying `f` then `fitToScale` or similar
modScale :: View
         -> (BpPerPixel -> BpPerPixel)
         -> View
modScale v f = v
  -- where bpsWide = v.max - v.min
  --       pixelsWide = bpToPixels v.scale bpsWide
  --       mid = v.min + ((v.max - v.min) * Bp 0.5)
  --       scale = f v.scale
  --       bpsWide' = pixelsToBp scale pixelsWide
  --       d = bpsWide' * Bp 0.5
{-
foldView :: UpdateView
         -> View
         -> View
foldView (ScrollBp x)     v = v { min = v.min + x
                                , max = v.max + x }

foldView (ScrollPixels x) v = let dx = pixelsToBp v.scale x
                              in v { min = v.min - dx
                                   , max = v.max - dx }

foldView (SetRange l r)   v = v { min = l, max = r }

foldView (ModScale f)     v = modScale v f

foldView (SetScale s)     v = modScale v (const s)

-}

module Genetics.Browser.View where

import Prelude

import Data.Array (index, (..))
import Data.Array as Array
import Data.Foldable (foldMap)
import Data.Maybe (Maybe)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (alaF, unwrap, wrap)
import Data.Traversable (traverse)
import Genetics.Browser.Types (Bp(..), BpPerPixel(..), Chr, Point, Pos, Range)
import Graphics.Canvas (TranslateTransform, Transform)

-- type Scale r = { scale :: BpPerPixel | r }

-- type PixelsWide r = { pixels :: Number | r }

-- type ChrSize r = { chrSize :: Chr -> Number | r }

-- type View r = Range (Scale (PixelsWide r))

type Pixels = Number

-- the view is relatively abstract; containing only the end points.
-- i.e. it's not concerned with rendering, directly.
type View = { lHand :: Pos, rHand :: Pos
            , scale :: BpPerPixel
            , pixelsWide :: Pixels
            }

-- TODO This module is probably not the best place for these functions
chrsInRange :: forall aff a r.
               Array Chr
            -> Range r
            -> Maybe (Array Chr)
chrsInRange chrs { lHand, rHand } = do
  lI <- Array.findIndex (\x -> x.chrId == lHand.chrId) chrs
  rI <- Array.findIndex (\x -> x.chrId == rHand.chrId) chrs
  traverse (index chrs) (lI .. rI)

getRangeSize :: forall aff a r.
                Array Chr
             -> Range r
             -> Maybe Bp
getRangeSize chrs r@{ lHand, rHand } = do
  chrs' <- chrsInRange chrs r
  {head, tail} <- Array.uncons chrs'
  {init, last} <- Array.unsnoc tail

  let l = head.size - lHand.bp
      mid = alaF Additive foldMap (_.size) init
      r = rHand.bp
  pure $ l + mid + r

-- we can just assume we always have all the data...
-- only special instances when that's not the case, e.g. when creating it

-- newtype View =

fromCanvasWidth :: forall r.
                   Array Chr
                -> { lHand :: Pos, rHand :: Pos
                   , pixelsWide :: Pixels }
                -> Maybe View
fromCanvasWidth chrs v' = do
  totalBps <- getRangeSize chrs v'
  let scale = wrap $ (unwrap totalBps) / v'.pixelsWide

  pure $ { lHand: v'.lHand, rHand: v'.rHand, pixelsWide: v'.pixelsWide, scale: scale }

browserTransform :: Number
                 -> Transform
browserTransform h = { m11: 1.0, m21:   0.0,  m31: 0.0
                     , m12: 0.0, m22: (-1.0), m32: h }

data UpdateView = ScrollBp Bp
                | ScrollPixels Number
                | SetRange (forall r. Range r)
                | ModScale (BpPerPixel -> BpPerPixel)
                | SetScale BpPerPixel

-- scaleToFit :: forall r.
--               Range (PixelsWide r)
--            -> View r
-- scaleToFit r@{ lHand, rHand, pixels } =
--   r { scale = rHand.}

-- fitToScale :: forall r.
--               Scale (PixelsWide r)
--            -> View r
-- fitToScale { scale, pixels } = ?pas

-- this should be a composition of just applying `f` then `fitToScale` or similar
modScale :: View
         -> (BpPerPixel -> BpPerPixel)
         -> View
modScale v f = v
  -- where bpsWide = v.max - v.min
  --       pixelsWide = bpToPixels v.scale bpsWide
  --       mid = v.min + ((v.max - v.min) * Bp 0.5)
  --       scale = f v.scale
  --       bpsWide' = pixelsToBp scale pixelsWide
  --       d = bpsWide' * Bp 0.5
{-
foldView :: UpdateView
         -> View
         -> View
foldView (ScrollBp x)     v = v { min = v.min + x
                                , max = v.max + x }

foldView (ScrollPixels x) v = let dx = pixelsToBp v.scale x
                              in v { min = v.min - dx
                                   , max = v.max - dx }

foldView (SetRange l r)   v = v { min = l, max = r }

foldView (ModScale f)     v = modScale v f

foldView (SetScale s)     v = modScale v (const s)

-}


Fix search and replace mistake (oops)

Fix search and replace mistake (oops)

{-
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 Halogen.Component.Utils where

import Prelude

import Control.Monad.Aff (Aff, Canceler, forkAff, later', runAff)
import Control.Monad.Aff.AVar (AVAR, AVar, makeVar, putVar, takeVar)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.EventLoop as EventLoop
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff.Class (liftEff)

import Data.Either as E
import Data.Int as Int
import Data.Time.Duration (Milliseconds(..))

import Halogen as H
import Halogen.Query.EventSource as ES

import Math as Math

withCanceler
  ∷ ∀ a eff m
  . MonadAff (avar ∷ AVAR | eff) m
  ⇒ (Canceler (avar ∷ AVAR | eff) → m Unit)
  → Aff (avar ∷ AVAR | eff) a
  → m a
withCanceler act aff = do
  v ← liftAff makeVar
  canceler ← liftAff $ forkAff do
    res ← aff
    putVar v res
  act canceler
  liftAff $ takeVar v

liftWithCanceler'
  ∷ ∀ s f g p o m a eff
  . MonadAff (avar ∷ AVAR | eff) m
  ⇒ (Canceler (avar ∷ AVAR | eff) → Unit → f Unit)
  → Aff (avar ∷ AVAR | eff) a
  → H.HalogenM s f g p o m a
liftWithCanceler' f aff = do
  withCanceler (\c → void <$> sendAfter' zero $ f c unit) aff

sendAfter'
  ∷ ∀ s f g m p eff
  . MonadAff (avar ∷ AVAR | eff) m
  ⇒ Milliseconds
  → f Unit
  → H.HalogenM s f g p o m (Canceler (avar ∷ AVAR | eff))
sendAfter' ms action = do
  cancelerVar ← H.liftAff makeVar
  H.subscribe $ oneTimeEventSource ms action cancelerVar
  H.liftAff $ takeVar cancelerVar

raise'
  ∷ ∀ s f g m p eff
  . MonadAff (avar ∷ AVAR | eff) m
  ⇒ f Unit
  → H.HalogenM s f g p o m Unit
raise' = void <$> sendAfter' (Milliseconds 0.0)

oneTimeEventSource
  ∷ ∀ f m eff
  . MonadAff (avar ∷ AVAR | eff) m
  ⇒ Milliseconds
  → f Unit
  → AVar (Canceler (avar ∷ AVAR | eff))
  → H.EventSource f m
oneTimeEventSource (Milliseconds n) action cancelerVar =
  ES.EventSource
    $ ES.produce \emit →
        void
          $ runAff (const $ pure unit) (const $ pure unit)
          $ putVar cancelerVar =<< (forkAff $ delay $ emitAndEnd emit)
  where
  delay = later' (Int.floor $ Math.max n zero)
  emitAndEnd emit = liftEff $ emit (E.Left action) *> emit (E.Right unit)

subscribeToBus'
  ∷ ∀ s f g p o m a r eff
  . MonadAff (avar ∷ AVAR | eff) m
  ⇒ (a → f Unit)
  → Bus.Bus (read ∷ Bus.Cap | r) a
  → H.HalogenM s f g p o m (EventLoop.Breaker Unit)
subscribeToBus' k bus =
  subscribeToASource' k (Bus.read bus)

subscribeToASource'
  ∷ ∀ s f g p o m a eff
  . MonadAff (avar ∷ AVAR | eff) m
  ⇒ (a → f Unit)
  → Aff (avar ∷ AVAR | eff) a
  → H.HalogenM s f g p o m (EventLoop.Breaker Unit)
subscribeToASource' k source = do
  breaker ← liftAff makeVar
  H.subscribe
    $ ES.EventSource
    $ ES.produce \emit →
        void $ runAff (const $ pure unit) (const $ pure unit) do
          loop ← EventLoop.forever do
            a ← source
            forkAff $ H.liftEff $ emit $ E.Left (k a)
          putVar breaker loop.breaker
          loop.run
  H.liftAff $ takeVar breaker

{-
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 moverning permissions and
limitations under the License.
-}

module Halogen.Component.Utils where

import Prelude

import Control.Monad.Aff (Aff, Canceler, forkAff, later', runAff)
import Control.Monad.Aff.AVar (AVAR, AVar, makeVar, putVar, takeVar)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.EventLoop as EventLoop
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff.Class (liftEff)

import Data.Either as E
import Data.Int as Int
import Data.Time.Duration (Milliseconds(..))

import Halogen as H
import Halogen.Query.EventSource as ES

import Math as Math

withCanceler
  ∷ ∀ a eff m
  . MonadAff (avar ∷ AVAR | eff) m
  ⇒ (Canceler (avar ∷ AVAR | eff) → m Unit)
  → Aff (avar ∷ AVAR | eff) a
  → m a
withCanceler act aff = do
  v ← liftAff makeVar
  canceler ← liftAff $ forkAff do
    res ← aff
    putVar v res
  act canceler
  liftAff $ takeVar v

liftWithCanceler'
  ∷ ∀ s f g p o m a eff
  . MonadAff (avar ∷ AVAR | eff) m
  ⇒ (Canceler (avar ∷ AVAR | eff) → Unit → f Unit)
  → Aff (avar ∷ AVAR | eff) a
  → H.HalogenM s f g p o m a
liftWithCanceler' f aff = do
  withCanceler (\c → void <$> sendAfter' zero $ f c unit) aff

sendAfter'
  ∷ ∀ s f g m p eff
  . MonadAff (avar ∷ AVAR | eff) m
  ⇒ Milliseconds
  → f Unit
  → H.HalogenM s f g p o m (Canceler (avar ∷ AVAR | eff))
sendAfter' ms action = do
  cancelerVar ← H.liftAff makeVar
  H.subscribe $ oneTimeEventSource ms action cancelerVar
  H.liftAff $ takeVar cancelerVar

raise'
  ∷ ∀ s f g m p eff
  . MonadAff (avar ∷ AVAR | eff) m
  ⇒ f Unit
  → H.HalogenM s f g p o m Unit
raise' = void <$> sendAfter' (Milliseconds 0.0)

oneTimeEventSource
  ∷ ∀ f m eff
  . MonadAff (avar ∷ AVAR | eff) m
  ⇒ Milliseconds
  → f Unit
  → AVar (Canceler (avar ∷ AVAR | eff))
  → H.EventSource f m
oneTimeEventSource (Milliseconds n) action cancelerVar =
  ES.EventSource
    $ ES.produce \emit →
        void
          $ runAff (const $ pure unit) (const $ pure unit)
          $ putVar cancelerVar =<< (forkAff $ delay $ emitAndEnd emit)
  where
  delay = later' (Int.floor $ Math.max n zero)
  emitAndEnd emit = liftEff $ emit (E.Left action) *> emit (E.Right unit)

subscribeToBus'
  ∷ ∀ s f g p o m a r eff
  . MonadAff (avar ∷ AVAR | eff) m
  ⇒ (a → f Unit)
  → Bus.Bus (read ∷ Bus.Cap | r) a
  → H.HalogenM s f g p o m (EventLoop.Breaker Unit)
subscribeToBus' k bus =
  subscribeToASource' k (Bus.read bus)

subscribeToASource'
  ∷ ∀ s f g p o m a eff
  . MonadAff (avar ∷ AVAR | eff) m
  ⇒ (a → f Unit)
  → Aff (avar ∷ AVAR | eff) a
  → H.HalogenM s f g p o m (EventLoop.Breaker Unit)
subscribeToASource' k source = do
  breaker ← liftAff makeVar
  H.subscribe
    $ ES.EventSource
    $ ES.produce \emit →
        void $ runAff (const $ pure unit) (const $ pure unit) do
          loop ← EventLoop.forever do
            a ← source
            forkAff $ H.liftEff $ emit $ E.Left (k a)
          putVar breaker loop.breaker
          loop.run
  H.liftAff $ takeVar breaker


Fix typo

Fix typo

module Test.Spec.GeneratorSpec (generatorSpec) where

import Prelude
import Data.Tuple (Tuple(..))
import Debug.Trace
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Control.Monad.State (State(), evalState)
import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)
import Data.List (List(..), toList, length, fromList, singleton)
import Data.Map (Map(..))
import qualified Data.Map as Map
import qualified Data.Array as A
import Data.Foldable (for_, intercalate)
import Control.Monad.Eff.Exception (error, throwException, catchException
                                   , message)
import qualified Text.Parsing.Parser as P

import Docopt
import Docopt.Spec.Parser.Usage (Usage(..))
import qualified Docopt.Spec.Parser.Usage as Usage
import qualified Docopt.Spec.Parser.Lexer as Lexer
import qualified Docopt.Spec.Parser.Scanner as Scanner
import Docopt.Gen.Parser (mkApplicationParser)
import Docopt.Gen.Lexer (lex)
import Docopt.Spec.Parser.Base (debug)

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff)

-- short hand to create a Command
co :: String -> Argument
co = Command

-- short hand to create a Positional argument
pos :: String -> Boolean -> Argument
pos = Positional

-- short hand to create a end-of-arguments marker
eoa :: Argument
eoa = EOA

-- short hand to create an Option argument
opt' :: Flag
      -> Name
      -> (Maybe OptionArgument)
      -> IsRepeatable
      -> Argument
opt' f n = Option (Just f) (Just n)

opt_ :: Flag
      -> Name
      -> Argument
opt_ f n = opt' f n Nothing false

optR_ :: Flag
      -> Name
      -> Argument
optR_ f n = opt' f n Nothing true

opt :: Flag
    -> Name
    -> OptionArgument
    -> Argument
opt f n a = opt' f n (Just a) false

optR :: Flag
     -> Name
     -> OptionArgument
     -> Argument
optR f n a = opt' f n (Just a) true

sopt :: Flag
      -> (Maybe OptionArgument)
      -> IsRepeatable
      -> Argument
sopt f = Option (Just f) Nothing

lopt :: Name
      -> (Maybe OptionArgument)
      -> IsRepeatable
      -> Argument
lopt name = Option Nothing (Just name)

-- short hand to create a group
gr :: Boolean -> IsRepeatable -> (Array (Array Argument)) -> Argument
gr b r xs = Group b (toList $ br <$> xs) r

-- short hand to create a optional group
gro :: IsRepeatable -> (Array (Array Argument)) -> Argument
gro = gr true

-- short hand to create a required group
grr :: IsRepeatable -> (Array (Array Argument)) -> Argument
grr = gr false

-- short hand to create a whole branch
br :: (Array Argument) -> Branch
br xs = Branch (toList xs)

oa :: String -> Value -> OptionArgument
oa n v = OptionArgument n (Just v)

oa_ :: String -> OptionArgument
oa_ n = OptionArgument n Nothing

type Input    = Array String
type Output   = Map Argument Value
data Test = Test (Array Argument) (Array Case)
data Case = Case Input (Either String Output)

test :: Array Argument -> Array Case -> Test
test = Test

pass :: Input -> (Array (Tuple Argument Value)) -> Case
pass i o = Case i (Right $ Map.fromList $ toList o)

fail :: Input -> String -> Case
fail i e = Case i (Left e)

(//) = Tuple

generatorSpec = describe "The generator" do

  -- Some options that will be used for these tests
  let cmd_foo          = co    "foo"
      opt_f_foo_FOZ__r = optR  'f' "foo" (oa_ "FOZ")
      opt_q_qux___r    = optR_ 'q' "qux"
      opt_b_baz        = opt   'b' "baz"   (oa "BAZ" $ StringValue "ax")
      opt_o_out        = opt_  'o' "out"
      opt_i_input      = opt_  'i' "input"
      pos_arg_r        = pos    "qux" true
      cmd_baz          = co     "baz"

  let testCases = [

      test [ pos_arg_r ]
        [ pass
            [ "a", "b", "c" ]
            [ Tuple pos_arg_r (ArrayValue [
                                StringValue "a"
                              , StringValue "b"
                              , StringValue "c"
                              ])
            ]
        , fail [ "--foo", "baz" ]
            "Expected positional argument: \"qux...\""
        , fail
            [ "a", "--foo", "-f=10" ]
            "Trailing input: --foo, -f=10"
        ]

    , test [ pos_arg_r, eoa ]
        [ pass
            [ "a", "b", "c", "--" ]
            [ Tuple pos_arg_r (ArrayValue [
                                StringValue "a"
                              , StringValue "b"
                              , StringValue "c"
                              ])
            , Tuple eoa (ArrayValue [])
            ]
        , pass
            [ "a", "b", "c", "--", "--", "--" ]
            [ Tuple pos_arg_r (ArrayValue [
                                StringValue "a"
                              , StringValue "b"
                              , StringValue "c"
                              ])
            , Tuple eoa (ArrayValue [
                          StringValue "--"
                        , StringValue "--"
                        ])
            ]
        ]

    , test
        [ grr false [] ]
        [ pass [] [] ]

    , test
        [ gro false [] ]
        [ pass [] [] ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          ]]
        ]
        [ fail [] "Missing required options: (-i, --input=FILE)"
        , pass
            [ "-i", "bar" ]
            [ opt 'i' "input" (oa_ "FILE") // (StringValue "bar") ]
        ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail [] "Missing required options: -o, --output=FILE, (-i, --input=FILE)"
        , fail [ "-i", "bar" ] "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") // (StringValue "bar")
            , opt 'o' "output" (oa_ "FILE") // (StringValue "bar") ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-i", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") // (StringValue "bar")
            , opt 'o' "output" (oa_ "FILE") // (StringValue "bar") ]
        ]

    , test
        [ grr false [[
            grr false [[
              opt 'i' "input" (oa_ "FILE")
            ]]
          , opt 'r' "redirect" (oa_ "FILE")
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail []
            "Missing required options: -o, --output=FILE, ((-i, --input=FILE) -r, --redirect=FILE)"
        , fail [ "-i", "bar", "-r", "bar" ]
            "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-r", "bar", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE")   // (StringValue "bar")
            , opt 'r' "redirect" (oa_ "FILE") // (StringValue "bar")
            , opt 'o' "output" (oa_ "FILE")   // (StringValue "bar") ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-r", "bar", "-i", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE")   // (StringValue "bar")
            , opt 'r' "redirect" (oa_ "FILE") // (StringValue "bar")
            , opt 'o' "output" (oa_ "FILE")   // (StringValue "bar") ]
        ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          , pos "env" false
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail [] "Missing required options: -i, --input=FILE"
          -- XXX: Would be cool to show the reason the group did not parse!
        , fail [ "-i", "bar" ] "Expected positional argument: \"env\""
        , pass [ "-i", "bar", "x", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") // (StringValue "bar")
            , pos "env" false               // (StringValue "x")
            , opt 'o' "output" (oa_ "FILE") // (StringValue "bar") ]
          -- group should NOT be interchangable if it contains non-options:
        , fail [ "-o", "bar", "x", "-i", "bar" ]
            "Missing required options: -i, --input=FILE"
        ]

    , test
        [ cmd_foo
        , opt_o_out
        , opt_q_qux___r
        , opt_b_baz
        , opt_i_input
        , opt_f_foo_FOZ__r
        , cmd_baz
        ]

        [ pass
            [ "foo" , "--out", "--input", "--qux", "--foo=ox", "baz" ]
            [ Tuple cmd_foo          (BoolValue true)
            , Tuple opt_o_out        (BoolValue true)
            , Tuple opt_i_input      (BoolValue true)
            , Tuple opt_q_qux___r    (ArrayValue [ BoolValue true ])
            , Tuple opt_f_foo_FOZ__r (ArrayValue [ StringValue "ox" ])
            , Tuple cmd_baz          (BoolValue true)
            -- should have added default value that was not provided above:
            , Tuple opt_b_baz        (StringValue "ax")
            ]

        , pass
            [ "foo" , "--out", "-qqq", "--foo=ox", "--baz=ax", "--input", "baz" ]
            [ Tuple cmd_foo          (BoolValue true)
            , Tuple opt_o_out        (BoolValue true)
            , Tuple opt_q_qux___r    (ArrayValue [
                                        BoolValue true
                                      , BoolValue true
                                      , BoolValue true
                                     ])
            , Tuple opt_f_foo_FOZ__r (ArrayValue [StringValue "ox"])
            , Tuple opt_b_baz        (StringValue "ax")
            , Tuple opt_i_input      (BoolValue true)
            , Tuple cmd_baz          (BoolValue true)
            ]

        , pass
            [ "foo", "-q", "-o", "--qux", "-i", "--baz=ax", "-f=ox", "baz" ]
            [ Tuple cmd_foo          (BoolValue true)
            , Tuple opt_q_qux___r    (ArrayValue [
                                        BoolValue true
                                      , BoolValue true
                                     ])
            , Tuple opt_o_out        (BoolValue true)
            , Tuple opt_i_input      (BoolValue true)
            , Tuple opt_b_baz        (StringValue "ax")
            , Tuple opt_f_foo_FOZ__r (ArrayValue [StringValue "ox"])
            , Tuple cmd_baz          (BoolValue true)
            ]

        , pass
            [ "foo", "--baz=ax", "-o", "-f=ox", "-i", "baz" ]
            [ Tuple cmd_foo          (BoolValue true)
            , Tuple opt_b_baz        (StringValue "ax")
            , Tuple opt_o_out        (BoolValue true)
            , Tuple opt_f_foo_FOZ__r (ArrayValue [StringValue "ox"])
            , Tuple opt_i_input      (BoolValue true)
            , Tuple cmd_baz          (BoolValue true)
            ]

        , pass
            [ "foo", "-o", "-i", "-bax", "baz" ]
            [ Tuple cmd_foo          (BoolValue true)
            , Tuple opt_o_out        (BoolValue true)
            , Tuple opt_i_input      (BoolValue true)
            , Tuple opt_b_baz        (StringValue "ax")
            , Tuple cmd_baz          (BoolValue true)
            -- should have added default value that was not provided above:
            , Tuple opt_b_baz        (StringValue "ax")
            ]

        , fail
            [ "foo" ]
            -- TODO: Create a more sophisticated way to test this
            $ "Missing required options: "
                ++ "-o, --out, "
                ++ "-i, --input"
        , fail
            [ "foo", "-o", "-i", "-bax" ]
            -- TODO: Create a more sophisticated way to test this
            "Expected command: \"baz\""
        ]

    , test
        [ gro false [[ cmd_foo ]] ]
        [ fail [ "goo" ] "Trailing input: \"goo\"" ]
    , test
        [ grr false [[ cmd_foo ]] ]
        [ fail [ "goo" ] "Expected command: \"foo\"" ]
  ]

  for_ testCases \(Test branch kases) -> do
    describe (prettyPrintBranch $ br branch) do
      for_ kases \(Case input expected) ->
            let msg = either
                  (\e -> "Should fail with \"" ++ e ++ "\"")
                  (\e -> prettyPrintOutput e)
                  expected
            in it (intercalate " " input ++ " -> " ++ msg) do
                  vliftEff do
                    validate branch input expected

    where

      prettyPrintOutput :: Output -> String
      prettyPrintOutput expected = ("\n\t" ++) $ intercalate "\n\t" $
                      (Map.toList expected) <#> \(Tuple arg val) ->
                        prettyPrintArg arg ++ ": " ++ prettyPrintValue val

      validate :: forall eff. Array Argument
                            -> Input
                            -> Either String Output
                            -> Eff (err :: EXCEPTION | eff) Unit
      validate args argv expected = do
        let result = do
              toks <- lex (toList argv)
              P.runParser
                (toks)
                (mkApplicationParser $ Application $ singleton $ br args)
        case result of
          Left (e@(P.ParseError { message: msg })) ->
            either
              (\e' ->
                if (msg /= e')
                  then throwException $ error $
                    "Unexpected error:\n" ++ msg
                  else return unit)
              (const $ throwException $ error $ show e)
              expected
          Right r -> do
            either
              (throwException <<< error <<< show)
              (\r' ->
                if (r /= r')
                  then throwException $ error $
                    "Unexpected output:\n"
                      ++ prettyPrintOutput r
                  else return unit)
              expected

module Test.Spec.GeneratorSpec (generatorSpec) where

import Prelude
import Data.Tuple (Tuple(..))
import Debug.Trace
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Control.Monad.State (State(), evalState)
import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)
import Data.List (List(..), toList, length, fromList, singleton)
import Data.Map (Map(..))
import qualified Data.Map as Map
import qualified Data.Array as A
import Data.Foldable (for_, intercalate)
import Control.Monad.Eff.Exception (error, throwException, catchException
                                   , message)
import qualified Text.Parsing.Parser as P

import Docopt
import Docopt.Spec.Parser.Usage (Usage(..))
import qualified Docopt.Spec.Parser.Usage as Usage
import qualified Docopt.Spec.Parser.Lexer as Lexer
import qualified Docopt.Spec.Parser.Scanner as Scanner
import Docopt.Gen.Parser (mkApplicationParser)
import Docopt.Gen.Lexer (lex)
import Docopt.Spec.Parser.Base (debug)

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff)

-- short hand to create a Command
co :: String -> Argument
co = Command

-- short hand to create a Positional argument
pos :: String -> Boolean -> Argument
pos = Positional

-- short hand to create a end-of-arguments marker
eoa :: Argument
eoa = EOA

-- short hand to create an Option argument
opt' :: Flag
      -> Name
      -> (Maybe OptionArgument)
      -> IsRepeatable
      -> Argument
opt' f n = Option (Just f) (Just n)

opt_ :: Flag
      -> Name
      -> Argument
opt_ f n = opt' f n Nothing false

optR_ :: Flag
      -> Name
      -> Argument
optR_ f n = opt' f n Nothing true

opt :: Flag
    -> Name
    -> OptionArgument
    -> Argument
opt f n a = opt' f n (Just a) false

optR :: Flag
     -> Name
     -> OptionArgument
     -> Argument
optR f n a = opt' f n (Just a) true

sopt :: Flag
      -> (Maybe OptionArgument)
      -> IsRepeatable
      -> Argument
sopt f = Option (Just f) Nothing

lopt :: Name
      -> (Maybe OptionArgument)
      -> IsRepeatable
      -> Argument
lopt name = Option Nothing (Just name)

-- short hand to create a group
gr :: Boolean -> IsRepeatable -> (Array (Array Argument)) -> Argument
gr b r xs = Group b (toList $ br <$> xs) r

-- short hand to create a optional group
gro :: IsRepeatable -> (Array (Array Argument)) -> Argument
gro = gr true

-- short hand to create a required group
grr :: IsRepeatable -> (Array (Array Argument)) -> Argument
grr = gr false

-- short hand to create a whole branch
br :: (Array Argument) -> Branch
br xs = Branch (toList xs)

oa :: String -> Value -> OptionArgument
oa n v = OptionArgument n (Just v)

oa_ :: String -> OptionArgument
oa_ n = OptionArgument n Nothing

type Input    = Array String
type Output   = Map Argument Value
data Test = Test (Array Argument) (Array Case)
data Case = Case Input (Either String Output)

test :: Array Argument -> Array Case -> Test
test = Test

pass :: Input -> (Array (Tuple Argument Value)) -> Case
pass i o = Case i (Right $ Map.fromList $ toList o)

fail :: Input -> String -> Case
fail i e = Case i (Left e)

(//) = Tuple

generatorSpec = describe "The generator" do

  -- Some options that will be used for these tests
  let cmd_foo          = co    "foo"
      opt_f_foo_FOZ__r = optR  'f' "foo" (oa_ "FOZ")
      opt_q_qux___r    = optR_ 'q' "qux"
      opt_b_baz        = opt   'b' "baz"   (oa "BAZ" $ StringValue "ax")
      opt_o_out        = opt_  'o' "out"
      opt_i_input      = opt_  'i' "input"
      pos_arg_r        = pos    "qux" true
      cmd_baz          = co     "baz"

  let testCases = [

      test [ pos_arg_r ]
        [ pass
            [ "a", "b", "c" ]
            [ Tuple pos_arg_r (ArrayValue [
                                StringValue "a"
                              , StringValue "b"
                              , StringValue "c"
                              ])
            ]
        , fail [ "--foo", "baz" ]
            "Expected positional argument \"qux...\""
        , fail
            [ "a", "--foo", "-f=10" ]
            "Trailing input: --foo, -f=10"
        ]

    , test [ pos_arg_r, eoa ]
        [ pass
            [ "a", "b", "c", "--" ]
            [ Tuple pos_arg_r (ArrayValue [
                                StringValue "a"
                              , StringValue "b"
                              , StringValue "c"
                              ])
            , Tuple eoa (ArrayValue [])
            ]
        , pass
            [ "a", "b", "c", "--", "--", "--" ]
            [ Tuple pos_arg_r (ArrayValue [
                                StringValue "a"
                              , StringValue "b"
                              , StringValue "c"
                              ])
            , Tuple eoa (ArrayValue [
                          StringValue "--"
                        , StringValue "--"
                        ])
            ]
        ]

    , test
        [ grr false [] ]
        [ pass [] [] ]

    , test
        [ gro false [] ]
        [ pass [] [] ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          ]]
        ]
        [ fail [] "Missing required options: (-i, --input=FILE)"
        , pass
            [ "-i", "bar" ]
            [ opt 'i' "input" (oa_ "FILE") // (StringValue "bar") ]
        ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail [] "Missing required options: -o, --output=FILE, (-i, --input=FILE)"
        , fail [ "-i", "bar" ] "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") // (StringValue "bar")
            , opt 'o' "output" (oa_ "FILE") // (StringValue "bar") ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-i", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") // (StringValue "bar")
            , opt 'o' "output" (oa_ "FILE") // (StringValue "bar") ]
        ]

    , test
        [ grr false [[
            grr false [[
              opt 'i' "input" (oa_ "FILE")
            ]]
          , opt 'r' "redirect" (oa_ "FILE")
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail []
            "Missing required options: -o, --output=FILE, ((-i, --input=FILE) -r, --redirect=FILE)"
        , fail [ "-i", "bar", "-r", "bar" ]
            "Missing required options: -o, --output=FILE"
        , pass [ "-i", "bar", "-r", "bar", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE")   // (StringValue "bar")
            , opt 'r' "redirect" (oa_ "FILE") // (StringValue "bar")
            , opt 'o' "output" (oa_ "FILE")   // (StringValue "bar") ]
          -- group should be interchangable if it's only of options:
        , pass [ "-o", "bar", "-r", "bar", "-i", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE")   // (StringValue "bar")
            , opt 'r' "redirect" (oa_ "FILE") // (StringValue "bar")
            , opt 'o' "output" (oa_ "FILE")   // (StringValue "bar") ]
        ]

    , test
        [ grr false [[
            opt 'i' "input" (oa_ "FILE")
          , pos "env" false
          ]]
        , opt 'o' "output" (oa_ "FILE")
        ]
        [ fail [] "Missing required options: -i, --input=FILE"
          -- XXX: Would be cool to show the reason the group did not parse!
        , fail [ "-i", "bar" ] "Expected positional argument: \"env\""
        , pass [ "-i", "bar", "x", "-o", "bar" ]
            [ opt 'i' "input"  (oa_ "FILE") // (StringValue "bar")
            , pos "env" false               // (StringValue "x")
            , opt 'o' "output" (oa_ "FILE") // (StringValue "bar") ]
          -- group should NOT be interchangable if it contains non-options:
        , fail [ "-o", "bar", "x", "-i", "bar" ]
            "Missing required options: -i, --input=FILE"
        ]

    , test
        [ cmd_foo
        , opt_o_out
        , opt_q_qux___r
        , opt_b_baz
        , opt_i_input
        , opt_f_foo_FOZ__r
        , cmd_baz
        ]

        [ pass
            [ "foo" , "--out", "--input", "--qux", "--foo=ox", "baz" ]
            [ Tuple cmd_foo          (BoolValue true)
            , Tuple opt_o_out        (BoolValue true)
            , Tuple opt_i_input      (BoolValue true)
            , Tuple opt_q_qux___r    (ArrayValue [ BoolValue true ])
            , Tuple opt_f_foo_FOZ__r (ArrayValue [ StringValue "ox" ])
            , Tuple cmd_baz          (BoolValue true)
            -- should have added default value that was not provided above:
            , Tuple opt_b_baz        (StringValue "ax")
            ]

        , pass
            [ "foo" , "--out", "-qqq", "--foo=ox", "--baz=ax", "--input", "baz" ]
            [ Tuple cmd_foo          (BoolValue true)
            , Tuple opt_o_out        (BoolValue true)
            , Tuple opt_q_qux___r    (ArrayValue [
                                        BoolValue true
                                      , BoolValue true
                                      , BoolValue true
                                     ])
            , Tuple opt_f_foo_FOZ__r (ArrayValue [StringValue "ox"])
            , Tuple opt_b_baz        (StringValue "ax")
            , Tuple opt_i_input      (BoolValue true)
            , Tuple cmd_baz          (BoolValue true)
            ]

        , pass
            [ "foo", "-q", "-o", "--qux", "-i", "--baz=ax", "-f=ox", "baz" ]
            [ Tuple cmd_foo          (BoolValue true)
            , Tuple opt_q_qux___r    (ArrayValue [
                                        BoolValue true
                                      , BoolValue true
                                     ])
            , Tuple opt_o_out        (BoolValue true)
            , Tuple opt_i_input      (BoolValue true)
            , Tuple opt_b_baz        (StringValue "ax")
            , Tuple opt_f_foo_FOZ__r (ArrayValue [StringValue "ox"])
            , Tuple cmd_baz          (BoolValue true)
            ]

        , pass
            [ "foo", "--baz=ax", "-o", "-f=ox", "-i", "baz" ]
            [ Tuple cmd_foo          (BoolValue true)
            , Tuple opt_b_baz        (StringValue "ax")
            , Tuple opt_o_out        (BoolValue true)
            , Tuple opt_f_foo_FOZ__r (ArrayValue [StringValue "ox"])
            , Tuple opt_i_input      (BoolValue true)
            , Tuple cmd_baz          (BoolValue true)
            ]

        , pass
            [ "foo", "-o", "-i", "-bax", "baz" ]
            [ Tuple cmd_foo          (BoolValue true)
            , Tuple opt_o_out        (BoolValue true)
            , Tuple opt_i_input      (BoolValue true)
            , Tuple opt_b_baz        (StringValue "ax")
            , Tuple cmd_baz          (BoolValue true)
            -- should have added default value that was not provided above:
            , Tuple opt_b_baz        (StringValue "ax")
            ]

        , fail
            [ "foo" ]
            -- TODO: Create a more sophisticated way to test this
            $ "Missing required options: "
                ++ "-o, --out, "
                ++ "-i, --input"
        , fail
            [ "foo", "-o", "-i", "-bax" ]
            -- TODO: Create a more sophisticated way to test this
            "Expected command: \"baz\""
        ]

    , test
        [ gro false [[ cmd_foo ]] ]
        [ fail [ "goo" ] "Trailing input: \"goo\"" ]
    , test
        [ grr false [[ cmd_foo ]] ]
        [ fail [ "goo" ] "Expected command: \"foo\"" ]
  ]

  for_ testCases \(Test branch kases) -> do
    describe (prettyPrintBranch $ br branch) do
      for_ kases \(Case input expected) ->
            let msg = either
                  (\e -> "Should fail with \"" ++ e ++ "\"")
                  (\e -> prettyPrintOutput e)
                  expected
            in it (intercalate " " input ++ " -> " ++ msg) do
                  vliftEff do
                    validate branch input expected

    where

      prettyPrintOutput :: Output -> String
      prettyPrintOutput expected = ("\n\t" ++) $ intercalate "\n\t" $
                      (Map.toList expected) <#> \(Tuple arg val) ->
                        prettyPrintArg arg ++ ": " ++ prettyPrintValue val

      validate :: forall eff. Array Argument
                            -> Input
                            -> Either String Output
                            -> Eff (err :: EXCEPTION | eff) Unit
      validate args argv expected = do
        let result = do
              toks <- lex (toList argv)
              P.runParser
                (toks)
                (mkApplicationParser $ Application $ singleton $ br args)
        case result of
          Left (e@(P.ParseError { message: msg })) ->
            either
              (\e' ->
                if (msg /= e')
                  then throwException $ error $
                    "Unexpected error:\n" ++ msg
                  else return unit)
              (const $ throwException $ error $ show e)
              expected
          Right r -> do
            either
              (throwException <<< error <<< show)
              (\r' ->
                if (r /= r')
                  then throwException $ error $
                    "Unexpected output:\n"
                      ++ prettyPrintOutput r
                  else return unit)
              expected