Fix usage parser consuming too much

Fix usage parser consuming too much

module Language.Docopt.Parser.Usage (
    usageParser
  , run
  , parse
  , module U
  ) where

import Prelude
import Debug.Trace
import Control.Lazy (defer)
import Control.MonadPlus (guard)
import Control.Monad.Trans (lift)
import Control.Monad.State (get)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Data.Foldable (intercalate)
import Data.List (List(..), many, some, (:), toList, concat, singleton
                  , modifyAt, length)
import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P
import Data.List as L
import Data.String (fromChar)
import Data.String as Str
import Data.Either (Either(..))
import Data.Tuple (Tuple(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Array as A
import Control.Bind ((=<<))

import Language.Docopt.Parser.Base
import Language.Docopt.Parser.Common
import Language.Docopt.Parser.State
import Language.Docopt.Parser.Usage.Usage
import Language.Docopt.Parser.Usage.Argument
import Language.Docopt.Parser.Usage.Usage  as U
import Language.Docopt.Parser.Lexer        as L
import Language.Docopt.Parser.Usage.Option as O

-- | L.TokenParser to parse the usage section
-- |
-- | This parser is tricky because it has to solve the following problems:
-- |    * What is the program name?
-- |    * Disambiguate between a usage and random text.
-- |    * Disambiguate between a usage and a line-wrapped usage.
-- |
-- | Hence, the following approach is employed:
-- |    * The parser expects a valid program name as first token
-- |    * The parser marks the indent of the first program name
-- |    * Tokens past the identation mark are considered to be part of the
-- |      previous usage pattern.
-- |    * Tokens before the identation mark are NOT considered interesting and
-- |      are IGNORED.
-- |    * A token at the identation mark starts a new usage pattern parse.
-- |
usageParser :: L.TokenParser (List Usage)
usageParser = do

  -- Calculate and mark the original program indentation.
  name <- program
  col' <- getCol
  let startCol = col' - (Str.length name) - 1
  markIndent' startCol $ do
    Cons
    <$> (usageLine name)
    <*> many do
          P.try do
            program
            usageLine name

  where

    usageLine :: String -> L.TokenParser Usage
    usageLine name = Usage name <$> do
      xs <- (many $ P.try $ moreIndented *> elem) `P.sepBy1` L.vbar
      eoa <- P.choice [
        P.try $ do
          moreIndented *> L.doubleDash
          return $ Just EOA
      , (do
          L.eof <|> (P.lookAhead $ lessIndented <|> sameIndent)
          return Nothing
        )
        -- XXX: We could show the last token that failed to be consumed, here
        P.<?> "start of next usage line or end of usage section"
      ]

      -- Push the EOA onto the last branch (the most right branch)
      return $ maybe xs id do
        e <- eoa
        modifyAt
          (length xs - 1)
          (\as -> as ++ (singleton e))
          xs

    elem :: L.TokenParser Argument
    elem = defer \_ -> do
      P.choice $ P.try <$>
        [ option
        , positional
        , command
        , group
        , reference
        , stdin
        ] P.<?> "Option, Positional, Command, Group or Reference"

    stdin :: L.TokenParser Argument
    stdin = L.dash *> return Stdin

    longOption :: L.TokenParser Argument
    longOption = Option <$> do
      { name: name, arg: arg } <- L.lopt
      O.lopt' name arg <$> repetition

    shortOption :: L.TokenParser Argument
    shortOption = OptionStack <$> do
      { flag: flag, stack: stack, arg: arg } <- L.sopt
      O.sopt' flag stack arg <$> repetition

    option :: L.TokenParser Argument
    option = longOption <|> shortOption

    reference :: L.TokenParser Argument
    reference = Reference <$> L.reference

    positional :: L.TokenParser Argument
    positional = Positional
      <$> (L.angleName <|> L.shoutName)
      <*> repetition

    command :: L.TokenParser Argument
    command = do
      cmd <- Command <$> L.name
      P.notFollowedBy L.tripleDot -- Commands may not repeat!
      pure cmd

    group :: L.TokenParser Argument
    group = defer \_ -> P.choice
      [ reqGroup
      , optGroup ]

    optGroup :: L.TokenParser Argument
    optGroup = defer \_ -> Group true
      <$> (P.between
            (indented *> L.lsquare)
            (L.rsquare)
            ((some elem) `P.sepBy1` L.vbar))
      <*> repetition

    reqGroup :: L.TokenParser Argument
    reqGroup = defer \_ -> Group false
      <$> (P.between
            (indented *> L.lparen)
            (L.rparen)
            ((some elem) `P.sepBy1` L.vbar))
      <*> repetition

    repetition :: L.TokenParser Boolean
    repetition = P.choice
      [ P.try $ indented *> L.tripleDot *> pure true
      , pure false ]

    program :: L.TokenParser String
    program = (L.name <|> L.word) P.<?> "Program Name"

parse :: (List L.PositionedToken) -> Either P.ParseError (List Usage)
parse = flip L.runTokenParser usageParser

run :: String -> Either P.ParseError (List Usage)
run x = parse =<< L.lexUsage x

module Language.Docopt.Parser.Usage (
    usageParser
  , run
  , parse
  , module U
  ) where

import Prelude
import Debug.Trace
import Control.Lazy (defer)
import Control.MonadPlus (guard)
import Control.Monad.Trans (lift)
import Control.Monad.State (get)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Data.Foldable (intercalate)
import Data.List (List(..), many, some, (:), toList, concat, singleton
                  , modifyAt, length)
import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P
import Data.List as L
import Data.String (fromChar)
import Data.String as Str
import Data.Either (Either(..))
import Data.Tuple (Tuple(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Array as A
import Control.Bind ((=<<))

import Language.Docopt.Parser.Base
import Language.Docopt.Parser.Common
import Language.Docopt.Parser.State
import Language.Docopt.Parser.Usage.Usage
import Language.Docopt.Parser.Usage.Argument
import Language.Docopt.Parser.Usage.Usage  as U
import Language.Docopt.Parser.Lexer        as L
import Language.Docopt.Parser.Usage.Option as O

-- | L.TokenParser to parse the usage section
-- |
-- | This parser is tricky because it has to solve the following problems:
-- |    * What is the program name?
-- |    * Disambiguate between a usage and random text.
-- |    * Disambiguate between a usage and a line-wrapped usage.
-- |
-- | Hence, the following approach is employed:
-- |    * The parser expects a valid program name as first token
-- |    * The parser marks the indent of the first program name
-- |    * Tokens past the identation mark are considered to be part of the
-- |      previous usage pattern.
-- |    * Tokens before the identation mark are NOT considered interesting and
-- |      are IGNORED.
-- |    * A token at the identation mark starts a new usage pattern parse.
-- |
usageParser :: L.TokenParser (List Usage)
usageParser = do

  -- Calculate and mark the original program indentation.
  name <- program
  col' <- getCol
  let startCol = col' - (Str.length name) - 1
  markIndent' startCol $ do
    Cons
    <$> (usageLine name)
    <*> many do program *> usageLine name

  where

    usageLine :: String -> L.TokenParser Usage
    usageLine name = Usage name <$> do
      xs  <- (many $ moreIndented *> elem) `P.sepBy1` L.vbar
      eoa <- P.choice [
        P.try $ do
          moreIndented *> L.doubleDash
          return $ Just EOA
      , (do
          L.eof <|> (P.lookAhead $ lessIndented <|> sameIndent)
          return Nothing
        )
        -- XXX: We could show the last token that failed to be consumed, here
        P.<?> "start of next usage line or end of usage section"
      ]

      -- Push the EOA onto the last branch (the most right branch)
      return $ maybe xs id do
        e <- eoa
        modifyAt
          (length xs - 1)
          (\as -> as ++ (singleton e))
          xs

    elem :: L.TokenParser Argument
    elem = defer \_ -> do
      P.choice $ P.try <$>
        [ option
        , positional
        , command
        , group
        , reference
        , stdin
        ] P.<?> "Option, Positional, Command, Group or Reference"

    stdin :: L.TokenParser Argument
    stdin = L.dash *> return Stdin

    longOption :: L.TokenParser Argument
    longOption = Option <$> do
      { name: name, arg: arg } <- L.lopt
      O.lopt' name arg <$> repetition

    shortOption :: L.TokenParser Argument
    shortOption = OptionStack <$> do
      { flag: flag, stack: stack, arg: arg } <- L.sopt
      O.sopt' flag stack arg <$> repetition

    option :: L.TokenParser Argument
    option = longOption <|> shortOption

    reference :: L.TokenParser Argument
    reference = Reference <$> L.reference

    positional :: L.TokenParser Argument
    positional = Positional
      <$> (L.angleName <|> L.shoutName)
      <*> repetition

    command :: L.TokenParser Argument
    command = do
      cmd <- Command <$> L.name
      P.notFollowedBy L.tripleDot -- Commands may not repeat!
      pure cmd

    group :: L.TokenParser Argument
    group = defer \_ -> P.choice
      [ reqGroup
      , optGroup ]

    optGroup :: L.TokenParser Argument
    optGroup = defer \_ -> Group true
      <$> (P.between
            (indented *> L.lsquare)
            (L.rsquare)
            ((some elem) `P.sepBy1` L.vbar))
      <*> repetition

    reqGroup :: L.TokenParser Argument
    reqGroup = defer \_ -> Group false
      <$> (P.between
            (indented *> L.lparen)
            (L.rparen)
            ((some elem) `P.sepBy1` L.vbar))
      <*> repetition

    repetition :: L.TokenParser Boolean
    repetition = P.choice
      [ P.try $ indented *> L.tripleDot *> pure true
      , pure false ]

    program :: L.TokenParser String
    program = (L.name <|> L.word) P.<?> "Program Name"

parse :: (List L.PositionedToken) -> Either P.ParseError (List Usage)
parse = flip L.runTokenParser usageParser

run :: String -> Either P.ParseError (List Usage)
run x = parse =<< L.lexUsage x


Uncomment tests

Uncomment tests

module Test.Main where

import Prelude

import Control.Monad.Aff (Aff, launchAff)
import Test.Spec.Runner (run)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.ScannerSpec (scannerSpec)
import Test.Spec.UsageParserSpec (usageParserSpec)
import Test.Spec.DescParserSpec (descParserSpec)
import Test.Spec.ArgParserSpec (argParserSpec)
import Test.Spec.ForeignSpec (foreignSpec)
import Test.Spec.SolveSpec (solveSpec)
import Test.Spec.CompatSpec (compatSpec)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff (Eff())
import Node.FS (FS())
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Console (CONSOLE)
import Node.Process (PROCESS)
import Test.Assert (ASSERT)
import Test.Support.CompatParser

-- Somehow, purescript needs this:
_liftEff :: ∀ e a. Eff e a -> Aff e a
_liftEff = liftEff

main :: Eff ( err     :: EXCEPTION
            , process :: PROCESS
            , fs      :: FS
            , console :: CONSOLE
            , assert  :: ASSERT
            | _
            ) _
main = launchAff do
  tests <- _liftEff $ readTests "testcases.docopt"
  liftEff $ run [consoleReporter] do
    scannerSpec     unit
    usageParserSpec unit
    descParserSpec  unit
    solveSpec       unit
    argParserSpec   unit
    foreignSpec     tests
    compatSpec      tests

module Test.Main where

import Prelude

import Control.Monad.Aff (Aff, launchAff)
import Test.Spec.Runner (run)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.ScannerSpec (scannerSpec)
import Test.Spec.UsageParserSpec (usageParserSpec)
import Test.Spec.DescParserSpec (descParserSpec)
import Test.Spec.ArgParserSpec (argParserSpec)
import Test.Spec.ForeignSpec (foreignSpec)
import Test.Spec.SolveSpec (solveSpec)
import Test.Spec.CompatSpec (compatSpec)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff (Eff())
import Node.FS (FS())
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Console (CONSOLE)
import Node.Process (PROCESS)
import Test.Assert (ASSERT)
import Test.Support.CompatParser

-- Somehow, purescript needs this:
_liftEff :: ∀ e a. Eff e a -> Aff e a
_liftEff = liftEff

main :: Eff ( err     :: EXCEPTION
            , process :: PROCESS
            , fs      :: FS
            , console :: CONSOLE
            , assert  :: ASSERT
            | _
            ) _
main = launchAff do
  tests <- _liftEff $ readTests "testcases.docopt"
  liftEff $ run [consoleReporter] do
    -- scannerSpec     unit
    -- usageParserSpec unit
    -- descParserSpec  unit
    -- solveSpec       unit
    -- argParserSpec   unit
    -- foreignSpec     tests
    compatSpec      tests


No need to bother with strict lists.

No need to bother with strict lists.

module Test.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (EXCEPTION(), throwException, error)
import Control.Monad.MonadFix
import Data.Fix
import Data.Lazy
import Data.List.Lazy
import Data.Maybe
import Data.Tuple
import Prelude

--

newtype Maybel a = Maybel (Lazy (Maybe a))

instance maybelApplicative :: Applicative Maybel where
  pure a = Maybel (defer \_ -> Just a)

instance maybelBind :: Bind Maybel where
  bind (Maybel aM) a2bM =
    Maybel (defer \_ ->
            force aM >>= \a -> case a2bM a of Maybel bM -> force bM)

instance maybelFunctor :: Functor Maybel where
  map = liftM1

instance maybelApply :: Apply Maybel where
  apply = ap

instance maybelMonad :: Monad Maybel

instance maybelLiftFix :: MonadFix Maybel where
  liftFix xF =
    Maybel (do x <- liftFix xF
               pure (pure x))

--

oneTwoThrees :: Maybel (List Int)
oneTwoThrees = do
  Tuple xs _ <-
    mfix \(Tuple xs (Tuple ys zs)) -> do
      xs <- pure (cons 1 ys)
      ys <- pure (cons 2 zs)
      zs <- pure (cons 3 xs)
      pure (Tuple xs (Tuple ys zs))
  pure xs

testEq :: forall a e. (Eq a) => a -> a -> Eff (err :: EXCEPTION | e) Unit
testEq actual expected =
  if actual == expected
    then pure unit
    else throwException $ error $ "Invalid result"

takeAsArray :: forall a. Int -> List a -> Array a
takeAsArray n xs = fromList (take n xs)

main = do
  xs <- fix \xs -> cons 1 xs
  testEq (takeAsArray 5 xs) [1, 1, 1, 1, 1]

  case force (case oneTwoThrees of Maybel x -> x) of
    Just xs -> testEq (takeAsArray 5 xs) [1, 2, 3, 1, 2]
    Nothing -> throwException $ error $ "Got nothing"

module Test.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (EXCEPTION(), throwException, error)
import Control.Monad.MonadFix
import Data.Fix
import Data.Lazy
import qualified Data.List as S
import qualified Data.List.Lazy as L
import Data.Maybe
import Data.Tuple
import Prelude

--

newtype Maybel a = Maybel (Lazy (Maybe a))

instance maybelApplicative :: Applicative Maybel where
  pure a = Maybel (defer \_ -> Just a)

instance maybelBind :: Bind Maybel where
  bind (Maybel aM) a2bM =
    Maybel (defer \_ ->
            force aM >>= \a -> case a2bM a of Maybel bM -> force bM)

instance maybelFunctor :: Functor Maybel where
  map = liftM1

instance maybelApply :: Apply Maybel where
  apply = ap

instance maybelMonad :: Monad Maybel

instance maybelLiftFix :: MonadFix Maybel where
  liftFix xF =
    Maybel (do x <- liftFix xF
               pure (pure x))

--

oneTwoThrees :: Maybel (L.List Int)
oneTwoThrees = do
  Tuple xs _ <-
    mfix \(Tuple xs (Tuple ys zs)) -> do
      xs <- pure (L.cons 1 ys)
      ys <- pure (L.cons 2 zs)
      zs <- pure (L.cons 3 xs)
      pure (Tuple xs (Tuple ys zs))
  pure xs

testEq :: forall a e. (Eq a) => a -> a -> Eff (err :: EXCEPTION | e) Unit
testEq actual expected =
  if actual == expected
    then pure unit
    else throwException $ error $ "Invalid result"

takeAsStrict :: forall a. Int -> L.List a -> S.List a
takeAsStrict n xs = L.fromList (L.take n xs)

main = do
  xs <- fix \xs -> L.cons 1 xs
  testEq (takeAsStrict 5 xs) (S.Cons 1 (S.Cons 1 (S.Cons 1 (S.Cons 1 (S.Cons 1 S.Nil)))))

  case force (case oneTwoThrees of Maybel x -> x) of
    Just xs -> testEq (takeAsStrict 5 xs) (S.Cons 1 (S.Cons 2 (S.Cons 3 (S.Cons 1 (S.Cons 2 S.Nil)))))
    Nothing -> throwException $ error $ "Got nothing"


More variety, add comments

More variety, add comments

-- | This module re-exports the types for the `HTML` DSL, and values for all
-- | supported HTML elements.
module Halogen.HTML
  ( ComponentHTML'
  , ComponentHTML
  , PlainHTML
  , fromPlainHTML
  , slot
  , memoized
  , module Halogen.HTML.Core
  , module Halogen.HTML.Elements
  , module Halogen.HTML.Properties
  ) where

import Halogen.HTML.Elements

import Data.Function.Uncurried as Fn
import Data.Maybe (Maybe)
import Data.Symbol (class IsSymbol, SProxy)
import Halogen.Component (Component, ComponentSlot(..), componentSlot)
import Halogen.Data.Slot (Slot)
import Halogen.HTML.Core (class IsProp, AttrName(..), ClassName(..), HTML(..), Namespace(..), PropName(..), ElemName(..), text, handler)
import Halogen.HTML.Core as Core
import Halogen.HTML.Properties (IProp, attr, attrNS, prop)
import Halogen.VDom.Thunk (thunk1, thunk2, thunk3, thunked)
import Prelude (class Ord, Unit, Void)
import Prim.Row as Row
import Unsafe.Coerce (unsafeCoerce)

-- | A convenience synonym for the output type of a `render` function, for a
-- | component that renders HTML, for a component constructed with the
-- | `component` smart constructor.
type ComponentHTML f ps m = ComponentHTML' (f Unit) ps m

-- | A convenience synonym for the output type of a `render` function, for a
-- | component that renders HTML.
-- |
-- | This type is more flexible than `ComponentHTML` as it allows for
-- | non-query-algebra actions to be raised from the HTML (kind `Type` rather
-- | than `Type -> Type`).
type ComponentHTML' act ps m = HTML (ComponentSlot HTML ps m act) act

-- | A type useful for a chunk of HTML with no slot-embedding or query-raising.
-- |
-- | Often a polymorphic usage of `HTML` is good enough for this, but sometimes
-- | it's useful to have a type like this (and accompanying coercion) when doing
-- | things like creating components that accept a chunk of HTML as part of
-- | their configuration.
type PlainHTML = HTML Void Void

-- | Relaxes the type of `PlainHTML` to make it compatible with all `HTML`.
fromPlainHTML :: forall p i. PlainHTML -> HTML p i
fromPlainHTML = unsafeCoerce -- ≅ bimap absurd absurd

-- | Defines a slot for a child component. Takes:
-- | - the slot address label
-- | - the slot address index
-- | - the component for the slot
-- | - the input value to pass to the component
-- | - a function mapping outputs from the component to a query in the parent
slot
  :: forall sym px ps f i o p m act
   . Row.Cons sym (Slot f o p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> p
  -> Component HTML f i o m
  -> i
  -> (o -> Maybe act)
  -> ComponentHTML' act ps m
slot sym p component input outputQuery =
  Core.slot (ComponentSlot (componentSlot sym p component input outputQuery))

-- | Optimizes rendering of a subtree given an equality predicate. If an argument
-- | is deemed equivalent to the previous value, rendering and diffing will be
-- | skipped. You should not use this function fully saturated, but instead
-- | partially apply it for use within a Component's scope. For example, to skip
-- | rendering for equal states, just wrap your `render` function.
-- |
-- | ```purescript
-- | myComponent = component
-- |  { render: memoized eq render
-- |  , ...
-- |  }
-- | ```
memoized
  :: forall a act ps m
   . (a -> a -> Boolean)
  -> (a -> ComponentHTML' act ps m)
  -> a
  -> ComponentHTML' act ps m
memoized eqFn f a = Core.slot (ThunkSlot (thunked eqFn f a))

-- | Skips rendering for referentially equal arguments. You should not use this
-- | function fully saturated, but instead partially apply it for use within a
-- | Component's scope.
lazy
  :: forall a act ps m
   . (a -> ComponentHTML' act ps m)
  -> a
  -> ComponentHTML' act ps m
lazy f a = Core.slot (ThunkSlot (Fn.runFn2 thunk1 f a))

-- | Like `lazy`, but for a rendering function which takes 2 arguments.
lazy2
  :: forall a b act ps m
   . (a -> b -> ComponentHTML' act ps m)
  -> a
  -> b
  -> ComponentHTML' act ps m
lazy2 f a b = Core.slot (ThunkSlot (Fn.runFn3 thunk2 f a b))

-- | Like `lazy`, but for a rendering function which takes 3 arguments.
lazy3
  :: forall a b c act ps m
   . (a -> b -> c -> ComponentHTML' act ps m)
  -> a
  -> b
  -> c
  -> ComponentHTML' act ps m
lazy3 f a b c = Core.slot (ThunkSlot (Fn.runFn4 thunk3 f a b c))

-- | This module re-exports the types for the `HTML` DSL, and values for all
-- | supported HTML elements.
module Halogen.HTML
  ( ComponentHTML'
  , ComponentHTML
  , PlainHTML
  , fromPlainHTML
  , slot
  , memoized
  , module Halogen.HTML.Core
  , module Halogen.HTML.Elements
  , module Halogen.HTML.Properties
  ) where

import Halogen.HTML.Elements

import Data.Maybe (Maybe)
import Data.Symbol (class IsSymbol, SProxy)
import Halogen.Component (Component, ComponentSlot(..), componentSlot)
import Halogen.Data.Slot (Slot)
import Halogen.HTML.Core (class IsProp, AttrName(..), ClassName(..), HTML(..), Namespace(..), PropName(..), ElemName(..), text, handler)
import Halogen.HTML.Core as Core
import Halogen.HTML.Properties (IProp, attr, attrNS, prop)
import Halogen.VDom.Thunk (thunked)
import Prelude (class Ord, Unit, Void)
import Prim.Row as Row
import Unsafe.Coerce (unsafeCoerce)

-- | A convenience synonym for the output type of a `render` function, for a
-- | component that renders HTML, for a component constructed with the
-- | `component` smart constructor.
type ComponentHTML f ps m = ComponentHTML' (f Unit) ps m

-- | A convenience synonym for the output type of a `render` function, for a
-- | component that renders HTML.
-- |
-- | This type is more flexible than `ComponentHTML` as it allows for
-- | non-query-algebra actions to be raised from the HTML (kind `Type` rather
-- | than `Type -> Type`).
type ComponentHTML' act ps m = HTML (ComponentSlot HTML ps m act) act

-- | A type useful for a chunk of HTML with no slot-embedding or query-raising.
-- |
-- | Often a polymorphic usage of `HTML` is good enough for this, but sometimes
-- | it's useful to have a type like this (and accompanying coercion) when doing
-- | things like creating components that accept a chunk of HTML as part of
-- | their configuration.
type PlainHTML = HTML Void Void

-- | Relaxes the type of `PlainHTML` to make it compatible with all `HTML`.
fromPlainHTML :: forall p i. PlainHTML -> HTML p i
fromPlainHTML = unsafeCoerce -- ≅ bimap absurd absurd

-- | Defines a slot for a child component. Takes:
-- | - the slot address label
-- | - the slot address index
-- | - the component for the slot
-- | - the input value to pass to the component
-- | - a function mapping outputs from the component to a query in the parent
slot
  :: forall sym px ps f i o p m act
   . Row.Cons sym (Slot f o p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> p
  -> Component HTML f i o m
  -> i
  -> (o -> Maybe act)
  -> ComponentHTML' act ps m
slot sym p component input outputQuery =
  Core.slot (ComponentSlot (componentSlot sym p component input outputQuery))

memoized
  :: forall a act ps m
   . (a -> a -> Boolean)
  -> (a -> ComponentHTML' act ps m)
  -> a
  -> ComponentHTML' act ps m
memoized eqFn f a = Core.slot (ThunkSlot (thunked eqFn f a))


Fix #34

Fix #34

module Language.PureScript.Parser.Lexer where

import Data.Array ()
import Data.Either
import Data.String
import qualified Data.String.Regex as Rx

import Global (readInt, readFloat)

import Language.PureScript.Keywords (opCharsString)

data Token
  = LParen
  | RParen
  | LBrace
  | RBrace
  | LAngle
  | RAngle
  | LSquare
  | RSquare

  | Newline Indentation
  | ShouldIndent Indentation

  | LArrow
  | RArrow
  | LFatArrow
  | RFatArrow

  | Colon
  | DoubleColon
  | Equals
  | Pipe
  | Tick
  | Dot
  | Comma
  | Semi
  | At

  | LName String
  | UName String
  | Symbol String

  | StringLiteral String

  | Natural Number
  | ANumber Number

instance showToken :: Show Token where
  show LParen                = "LParen"
  show RParen                = "RParen"
  show LBrace                = "LBrace"
  show RBrace                = "RBrace"
  show LAngle                = "LAngle"
  show RAngle                = "RAngle"
  show LSquare               = "LSquare"
  show RSquare               = "RSquare"
  show LArrow                = "LArrow"
  show RArrow                = "RArrow"
  show LFatArrow             = "LFatArrow"
  show RFatArrow             = "RFatArrow"
  show Colon                 = "Colon"
  show DoubleColon           = "DoubleColon"
  show Equals                = "Equals"
  show Pipe                  = "Pipe"
  show Tick                  = "Tick"
  show Dot                   = "Dot"
  show Comma                 = "Comma"
  show Semi                  = "Semi"
  show At                    = "At"
  show (Newline n)           = "Newline (" ++ show n ++ ")"
  show (ShouldIndent n)      = "ShouldIndent (" ++ show n ++ ")"
  show (LName s)             = "LName (" ++ show s ++ ")"
  show (UName s)             = "UName (" ++ show s ++ ")"
  show (Symbol s)            = "Symbol (" ++ show s ++ ")"
  show (StringLiteral s)     = "StringLiteral (" ++ show s ++ ")"
  show (Natural n)           = "Natural (" ++ show n ++ ")"
  show (ANumber n)           = "ANumber (" ++ show n ++ ")"

instance eqToken :: Eq Token where
  (==) LParen              LParen              = true
  (==) RParen              RParen              = true
  (==) LBrace              LBrace              = true
  (==) RBrace              RBrace              = true
  (==) LAngle              LAngle              = true
  (==) RAngle              RAngle              = true
  (==) LSquare             LSquare             = true
  (==) RSquare             RSquare             = true
  (==) LArrow              LArrow              = true
  (==) RArrow              RArrow              = true
  (==) LFatArrow           LFatArrow           = true
  (==) RFatArrow           RFatArrow           = true
  (==) Colon               Colon               = true
  (==) DoubleColon         DoubleColon         = true
  (==) Equals              Equals              = true
  (==) Pipe                Pipe                = true
  (==) Tick                Tick                = true
  (==) Dot                 Dot                 = true
  (==) Comma               Comma               = true
  (==) Semi                Semi                = true
  (==) At                  At                  = true
  (==) (Newline n1)        (Newline n2)        = n1 == n2
  (==) (ShouldIndent n1)   (ShouldIndent n2)   = n1 == n2
  (==) (LName s1)          (LName s2)          = s1 == s2
  (==) (UName s1)          (UName s2)          = s1 == s2
  (==) (Symbol s1)         (Symbol s2)         = s1 == s2
  (==) (StringLiteral s1)  (StringLiteral s2)  = s1 == s2
  (==) (Natural n1)        (Natural n2)        = n1 == n2
  (==) (ANumber n1)        (ANumber n2)        = n1 == n2
  (==) _                   _                   = false
  (/=) tok1                tok2                = not (tok1 == tok2)

type Indentation = Number

type Line = Number
type Column = Number

type Position = Number

type Comments = [String]

type PositionedToken =
  { line :: Line
  , column :: Column
  , token :: Token
  , comments :: Comments
  }

mkPositionedToken :: Line -> Column -> [String] -> Token -> PositionedToken
mkPositionedToken line column comments token = { line: line, column: column, token: token, comments: comments }

foreign import unEscape
  "function unEscape(s) {\
  \  return function (sc) {\
  \    return function (fc) {\
  \      try {\
  \        return sc(JSON.parse('\"' + s + '\"'));\
  \      } catch (ex) {\
  \        return fc;\
  \      }\
  \    };\
  \  };\
  \}" :: forall r. String -> (String -> r) -> r -> r

lex :: String -> Either String [PositionedToken]
lex input = do
  let wh = eatWhitespace 0 []
  ts <- go 1 (wh.next + 1) wh.next [] []
  removeWhitespace [] ts []
  where
  go :: Line -> Column -> Position -> Comments -> [PositionedToken] -> Either String [PositionedToken]
  go _    _   i _  ts | i >= length input = Right (Data.Array.reverse ts)
  go line col i cs ts | charAt i input == " " = go line (col + 1) (i + 1) cs ts
  go line col i cs ts | charAt i input == "\r" = go line (col + 1) (i + 1) cs ts
  go line col i cs ts | charAt i input == "\n" =
    let wh = eatWhitespace (i + 1) ts
    in go (line + 1) (wh.len + 1) wh.next cs wh.toks

  go line col i cs ts | charAt i input == "-" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (\x -> (not $ isSymbolChar x) || x == "-") =
    let tok = eatWhile (i + 2) (\s -> s /= "\n")
    in go line (col + length tok.str) tok.next (cs ++ [tok.str]) ts
  go line col i cs ts | charAt i input == "{" && charAt (i + 1) input == "-" =
    let tok = eatWhile' (i + 2) (\j -> j < length input && ((charAt j input /= "-") || (charAt (j + 1) input /= "}")))
    in go line (col + length tok.str + 2) (tok.next + 2) (cs ++ [tok.str]) ts

  go line col i cs ts | charAt i input == "(" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LParen : ts)
  go line col i cs ts | charAt i input == ")" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RParen : ts)
  go line col i cs ts | charAt i input == "{" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LBrace : ts)
  go line col i cs ts | charAt i input == "}" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RBrace : ts)
  go line col i cs ts | charAt i input == "[" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LSquare : ts)
  go line col i cs ts | charAt i input == "]" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RSquare : ts)
  go line col i cs ts | charAt i input == "." && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Dot : ts)
  go line col i cs ts | charAt i input == "<" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LAngle : ts)
  go line col i cs ts | charAt i input == ">" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RAngle : ts)
  go line col i cs ts | charAt i input == ":" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Colon : ts)
  go line col i cs ts | charAt i input == "=" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Equals : ts)
  go line col i cs ts | charAt i input == "|" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Pipe : ts)
  go line col i cs ts | charAt i input == "@" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs At : ts)
  go line col i cs ts | charAt i input == "`" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Tick : ts)
  go line col i cs ts | charAt i input == "," = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Comma : ts)
  go line col i cs ts | charAt i input == ";" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Semi : ts)

  go line col i cs ts | charAt i input == ":" && charAt (i + 1) input == ":" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs DoubleColon : ts)
  go line col i cs ts | charAt i input == "<" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs LArrow : ts)
  go line col i cs ts | charAt i input == "-" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs RArrow : ts)
  go line col i cs ts | charAt i input == "<" && charAt (i + 1) input == "=" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs LFatArrow : ts)
  go line col i cs ts | charAt i input == "=" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs RFatArrow : ts)

  go line col i cs ts | charAt i input == "0" && charAt (i + 1) input == "x" =
    let ns = eatWhile (i + 2) isHex
    in go line (col + length ns.str) ns.next [] (mkPositionedToken line col cs (ANumber (readInt 16 ns.str)) : ts)

  go line col i cs ts | isNumeric (charAt i input) =
    case readNumberLiteral line col i of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs tok.tok : ts)

  go line col i cs ts | isIdentStart (charAt i input) =
    let tok = eatWhile i isIdentChar
        col' = col + length tok.str
    in case tok.str of
      s | shouldIndent tok.str ->
        let lme = nextLexeme line col' tok.next
        in case unit of
          _ | charAt lme.next input == "{" -> go line col' tok.next [] (mkPositionedToken line col cs (LName tok.str) : ts)
          _ -> go lme.line lme.col lme.next [] (mkPositionedToken line col cs (ShouldIndent lme.col) : mkPositionedToken line col [] (LName tok.str) : ts)
      s -> go line col' tok.next [] (mkPositionedToken line col cs (LName tok.str) : ts)

  go line col i cs ts | isUpper (charAt i input) =
    let tok = eatWhile i isIdentChar
    in go line (col + length tok.str) tok.next [] (mkPositionedToken line col cs (UName tok.str) : ts)
  go line col i cs ts | isSymbolChar (charAt i input) =
    let tok = eatWhile i isSymbolChar
    in go line (col + length tok.str) tok.next [] (mkPositionedToken line col cs (Symbol tok.str) : ts)

  go line col i cs ts | indexOf' "\"\"\"" i input == i =
    case readStringLiteral line col (i + 3) "\"\"\"" replaceNewLines of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs (StringLiteral tok.str) : ts)
    where
    replaceNewLines :: String -> String
    replaceNewLines = joinWith "\\n" <<< split "\n"
  go line col i cs ts | charAt i input == "\"" =
    case readStringLiteral line col (i + 1) "\"" handleMultiline of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs (StringLiteral tok.str) : ts)
    where
    handleMultiline :: String -> String
    handleMultiline = Rx.replace (Rx.regex "\\\\(\\s*)\\n(\\s*)\\\\" "g") ""

  go line col _ _ _ = Left $ "Lexer error at line " ++ show line ++ ", column " ++ show col

  removeWhitespace :: [Indentation] -> [PositionedToken] -> [PositionedToken] -> Either String [PositionedToken]
  removeWhitespace ms       ({ token = Newline _ } : (t@{ token = Newline _ }) : ts) acc = removeWhitespace ms (t : ts) acc
  removeWhitespace (m : ms) ((t@{ token = Newline n })      : ts) acc | m == n = removeWhitespace (m : ms) ts (mkPositionedToken t.line t.column t.comments Semi : acc)
  removeWhitespace []       ((t@{ token = Newline 1 })      : ts) acc = removeWhitespace [] ts (mkPositionedToken t.line t.column t.comments Semi : acc)
  removeWhitespace (m : ms) ((t@{ token = Newline n })      : ts) acc | n < m = removeWhitespace ms (t : ts) (mkPositionedToken t.line t.column t.comments RBrace : acc)
  removeWhitespace ms       ((t@{ token = Newline n })      : ts) acc = removeWhitespace ms ts acc
  removeWhitespace (m : ms) ((t@{ token = ShouldIndent n }) : ts) acc | n > m = removeWhitespace (n : m : ms) ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace []       ((t@{ token = ShouldIndent n }) : ts) acc | n > 1 = removeWhitespace [n] ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace ms       ((t@{ token = ShouldIndent n }) : ts) acc = removeWhitespace ms (mkPositionedToken t.line t.column t.comments (Newline n) : ts) (mkPositionedToken t.line t.column [] RBrace : mkPositionedToken t.line t.column [] LBrace : acc)
  removeWhitespace (1 : ms) ((t@{ token = RBrace })         : ts) acc = removeWhitespace ms ts (mkPositionedToken t.line t.column t.comments RBrace : acc)
  removeWhitespace _        ((t@{ token = RBrace })         : ts) acc = Left "Unexpected }"
  removeWhitespace ms       ((t@{ token = LBrace })         : ts) acc = removeWhitespace (1 : ms) ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace ms       (t : ts)                              acc = removeWhitespace ms ts (t : acc)
  removeWhitespace []       []                                    acc = return (Data.Array.reverse acc)
  removeWhitespace (m : ms) []                                    acc | m > 1 = removeWhitespace ms [] (mkPositionedToken 0 0 [] RBrace : acc)

  nextLexeme :: Line -> Column -> Position -> { line :: Line, col :: Column, next :: Position }
  nextLexeme = eat
    where
    eat line col i | charAt i input == " "  = eat line (col + 1) (i + 1)
    eat line col i | charAt i input == "\r" = eat line col (i + 1)
    eat line col i | charAt i input == "\n" = eat (line + 1) 1 (i + 1)
    eat line col i = { line: line, col: col, next: i }

  eatWhitespace :: Position -> [PositionedToken] -> { len :: Number, count :: Number, next :: Position, toks :: [PositionedToken] }
  eatWhitespace = eat 0 0
    where
    eat len count i ts | charAt i input == " " = eat (len + 1) (count + 1) (i + 1) ts
    eat len count i ts | charAt i input == "\r" = eat len (count + 1) (i + 1) ts
    -- TODO: include position info here
    eat len count i ts = { len: len, count: count, next: i, toks: mkPositionedToken 0 0 [] (Newline (len + 1)) : ts }

  eatWhile :: Position -> (String -> Boolean) -> { next :: Position, str :: String }
  eatWhile start p = eatWhile' start (\i -> p (charAt i input))

  eatWhile' :: Position -> (Number -> Boolean) -> { next :: Position, str :: String }
  eatWhile' start p = eat start 0
    where
    eat i _   | i >= length input = { next: i, str: drop start input }
    eat i len | p i = eat (i + 1) (len + 1)
    eat i len = { next: i, str: take len (drop start input) }

  readStringLiteral :: Line -> Column -> Position -> String -> (String -> String) -> Either String { next :: Position, str :: String, count :: Number }
  readStringLiteral line col start term replace = eat false 0 start
    where
    eat :: Boolean -> Number -> Position -> Either String { next :: Position, str :: String, count :: Number }
    eat _     _     i | i >= length input = Left $ "Unterminated string literal at line " ++ show line ++ ", column " ++ show col
    eat false count i | indexOf' term i input == i =
      let escaped = replace (take count (drop start input))
      in unEscape escaped (\s -> Right { next: i + length term, str: s, count: count }) (Left $ "Invalid string literal at line " ++ show line ++ ", column " ++ show col ++ ": " ++ show escaped)
    eat _     count i | charAt i input == "\\" = eat true (count + 1) (i + 1)
    eat _     count i = eat false (count + 1) (i + 1)

  readNumberLiteral :: Line -> Column -> Position -> Either String { next :: Position, tok :: Token, count :: Number }
  readNumberLiteral line col start = eat true false 0 start
    where
    eat :: Boolean -> Boolean -> Number -> Position -> Either String { next :: Position, tok :: Token, count :: Number }
    eat _     true  count i | charAt i input == "." = Left $ "Invalid decimal place in exponent in number literal at line " ++ show line ++ ", column " ++ show col
    eat false _     count i | charAt i input == "." = Left $ "Invalid decimal place in number literal at line " ++ show line ++ ", column " ++ show col
    eat _     _     count i | charAt i input == "." = eat false false (count + 1) (i + 1)
    eat _     true  count i | charAt i input == "e" = Left $ "Invalid exponent in number literal at line " ++ show line ++ ", column " ++ show col
    eat _     _     count i | charAt i input == "e" && charAt (i + 1) input == "-" = eat false true (count + 2) (i + 2)
    eat _     _     count i | charAt i input == "e" && charAt (i + 1) input == "+" = eat false true (count + 2) (i + 2)
    eat _     _     count i | charAt i input == "e" = eat false true (count + 1) (i + 1)
    eat isNat isExp count i | isNumeric (charAt i input) = eat isNat isExp (count + 1) (i + 1)
    eat isNat isExp count i =
      let s = (take count (drop start input))
      in Right { next: i, tok: if isNat then Natural (readInt 10 s) else ANumber (readFloat s), count: count }

  lookaheadChar :: Position -> (String -> Boolean) -> Boolean
  lookaheadChar i pred = pred (charAt i input)

  isSymbolChar :: String -> Boolean
  isSymbolChar c = indexOf c opCharsString >= 0

  isLower :: String -> Boolean
  isLower c = c >= "a" && c <= "z"

  isUpper :: String -> Boolean
  isUpper c = c >= "A" && c <= "Z"

  isAlpha :: String -> Boolean
  isAlpha c = isLower c || isUpper c

  isNumeric :: String -> Boolean
  isNumeric c = c >= "0" && c <= "9"

  isHex :: String -> Boolean
  isHex c = (c >= "a" && c <= "f") || (c >= "A" && c <= "F") || isNumeric c

  isAlphaNum :: String -> Boolean
  isAlphaNum c = isAlpha c || isNumeric c

  isIdentStart :: String -> Boolean
  isIdentStart c = isLower c || (c == "_")

  isIdentChar :: String -> Boolean
  isIdentChar c = isAlphaNum c || (c == "_") || (c == "'")

  isNumericLiteralChar :: String -> Boolean
  isNumericLiteralChar c = isNumeric c || (c == ".") || (c == "b") || (c == "x") || (c == "-")

  shouldIndent :: String -> Boolean
  shouldIndent "of" = true
  shouldIndent "do" = true
  shouldIndent "where" = true
  shouldIndent "let" = true
  shouldIndent _ = false

module Language.PureScript.Parser.Lexer where

import Data.Array ()
import Data.Either
import Data.String
import qualified Data.String.Regex as Rx

import Global (readInt, readFloat)

import Language.PureScript.Keywords (opCharsString)

data Token
  = LParen
  | RParen
  | LBrace
  | RBrace
  | LAngle
  | RAngle
  | LSquare
  | RSquare

  | Newline Indentation
  | ShouldIndent Indentation

  | LArrow
  | RArrow
  | LFatArrow
  | RFatArrow

  | Colon
  | DoubleColon
  | Equals
  | Pipe
  | Tick
  | Dot
  | Comma
  | Semi
  | At

  | LName String
  | UName String
  | Symbol String

  | StringLiteral String

  | Natural Number
  | ANumber Number

instance showToken :: Show Token where
  show LParen                = "LParen"
  show RParen                = "RParen"
  show LBrace                = "LBrace"
  show RBrace                = "RBrace"
  show LAngle                = "LAngle"
  show RAngle                = "RAngle"
  show LSquare               = "LSquare"
  show RSquare               = "RSquare"
  show LArrow                = "LArrow"
  show RArrow                = "RArrow"
  show LFatArrow             = "LFatArrow"
  show RFatArrow             = "RFatArrow"
  show Colon                 = "Colon"
  show DoubleColon           = "DoubleColon"
  show Equals                = "Equals"
  show Pipe                  = "Pipe"
  show Tick                  = "Tick"
  show Dot                   = "Dot"
  show Comma                 = "Comma"
  show Semi                  = "Semi"
  show At                    = "At"
  show (Newline n)           = "Newline (" ++ show n ++ ")"
  show (ShouldIndent n)      = "ShouldIndent (" ++ show n ++ ")"
  show (LName s)             = "LName (" ++ show s ++ ")"
  show (UName s)             = "UName (" ++ show s ++ ")"
  show (Symbol s)            = "Symbol (" ++ show s ++ ")"
  show (StringLiteral s)     = "StringLiteral (" ++ show s ++ ")"
  show (Natural n)           = "Natural (" ++ show n ++ ")"
  show (ANumber n)           = "ANumber (" ++ show n ++ ")"

instance eqToken :: Eq Token where
  (==) LParen              LParen              = true
  (==) RParen              RParen              = true
  (==) LBrace              LBrace              = true
  (==) RBrace              RBrace              = true
  (==) LAngle              LAngle              = true
  (==) RAngle              RAngle              = true
  (==) LSquare             LSquare             = true
  (==) RSquare             RSquare             = true
  (==) LArrow              LArrow              = true
  (==) RArrow              RArrow              = true
  (==) LFatArrow           LFatArrow           = true
  (==) RFatArrow           RFatArrow           = true
  (==) Colon               Colon               = true
  (==) DoubleColon         DoubleColon         = true
  (==) Equals              Equals              = true
  (==) Pipe                Pipe                = true
  (==) Tick                Tick                = true
  (==) Dot                 Dot                 = true
  (==) Comma               Comma               = true
  (==) Semi                Semi                = true
  (==) At                  At                  = true
  (==) (Newline n1)        (Newline n2)        = n1 == n2
  (==) (ShouldIndent n1)   (ShouldIndent n2)   = n1 == n2
  (==) (LName s1)          (LName s2)          = s1 == s2
  (==) (UName s1)          (UName s2)          = s1 == s2
  (==) (Symbol s1)         (Symbol s2)         = s1 == s2
  (==) (StringLiteral s1)  (StringLiteral s2)  = s1 == s2
  (==) (Natural n1)        (Natural n2)        = n1 == n2
  (==) (ANumber n1)        (ANumber n2)        = n1 == n2
  (==) _                   _                   = false
  (/=) tok1                tok2                = not (tok1 == tok2)

type Indentation = Number

type Line = Number
type Column = Number

type Position = Number

type Comments = [String]

type PositionedToken =
  { line :: Line
  , column :: Column
  , token :: Token
  , comments :: Comments
  }

mkPositionedToken :: Line -> Column -> [String] -> Token -> PositionedToken
mkPositionedToken line column comments token = { line: line, column: column, token: token, comments: comments }

foreign import unEscape
  "function unEscape(s) {\
  \  return function (sc) {\
  \    return function (fc) {\
  \      try {\
  \        return sc(JSON.parse('\"' + s + '\"'));\
  \      } catch (ex) {\
  \        return fc;\
  \      }\
  \    };\
  \  };\
  \}" :: forall r. String -> (String -> r) -> r -> r

lex :: String -> Either String [PositionedToken]
lex input = do
  let wh = eatWhitespace 0 []
  ts <- go 1 (wh.next + 1) wh.next [] []
  removeWhitespace [] ts []
  where
  go :: Line -> Column -> Position -> Comments -> [PositionedToken] -> Either String [PositionedToken]
  go _    _   i _  ts | i >= length input = Right (Data.Array.reverse ts)
  go line col i cs ts | charAt i input == " " = go line (col + 1) (i + 1) cs ts
  go line col i cs ts | charAt i input == "\r" = go line (col + 1) (i + 1) cs ts
  go line col i cs ts | charAt i input == "\n" =
    let wh = eatWhitespace (i + 1) ts
    in go (line + 1) (wh.len + 1) wh.next cs wh.toks

  go line col i cs ts | charAt i input == "-" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) =
    let tok = eatWhile (i + 2) (\s -> s /= "\n")
    in go line (col + length tok.str) tok.next (cs ++ [tok.str]) ts
  go line col i cs ts | charAt i input == "{" && charAt (i + 1) input == "-" =
    let tok = eatWhile' (i + 2) (\j -> j < length input && ((charAt j input /= "-") || (charAt (j + 1) input /= "}")))
    in go line (col + length tok.str + 2) (tok.next + 2) (cs ++ [tok.str]) ts

  go line col i cs ts | charAt i input == "(" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LParen : ts)
  go line col i cs ts | charAt i input == ")" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RParen : ts)
  go line col i cs ts | charAt i input == "{" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LBrace : ts)
  go line col i cs ts | charAt i input == "}" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RBrace : ts)
  go line col i cs ts | charAt i input == "[" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LSquare : ts)
  go line col i cs ts | charAt i input == "]" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RSquare : ts)
  go line col i cs ts | charAt i input == "." && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Dot : ts)
  go line col i cs ts | charAt i input == "<" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LAngle : ts)
  go line col i cs ts | charAt i input == ">" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RAngle : ts)
  go line col i cs ts | charAt i input == ":" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Colon : ts)
  go line col i cs ts | charAt i input == "=" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Equals : ts)
  go line col i cs ts | charAt i input == "|" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Pipe : ts)
  go line col i cs ts | charAt i input == "@" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs At : ts)
  go line col i cs ts | charAt i input == "`" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Tick : ts)
  go line col i cs ts | charAt i input == "," = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Comma : ts)
  go line col i cs ts | charAt i input == ";" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Semi : ts)

  go line col i cs ts | charAt i input == ":" && charAt (i + 1) input == ":" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs DoubleColon : ts)
  go line col i cs ts | charAt i input == "<" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs LArrow : ts)
  go line col i cs ts | charAt i input == "-" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs RArrow : ts)
  go line col i cs ts | charAt i input == "<" && charAt (i + 1) input == "=" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs LFatArrow : ts)
  go line col i cs ts | charAt i input == "=" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs RFatArrow : ts)

  go line col i cs ts | charAt i input == "0" && charAt (i + 1) input == "x" =
    let ns = eatWhile (i + 2) isHex
    in go line (col + length ns.str) ns.next [] (mkPositionedToken line col cs (ANumber (readInt 16 ns.str)) : ts)

  go line col i cs ts | isNumeric (charAt i input) =
    case readNumberLiteral line col i of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs tok.tok : ts)

  go line col i cs ts | isIdentStart (charAt i input) =
    let tok = eatWhile i isIdentChar
        col' = col + length tok.str
    in case tok.str of
      s | shouldIndent tok.str ->
        let lme = nextLexeme line col' tok.next
        in case unit of
          _ | charAt lme.next input == "{" -> go line col' tok.next [] (mkPositionedToken line col cs (LName tok.str) : ts)
          _ -> go lme.line lme.col lme.next [] (mkPositionedToken line col cs (ShouldIndent lme.col) : mkPositionedToken line col [] (LName tok.str) : ts)
      s -> go line col' tok.next [] (mkPositionedToken line col cs (LName tok.str) : ts)

  go line col i cs ts | isUpper (charAt i input) =
    let tok = eatWhile i isIdentChar
    in go line (col + length tok.str) tok.next [] (mkPositionedToken line col cs (UName tok.str) : ts)
  go line col i cs ts | isSymbolChar (charAt i input) =
    let tok = eatWhile i isSymbolChar
    in go line (col + length tok.str) tok.next [] (mkPositionedToken line col cs (Symbol tok.str) : ts)

  go line col i cs ts | indexOf' "\"\"\"" i input == i =
    case readStringLiteral line col (i + 3) "\"\"\"" replaceNewLines of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs (StringLiteral tok.str) : ts)
    where
    replaceNewLines :: String -> String
    replaceNewLines = joinWith "\\n" <<< split "\n"
  go line col i cs ts | charAt i input == "\"" =
    case readStringLiteral line col (i + 1) "\"" handleMultiline of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs (StringLiteral tok.str) : ts)
    where
    handleMultiline :: String -> String
    handleMultiline = Rx.replace (Rx.regex "\\\\(\\s*)\\n(\\s*)\\\\" "g") ""

  go line col _ _ _ = Left $ "Lexer error at line " ++ show line ++ ", column " ++ show col

  removeWhitespace :: [Indentation] -> [PositionedToken] -> [PositionedToken] -> Either String [PositionedToken]
  removeWhitespace ms       ({ token = Newline _ } : (t@{ token = Newline _ }) : ts) acc = removeWhitespace ms (t : ts) acc
  removeWhitespace (m : ms) ((t@{ token = Newline n })      : ts) acc | m == n = removeWhitespace (m : ms) ts (mkPositionedToken t.line t.column t.comments Semi : acc)
  removeWhitespace []       ((t@{ token = Newline 1 })      : ts) acc = removeWhitespace [] ts (mkPositionedToken t.line t.column t.comments Semi : acc)
  removeWhitespace (m : ms) ((t@{ token = Newline n })      : ts) acc | n < m = removeWhitespace ms (t : ts) (mkPositionedToken t.line t.column t.comments RBrace : acc)
  removeWhitespace ms       ((t@{ token = Newline n })      : ts) acc = removeWhitespace ms ts acc
  removeWhitespace (m : ms) ((t@{ token = ShouldIndent n }) : ts) acc | n > m = removeWhitespace (n : m : ms) ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace []       ((t@{ token = ShouldIndent n }) : ts) acc | n > 1 = removeWhitespace [n] ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace ms       ((t@{ token = ShouldIndent n }) : ts) acc = removeWhitespace ms (mkPositionedToken t.line t.column t.comments (Newline n) : ts) (mkPositionedToken t.line t.column [] RBrace : mkPositionedToken t.line t.column [] LBrace : acc)
  removeWhitespace (1 : ms) ((t@{ token = RBrace })         : ts) acc = removeWhitespace ms ts (mkPositionedToken t.line t.column t.comments RBrace : acc)
  removeWhitespace _        ((t@{ token = RBrace })         : ts) acc = Left "Unexpected }"
  removeWhitespace ms       ((t@{ token = LBrace })         : ts) acc = removeWhitespace (1 : ms) ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace ms       (t : ts)                              acc = removeWhitespace ms ts (t : acc)
  removeWhitespace []       []                                    acc = return (Data.Array.reverse acc)
  removeWhitespace (m : ms) []                                    acc | m > 1 = removeWhitespace ms [] (mkPositionedToken 0 0 [] RBrace : acc)

  nextLexeme :: Line -> Column -> Position -> { line :: Line, col :: Column, next :: Position }
  nextLexeme = eat
    where
    eat line col i | charAt i input == " "  = eat line (col + 1) (i + 1)
    eat line col i | charAt i input == "\r" = eat line col (i + 1)
    eat line col i | charAt i input == "\n" = eat (line + 1) 1 (i + 1)
    eat line col i = { line: line, col: col, next: i }

  eatWhitespace :: Position -> [PositionedToken] -> { len :: Number, count :: Number, next :: Position, toks :: [PositionedToken] }
  eatWhitespace = eat 0 0
    where
    eat len count i ts | charAt i input == " " = eat (len + 1) (count + 1) (i + 1) ts
    eat len count i ts | charAt i input == "\r" = eat len (count + 1) (i + 1) ts
    -- TODO: include position info here
    eat len count i ts = { len: len, count: count, next: i, toks: mkPositionedToken 0 0 [] (Newline (len + 1)) : ts }

  eatWhile :: Position -> (String -> Boolean) -> { next :: Position, str :: String }
  eatWhile start p = eatWhile' start (\i -> p (charAt i input))

  eatWhile' :: Position -> (Number -> Boolean) -> { next :: Position, str :: String }
  eatWhile' start p = eat start 0
    where
    eat i _   | i >= length input = { next: i, str: drop start input }
    eat i len | p i = eat (i + 1) (len + 1)
    eat i len = { next: i, str: take len (drop start input) }

  readStringLiteral :: Line -> Column -> Position -> String -> (String -> String) -> Either String { next :: Position, str :: String, count :: Number }
  readStringLiteral line col start term replace = eat false 0 start
    where
    eat :: Boolean -> Number -> Position -> Either String { next :: Position, str :: String, count :: Number }
    eat _     _     i | i >= length input = Left $ "Unterminated string literal at line " ++ show line ++ ", column " ++ show col
    eat false count i | indexOf' term i input == i =
      let escaped = replace (take count (drop start input))
      in unEscape escaped (\s -> Right { next: i + length term, str: s, count: count }) (Left $ "Invalid string literal at line " ++ show line ++ ", column " ++ show col ++ ": " ++ show escaped)
    eat _     count i | charAt i input == "\\" = eat true (count + 1) (i + 1)
    eat _     count i = eat false (count + 1) (i + 1)

  readNumberLiteral :: Line -> Column -> Position -> Either String { next :: Position, tok :: Token, count :: Number }
  readNumberLiteral line col start = eat true false 0 start
    where
    eat :: Boolean -> Boolean -> Number -> Position -> Either String { next :: Position, tok :: Token, count :: Number }
    eat _     true  count i | charAt i input == "." = Left $ "Invalid decimal place in exponent in number literal at line " ++ show line ++ ", column " ++ show col
    eat false _     count i | charAt i input == "." = Left $ "Invalid decimal place in number literal at line " ++ show line ++ ", column " ++ show col
    eat _     _     count i | charAt i input == "." = eat false false (count + 1) (i + 1)
    eat _     true  count i | charAt i input == "e" = Left $ "Invalid exponent in number literal at line " ++ show line ++ ", column " ++ show col
    eat _     _     count i | charAt i input == "e" && charAt (i + 1) input == "-" = eat false true (count + 2) (i + 2)
    eat _     _     count i | charAt i input == "e" && charAt (i + 1) input == "+" = eat false true (count + 2) (i + 2)
    eat _     _     count i | charAt i input == "e" = eat false true (count + 1) (i + 1)
    eat isNat isExp count i | isNumeric (charAt i input) = eat isNat isExp (count + 1) (i + 1)
    eat isNat isExp count i =
      let s = (take count (drop start input))
      in Right { next: i, tok: if isNat then Natural (readInt 10 s) else ANumber (readFloat s), count: count }

  lookaheadChar :: Position -> (String -> Boolean) -> Boolean
  lookaheadChar i pred = pred (charAt i input)

  isSymbolChar :: String -> Boolean
  isSymbolChar c = indexOf c opCharsString >= 0

  isLower :: String -> Boolean
  isLower c = c >= "a" && c <= "z"

  isUpper :: String -> Boolean
  isUpper c = c >= "A" && c <= "Z"

  isAlpha :: String -> Boolean
  isAlpha c = isLower c || isUpper c

  isNumeric :: String -> Boolean
  isNumeric c = c >= "0" && c <= "9"

  isHex :: String -> Boolean
  isHex c = (c >= "a" && c <= "f") || (c >= "A" && c <= "F") || isNumeric c

  isAlphaNum :: String -> Boolean
  isAlphaNum c = isAlpha c || isNumeric c

  isIdentStart :: String -> Boolean
  isIdentStart c = isLower c || (c == "_")

  isIdentChar :: String -> Boolean
  isIdentChar c = isAlphaNum c || (c == "_") || (c == "'")

  isNumericLiteralChar :: String -> Boolean
  isNumericLiteralChar c = isNumeric c || (c == ".") || (c == "b") || (c == "x") || (c == "-")

  shouldIndent :: String -> Boolean
  shouldIndent "of" = true
  shouldIndent "do" = true
  shouldIndent "where" = true
  shouldIndent "let" = true
  shouldIndent _ = false


Comments

Comments

module Hyper.Routing.DataRouterSpec where

import Prelude
import Hyper.Method as Method
import Data.Leibniz (type (~))
import Data.Maybe (Maybe(Nothing, Just))
import Data.Newtype (class Newtype, unwrap)
import Hyper.Core (statusNotFound, fallbackTo, class ResponseWriter, ResponseEnded, StatusLineOpen, Conn, Middleware, closeHeaders, writeStatus, statusOK)
import Hyper.HTML (p, h1, text, HTML)
import Hyper.Method (Method)
import Hyper.Response (class Response, respond)
import Hyper.Routing.DataRouter (class Addressable, class Routable, linkTo, formFor, router, POST, Route(Route), GET)
import Hyper.Test.TestServer (testStringBody, testResponseWriter, testServer)
import Node.Buffer (BUFFER)
import Test.Spec (Spec, it, describe)
import Test.Spec.Assertions (shouldEqual)

newtype Task = Task String

derive instance newtypeTask :: Newtype Task _

instance showTask :: Show Task where
  show = unwrap

data TestRoutes m
  = ListTasks (m ~ GET)
  | SaveTask Task (m ~ POST)

instance addressableTestRoutes :: Addressable TestRoutes where
  toPath =
    case _ of
      ListTasks _ -> []
      SaveTask _ _ -> []

instance routableGETTestRoutes :: Routable TestRoutes GET where
  fromRoute =
    case _ of
      Route [] -> Just (ListTasks id)
      _ -> Nothing

instance routablePOSTTestRoutes :: Routable TestRoutes POST where
  fromRoute =
    case _ of
      Route [] -> Just (SaveTask (Task "Be chill.") id)
      _ -> Nothing

-- The user-level routing handler function, i.e. the one that responds
-- to requests for each route.
--
-- NOTE: It's a bit shaky that it can deconstruct the ListTasks and
-- SaveTask constructors, regardless of their differently typed Leibniz
-- arguments, but it seems OK as the Routable instance cannot incorrectly
-- route POST to GET and vice versa.
handler :: forall m method req res rw b c.
  (Monad m, Response m HTML b, ResponseWriter rw m b) =>
  TestRoutes method
  -> Middleware
  m
  (Conn { url :: String, method :: Method | req }
        { writer :: rw StatusLineOpen | res }
        c)
  (Conn { url :: String, method :: Method | req }
        { writer :: rw ResponseEnded | res }
        c)
handler =
  case _ of
    ListTasks _ ->
      writeStatus statusOK
      >=> closeHeaders
      >=> respond (formFor SaveTask (Task "Be cool"))
    SaveTask _ _ ->
      writeStatus statusOK
      >=> closeHeaders
      >=> respond (p [] [ text "Saved. "
                        , linkTo ListTasks [text "Back to tasks."]
                        ])

app :: forall m req res rw b c.
  (Monad m, Response m HTML b, ResponseWriter rw m b) =>
  Middleware
  m
  (Conn { url :: String, method :: Method | req }
        { writer :: rw StatusLineOpen | res }
        c)
  (Conn { url :: String, method :: Method | req }
        { writer :: rw ResponseEnded | res }
        c)
app =
  -- This record is a little weird, but haven't found any better way
  -- yet (the only other approach I could come up with was type classes,
  -- and that would results in massive type signatures as one parameter
  -- would be the middleware type).
  --
  -- I hope that if the record it can be generically derived, then the user
  -- will not have to construct it, only provide the handler function.
  router { get: handler, post: handler }
  # fallbackTo notFound
  where
    notFound =
      writeStatus statusNotFound
      >=> closeHeaders
      >=> respond (h1 [] [text "Not Found"])

spec :: forall e. Spec (buffer :: BUFFER | e) Unit
spec = do
  describe "Hyper.Routing.DataRouter" do
    let makeRequest method path =
          { request: { method: method
                     , url: path
                     }
          , response: { writer: testResponseWriter }
          , components: {}
          }
          # app
          # testServer

    it "can route a GET" do
      conn <- makeRequest Method.GET "/"
      testStringBody conn `shouldEqual` "<form method=\"POST\" action=\"/\"><input name=\"value\" value=\"Be cool\"></input></form>"

    it "can route a POST" do
      conn <- makeRequest Method.POST "/"
      testStringBody conn `shouldEqual` "
Saved. Back to tasks.
"

module Hyper.Routing.DataRouterSpec where

import Prelude
import Hyper.Method as Method
import Data.Leibniz (type (~))
import Data.Maybe (Maybe(Nothing, Just))
import Data.Newtype (class Newtype, unwrap)
import Hyper.Core (statusNotFound, fallbackTo, class ResponseWriter, ResponseEnded, StatusLineOpen, Conn, Middleware, closeHeaders, writeStatus, statusOK)
import Hyper.HTML (p, h1, text, HTML)
import Hyper.Method (Method)
import Hyper.Response (class Response, respond)
import Hyper.Routing.DataRouter (class Addressable, class Routable, linkTo, formFor, router, POST, Route(Route), GET)
import Hyper.Test.TestServer (testStringBody, testResponseWriter, testServer)
import Node.Buffer (BUFFER)
import Test.Spec (Spec, it, describe)
import Test.Spec.Assertions (shouldEqual)

newtype Task = Task String

derive instance newtypeTask :: Newtype Task _

instance showTask :: Show Task where
  show = unwrap

data TestRoutes m
  = ListTasks (m ~ GET)
  | SaveTask Task (m ~ POST)

instance addressableTestRoutes :: Addressable TestRoutes where
  toPath =
    case _ of
      ListTasks _ -> []
      SaveTask _ _ -> []

instance routableGETTestRoutes :: Routable TestRoutes GET where
  fromRoute =
    case _ of
      Route [] -> Just (ListTasks id)
      _ -> Nothing

instance routablePOSTTestRoutes :: Routable TestRoutes POST where
  fromRoute =
    case _ of
      Route [] -> Just (SaveTask (Task "Be chill.") id)
      _ -> Nothing

-- The user-level routing handlerfunction, i.e. the one that responds
-- to requests for each route.
handler :: forall m method req res rw b c.
  (Monad m, Response m HTML b, ResponseWriter rw m b) =>
  TestRoutes method
  -> Middleware
  m
  (Conn { url :: String, method :: Method | req }
        { writer :: rw StatusLineOpen | res }
        c)
  (Conn { url :: String, method :: Method | req }
        { writer :: rw ResponseEnded | res }
        c)
handler =
  case _ of
    ListTasks _ ->
      writeStatus statusOK
      >=> closeHeaders
      >=> respond (formFor SaveTask (Task "Be cool"))
    SaveTask _ _ ->
      writeStatus statusOK
      >=> closeHeaders
      >=> respond (p [] [ text "Saved. "
                        , linkTo ListTasks [text "Back to tasks."]
                        ])

app :: forall m req res rw b c.
  (Monad m, Response m HTML b, ResponseWriter rw m b) =>
  Middleware
  m
  (Conn { url :: String, method :: Method | req }
        { writer :: rw StatusLineOpen | res }
        c)
  (Conn { url :: String, method :: Method | req }
        { writer :: rw ResponseEnded | res }
        c)
app =
  -- This is a little weird, but haven't found a better way yet.
  -- If it can be generically derived the user would not have to
  -- construct this record.
  router { get: handler, post: handler }
  # fallbackTo notFound
  where
    notFound =
      writeStatus statusNotFound
      >=> closeHeaders
      >=> respond (h1 [] [text "Not Found"])

spec :: forall e. Spec (buffer :: BUFFER | e) Unit
spec = do
  describe "Hyper.Routing.DataRouter" do
    let makeRequest method path =
          { request: { method: method
                     , url: path
                     }
          , response: { writer: testResponseWriter }
          , components: {}
          }
          # app
          # testServer

    it "can route a GET" do
      conn <- makeRequest Method.GET "/"
      testStringBody conn `shouldEqual` "<form method=\"POST\" action=\"/\"><input name=\"value\" value=\"Be cool\"></input></form>"

    it "can route a POST" do
      conn <- makeRequest Method.POST "/"
      testStringBody conn `shouldEqual` "
Saved. Back to tasks.
"


formatted

formatted

module Blueprint.Components.CollapsibleList where

import Blueprint.Components.Menu (MenuItemProps)
import Blueprint.Components.Popover (PopoverProps)
import Blueprint.ComponentsClasses (collapsibleListClass)
import Blueprint.PropTypes (PropsEx, Prop, UnknownJSXElementType)
import React

newtype CollapseForm = CollapseForm Int

collapseForm ::
  { start :: CollapseForm
  , end :: CollapseForm
  }
collapseForm =
  { start : CollapseForm 0
  , end : CollapseForm 1
  }

type CollapsibleListProps = CollapsibleListPropsEx ()

type CollapsibleListPropsEx r = PropsEx
  ( dropdownTarget :: UnknownJSXElementType
  , dropdownProps :: PopoverProps
  , renderVisibleItem :: MenuItemProps -> Int -> UnknownJSXElementType
  , collapseFrom :: CollapseForm
  , visibleItemClassName :: String
  , visibleItemCount :: Int
  | r
  )

collapsibleList :: Prop CollapsibleListProps -> Array ReactElement -> ReactElement
collapsibleList = createElement collapsibleListClass

module Blueprint.Components.CollapsibleList where

import React
import Blueprint.ComponentsClasses (collapsibleListClass)
import Blueprint.Components.Menu (IMenuItemProps)
import Blueprint.PropTypes (IPropsEx, Prop, UnknownJSXElementType)
import Blueprint.Components.Popover (IPopoverProps)

newtype CollapseForm = CollapseForm Int

collapseForm  :: { start :: CollapseForm, end :: CollapseForm }
collapseForm = { start : CollapseForm 0, end : CollapseForm 1}

type CollapsibleListProps = CollapsibleListPropsEx ()

type CollapsibleListPropsEx r = IPropsEx ( dropdownTarget :: UnknownJSXElementType
                                         , dropdownProps :: IPopoverProps
                                         , renderVisibleItem :: IMenuItemProps -> Int -> UnknownJSXElementType
                                         , collapseFrom :: CollapseForm
                                         , visibleItemClassName :: String
                                         , visibleItemCount :: Int
                                         | r)

collapsibleList :: Prop CollapsibleListProps -> Array ReactElement -> ReactElement
collapsibleList = createElement collapsibleListClass


refactors Streams to be a lot more modular.

module Openspace.Ui.Stream where

import Rx.Observable
import Data.Either
import Control.Monad.Eff
import Control.Monad.ST
import DOM

import Openspace.Ui.Render
import Openspace.Ui.Emitter
import Openspace.Ui.Parser
import Openspace.Types
import Openspace.Engine
import Openspace.Network.Socket

netStream :: forall eff. Socket -> Eff( net :: Net | eff ) (Observable Action)
netStream socket = do
  onReceive <- "message" `socketObserver` socket
  return $ (\ f -> case parseAction f of
               Right a -> a
               Left e -> ShowError (show e)
           ) <$> onReceive

uiStream :: forall eff. Eff( dom :: DOM | eff ) (Observable Action)
uiStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
  let add = (\e -> do
                let ft = getDetail e
                case parseTopic ft of
                  Right t -> AddTopic t
                  Left e -> ShowError (show e)
            ) <$> lookup "addTopic"

  let dragOverSlot = (\e -> case parseSlot (getDetail e) of
                         Right s -> AssignTopic s
                         Left e -> UnassignTopic
                     ) <$> lookup "dragOverSlot"

  let dragOverTrash = (const DeleteTopic) <$> (lookup "dragOverTrash")

  -- HTML 5 fires dragLeave before dragEnd occurs
  -- TODO: Find a cleaner solution
  let dragLeave = delay 30 $ (const UnassignTopic) <$> ((lookup "dragLeaveSlot") `merge` (lookup "dragLeaveTrash"))

  let dragOver = dragLeave `merge` dragOverSlot `merge` dragOverTrash

  let dragTopic = do (Right t) <- (parseTopic <<< getDetail) <$> lookup "dragStartTopic"
                     action <- dragOver
                     lookup "dragEndTopic"
                     return $ action t
  return $ add `merge` dragTopic

main = do
  -- TODO: getSocket :: Either SockErr Socket
  let sockEmitter = getSocket "http://localhost:3000"
  -- Initial State
  appSt <- newSTRef myState1
  -- Initial Render
  renderMenu (show <$> topicTypes)
  readSTRef appSt >>= renderApp
  -- Observable Action
  ui  <- uiStream
  net <- netStream sockEmitter
  -- Broadcast the UI Observable
  unwrap $ (\a -> emitAction sockEmitter (serialize a)) <$> ui
  -- Evaluate Action Observables
  let actions = ui `merge` net
  subscribe actions (\a -> modifySTRef appSt (evalAction a) >>= renderApp)

module Openspace.Ui.Stream where

import Rx.JQuery
import Rx.Observable

import Data.Either
import Data.Foreign
import Data.Foreign.Class
import Data.Tuple hiding(zip)
import Data.Maybe

import Control.Monad.Eff
import Control.Monad.ST
import qualified Control.Monad.JQuery as J
import Debug.Trace
import DOM

import Openspace.Ui.Render
import Openspace.Types
import Openspace.Engine
import Openspace.Network.Socket

foreign import getDetail
"""
function getDetail (e){
    return e.originalEvent.detail;
}
""" :: forall eff. J.JQueryEvent -> Foreign

parseAction :: Foreign -> Either ForeignError Action
parseAction fa = do
  a <- read fa :: F Action
  return a

parseTopic :: Foreign -> Either ForeignError Topic
parseTopic ft = do
  t <- read ft :: F Topic
  return t

parseSlot :: Foreign -> Either ForeignError Slot
parseSlot fs = do
  s <- read fs :: F Slot
  return s

parseTimeslot :: Foreign -> Foreign -> Either ForeignError Timeslot
parseTimeslot fs ft = do
  s <- parseSlot fs
  t <- parseTopic ft
  return $ Tuple s t

type Stream a h eff = Eff( dom :: DOM, trace :: Trace, st :: ST h, net :: Net | eff ) Unit

streams :: forall h eff. Stream AppState h eff
streams = do

  appSt <- newSTRef myState1
  readSTRef appSt >>= renderApp
  renderMenu (show <$> topicTypes)

  menuEmitter              <- J.select "#menuContainer"
  onAddTopic               <- "addTopic" `onAsObservable` menuEmitter
  onDragOverTrash          <- "dragOverTrash" `onAsObservable` menuEmitter
  onDragLeaveTrash         <- "dragLeaveTrash" `onAsObservable` menuEmitter

  topicEmitter             <- J.select "#topicsContainer"
  onDragStartTopic         <- "dragStartTopic" `onAsObservable` topicEmitter
  onDragEndTopic           <- "dragEndTopic" `onAsObservable` topicEmitter

  gridEmitter              <- J.select "#gridContainer"
  onDragOverSlot           <- "dragOverSlot" `onAsObservable` gridEmitter
  onDragLeaveSlot          <- "dragLeaveSlot" `onAsObservable` gridEmitter

  let sockEmitter = getSocket "http://localhost:3000"
  onReceive                <- "message" `socketObserver` sockEmitter

  let add = (\e -> do
                let ft = getDetail e
                case parseTopic ft of
                  Right t -> AddTopic t
                  Left e -> ShowError (show e)
            ) <$> onAddTopic

  let dragOverSlot = (\e -> case parseSlot (getDetail e) of
                         Right s -> AssignTopic s
                         Left e -> UnassignTopic
                     ) <$> onDragOverSlot

  let dragOverTrash = (const DeleteTopic) <$> onDragOverTrash

  -- HTML 5 fires dragLeave before dragEnd occurs
  -- TODO: Find a cleaner solution
  let dragLeave = delay 30 $ (const UnassignTopic) <$> (onDragLeaveSlot `merge` onDragLeaveTrash)

  let dragOver = dragLeave `merge` dragOverSlot `merge` dragOverTrash

  let dragTopic =
        do (Right t) <- (parseTopic <<< getDetail) <$> onDragStartTopic
           action <- dragOver
           onDragEndTopic
           return $ action t

  let receive = (\ f -> case parseAction f of
                    Right a -> a
                    Left e -> ShowError (show e)
                ) <$> onReceive

  let change = add `merge` dragTopic

  subscribe receive (\a -> do modifySTRef appSt (evalAction a) >>= renderApp)

  subscribe change (\a -> do modifySTRef appSt (evalAction a) >>= renderApp
                             emitAction sockEmitter (serialize a)
                   )

main = streams