text' removed, formatted and cleaned up components

module RNX.Components where

import Prelude
import Data.Function.Uncurried (Fn2)

foreign import data ReactClass :: * -> *
foreign import data Element :: * -> *
foreign import data Prop :: * -> *

foreign import forwardTo    :: forall a b. (a -> b) -> Element a -> Element b
foreign import mapAttribute :: forall a b. (a -> b) -> Prop a -> Prop b

instance functorElement :: Functor Element where
  map f x = forwardTo f x

instance functorAttribute :: Functor Prop where
  map f x = mapAttribute f x

-- createElement
foreign import createElement         :: forall props action. ReactClass props -> props -> Array (Element action)-> Element action
foreign import createElementOneChild :: forall props action. ReactClass props -> props -> Element action -> Element action

-- classes
foreign import activityIndicatorClass        :: forall props. ReactClass props
foreign import datePickerIOSClass            :: forall props. ReactClass props
foreign import drawerLayoutAndroidClass      :: forall props. ReactClass props
foreign import imageClass                    :: forall props. ReactClass props
foreign import keyboardAvoidingViewClass     :: forall props. ReactClass props
foreign import listViewClass                 :: forall props. ReactClass props
foreign import mapViewClass                  :: forall props. ReactClass props
foreign import modalClass                    :: forall props. ReactClass props
foreign import pickerClass                   :: forall props. ReactClass props
foreign import pickerItemClass               :: forall props. ReactClass props
foreign import progressViewIOSClass          :: forall props. ReactClass props
foreign import refreshControlClass           :: forall props. ReactClass props
foreign import scrollViewClass               :: forall props. ReactClass props
foreign import segmentedControlIOSClass      :: forall props. ReactClass props
foreign import sliderClass                   :: forall props. ReactClass props
foreign import statusBarClass                :: forall props. ReactClass props
foreign import snapshotViewIOSClass          :: forall props. ReactClass props
foreign import switchClass                   :: forall props. ReactClass props
foreign import tabBarIOSClass                :: forall props. ReactClass props
foreign import tabBarIOSItemClass            :: forall props. ReactClass props
foreign import textClass                     :: forall props. ReactClass props
foreign import textInputClass                :: forall props. ReactClass props
foreign import toolbarAndroidClass           :: forall props. ReactClass props
foreign import touchableHighlightClass       :: forall props. ReactClass props
foreign import touchableNativeFeedbackClass  :: forall props. ReactClass props
foreign import touchableOpacityClass         :: forall props. ReactClass props
foreign import touchableWithoutFeedbackClass :: forall props. ReactClass props
foreign import viewClass                     :: forall props. ReactClass props
foreign import viewPagerAndroidClass         :: forall props. ReactClass props
foreign import webViewClass                  :: forall props. ReactClass props

-- Elements
foreign import textElem :: forall action. String -> Element action

foreign import handler :: forall event action. Fn2 String (event -> action) (Prop action)
foreign import handlerBool :: forall event action. Fn2 String (event -> Boolean) (Prop action)
foreign import handlerUnit :: forall event action. Fn2 String (event -> Unit) (Prop action)

-- ActivityIndicator doesn't have any children
activityIndicator :: forall action. Array (Prop action) -> Element action
activityIndicator props = createElement activityIndicatorClass props []

datePickerIOS :: forall action. Array (Prop action) -> Element action
datePickerIOS props = createElement datePickerIOSClass props []

drawerLayoutAndroid :: forall action. Array (Prop action) -> Array (Element action) -> Element action
drawerLayoutAndroid = createElement drawerLayoutAndroidClass

image :: forall action. Array (Prop action) -> Array (Element action) -> Element action
image = createElement imageClass

keyboardAvoidingView :: forall action. Array (Prop action) -> Array (Element action) -> Element action
keyboardAvoidingView = createElement keyboardAvoidingViewClass

textView :: forall action. Array (Prop action) -> Array (Element action) -> Element action
textView = createElement textClass

listView :: forall action. Array (Prop action) -> Element action
listView props = createElement listViewClass props []

mapView :: forall action. Array (Prop action) -> Array (Element action) -> Element action
mapView = createElement mapViewClass

modal :: forall action. Array (Prop action) -> Array (Element action) -> Element action
modal = createElement modalClass

picker :: forall action. Array (Prop action) -> Array (Element action) -> Element action
picker = createElement pickerClass

pickerItem :: forall action. Array (Prop action) -> Array (Element action) -> Element action
pickerItem = createElement pickerItemClass

progressViewIOS :: forall action. Array (Prop action) -> Element action
progressViewIOS props = createElement progressViewIOSClass props []

refreshControl' :: forall action. Array (Prop action) -> Element action
refreshControl' props = createElement refreshControlClass props []

scrollView :: forall action. Array (Prop action) -> Array (Element action) -> Element action
scrollView = createElement scrollViewClass

segmentedControlIOS :: forall action. Array (Prop action) -> Element action
segmentedControlIOS props = createElement segmentedControlIOSClass props []

slider :: forall action. Array (Prop action) -> Element action
slider props = createElement sliderClass props []

statusBar :: forall action. Array (Prop action) -> Element action
statusBar props = createElement statusBarClass props []

snapshotViewIOS :: forall action. Array (Prop action) -> Element action
snapshotViewIOS props = createElement snapshotViewIOSClass props []

switch :: forall action. Array (Prop action) ->  Element action
switch props = createElement switchClass props []

tabBarIOS :: forall action. Array (Prop action) -> Array (Element action) -> Element action
tabBarIOS = createElement tabBarIOSClass

tabBarIOSItem :: forall action. Array (Prop action) -> Element action
tabBarIOSItem props = createElement tabBarIOSItemClass props []

-- TODO: Text can have Text Component inside
text :: forall action. Array (Prop action) -> String -> Element action
text props str = createElement textClass props [textElem str]

textInput :: forall action. Array (Prop action) -> Element action
textInput props = createElement textInputClass props []

toolbarAndroid :: forall action. Array (Prop action) -> Element action
toolbarAndroid props = createElement toolbarAndroidClass props []

touchableHighlight :: forall action. Array (Prop action) -> Element action -> Element action
touchableHighlight = createElementOneChild touchableHighlightClass

touchableNativeFeedback :: forall action. Array (Prop action) -> Element action -> Element action
touchableNativeFeedback = createElementOneChild touchableNativeFeedbackClass

touchableOpacity :: forall action. Array (Prop action) -> Element action -> Element action
touchableOpacity = createElementOneChild touchableOpacityClass

touchableWithoutFeedback :: forall action. Array (Prop action) -> Element action -> Element action
touchableWithoutFeedback = createElementOneChild touchableWithoutFeedbackClass

view' :: forall action. Array (Prop action) -> Array (Element action) -> Element action
view' = createElement viewClass

viewPagerAndroid :: forall action. Array (Prop action) -> Array (Element action) -> Element action
viewPagerAndroid = createElement viewPagerAndroidClass

webView :: forall action. Array (Prop action) -> Element action
webView props = createElement webViewClass props []

module RNX.Components where

import Data.Function.Uncurried (Fn2, Fn3, runFn2, runFn3)
import Prelude

foreign import data ReactClass :: * -> *
foreign import data Element :: * -> *
foreign import data Prop :: * -> *

instance functorElement :: Functor Element where
  map f x = forwardTo f x

instance functorAttribute :: Functor Prop where
  map f x = mapAttribute f x

foreign import forwardTo :: forall a b. (a -> b) -> Element a -> Element b

foreign import mapAttribute :: forall a b. (a -> b) -> Prop a -> Prop b

-- createElement
foreign import createElement :: forall props action. ReactClass props -> props -> Array (Element action)-> Element action
foreign import createElementOneChild :: forall props action. ReactClass props -> props -> Element action -> Element action

-- classes
foreign import activityIndicatorClass :: forall props. ReactClass props
foreign import datePickerIOSClass :: forall props. ReactClass props
foreign import drawerLayoutAndroidClass :: forall props. ReactClass props
foreign import imageClass :: forall props. ReactClass props
foreign import keyboardAvoidingViewClass :: forall props. ReactClass props
foreign import listViewClass :: forall props. ReactClass props
foreign import mapViewClass :: forall props. ReactClass props
foreign import modalClass :: forall props. ReactClass props
foreign import pickerClass :: forall props. ReactClass props
foreign import pickerItemClass :: forall props. ReactClass props
foreign import progressViewIOSClass :: forall props. ReactClass props
foreign import refreshControlClass :: forall props. ReactClass props
foreign import scrollViewClass :: forall props. ReactClass props
foreign import segmentedControlIOSClass :: forall props. ReactClass props
foreign import sliderClass :: forall props. ReactClass props
foreign import statusBarClass :: forall props. ReactClass props
foreign import snapshotViewIOSClass :: forall props. ReactClass props
foreign import switchClass :: forall props. ReactClass props
foreign import tabBarIOSClass :: forall props. ReactClass props
foreign import tabBarIOSItemClass :: forall props. ReactClass props
foreign import textClass :: forall props. ReactClass props
foreign import textInputClass :: forall props. ReactClass props
foreign import toolbarAndroidClass :: forall props. ReactClass props
foreign import touchableHighlightClass :: forall props. ReactClass props
foreign import touchableNativeFeedbackClass :: forall props. ReactClass props
foreign import touchableOpacityClass :: forall props. ReactClass props
foreign import touchableWithoutFeedbackClass :: forall props. ReactClass props
foreign import viewClass :: forall props. ReactClass props
foreign import viewPagerAndroidClass :: forall props. ReactClass props
foreign import webViewClass :: forall props. ReactClass props
-- Elements
foreign import textElem :: forall action. String -> Element action

text' :: forall action. Array (Prop action) -> String -> Element action
text' props str = createElement textClass props [textElem str]

foreign import handler :: forall event action. Fn2 String (event -> action) (Prop action)

foreign import handlerBool :: forall event action. Fn2 String (event -> Boolean) (Prop action)

foreign import handlerUnit :: forall event action. Fn2 String (event -> Unit) (Prop action)

-- ActivityIndicator doesn't have any children
activityIndicator :: forall action. Array (Prop action) -> Element action
activityIndicator props = createElement activityIndicatorClass props []

datePickerIOS :: forall action. Array (Prop action) -> Element action
datePickerIOS props = createElement datePickerIOSClass props []

drawerLayoutAndroid :: forall action. Array (Prop action) -> Array (Element action) -> Element action
drawerLayoutAndroid = createElement drawerLayoutAndroidClass

image :: forall action. Array (Prop action) -> Array (Element action) -> Element action
image = createElement imageClass

keyboardAvoidingView :: forall action. Array (Prop action) -> Array (Element action) -> Element action
keyboardAvoidingView = createElement keyboardAvoidingViewClass

textView :: forall action. Array (Prop action) -> Array (Element action) -> Element action
textView = createElement textClass

listView :: forall action. Array (Prop action) -> Element action
listView props = createElement listViewClass props []

mapView :: forall action. Array (Prop action) -> Array (Element action) -> Element action
mapView = createElement mapViewClass

modal :: forall action. Array (Prop action) -> Array (Element action) -> Element action
modal = createElement modalClass

picker :: forall action. Array (Prop action) -> Array (Element action) -> Element action
picker = createElement pickerClass

pickerItem :: forall action. Array (Prop action) -> Array (Element action) -> Element action
pickerItem = createElement pickerItemClass

progressViewIOS :: forall action. Array (Prop action) -> Element action
progressViewIOS props = createElement progressViewIOSClass props []

refreshControl' :: forall action. Array (Prop action) -> Element action
refreshControl' props = createElement refreshControlClass props []

scrollView :: forall action. Array (Prop action) -> Array (Element action) -> Element action
scrollView = createElement scrollViewClass

segmentedControlIOS :: forall action. Array (Prop action) -> Element action
segmentedControlIOS props = createElement segmentedControlIOSClass props []

slider :: forall action. Array (Prop action) -> Element action
slider props = createElement sliderClass props []

statusBar :: forall action. Array (Prop action) -> Element action
statusBar props = createElement statusBarClass props []

snapshotViewIOS :: forall action. Array (Prop action) -> Element action
snapshotViewIOS props = createElement snapshotViewIOSClass props []

switch :: forall action. Array (Prop action) ->  Element action
switch props = createElement switchClass props []

tabBarIOS :: forall action. Array (Prop action) -> Array (Element action) -> Element action
tabBarIOS = createElement tabBarIOSClass

tabBarIOSItem :: forall action. Array (Prop action) -> Element action
tabBarIOSItem props = createElement tabBarIOSItemClass props []

-- TODO: Text can have Text Component inside
text :: forall action. Array (Prop action) -> String -> Element action
text props str = createElement textClass props [textElem str]

textInput :: forall action. Array (Prop action) -> Element action
textInput props = createElement textInputClass props []

toolbarAndroid :: forall action. Array (Prop action) -> Element action
toolbarAndroid props = createElement toolbarAndroidClass props []

touchableHighlight :: forall action. Array (Prop action) -> Element action -> Element action
touchableHighlight = createElementOneChild touchableHighlightClass

touchableNativeFeedback :: forall action. Array (Prop action) -> Element action -> Element action
touchableNativeFeedback = createElementOneChild touchableNativeFeedbackClass

touchableOpacity :: forall action. Array (Prop action) -> Element action -> Element action
touchableOpacity = createElementOneChild touchableOpacityClass

touchableWithoutFeedback :: forall action. Array (Prop action) -> Element action -> Element action
touchableWithoutFeedback = createElementOneChild touchableWithoutFeedbackClass

view' :: forall action. Array (Prop action) -> Array (Element action) -> Element action
view' = createElement viewClass

viewPagerAndroid :: forall action. Array (Prop action) -> Array (Element action) -> Element action
viewPagerAndroid = createElement viewPagerAndroidClass

webView :: forall action. Array (Prop action) -> Element action
webView props = createElement webViewClass props []


Wrap result as a Node, which can be un/resolved

-- | Resolve ambiguities by combining the parsed usage section with any parsed
-- | Option sections, as well as some best effort guessing.

module Language.Docopt.Solver where

import Prelude
import Data.Functor ((<$))
import Data.Either (Either(..), either)
import Data.Maybe.Unsafe (fromJust)
import Data.Maybe (Maybe(Nothing, Just), isNothing, maybe, isJust)
import Data.List (List(..), length, filter, singleton, toList, catMaybes, head,
                  (:))
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple))
import Control.MonadPlus (guard)
import Control.Alt ((<|>))
import Data.String (fromChar, fromCharArray, toCharArray, toUpper)
import Data.Array as A
import Data.String as S
import Data.String.Unsafe as US

import Data.String.Ext ((^=), endsWith)
import Language.Docopt.Errors (SolveError(..))
import Language.Docopt.Argument (Argument(..), Branch(..))
import Language.Docopt.Usage (Usage(..))
import Language.Docopt.Parser.Desc (Desc())
import Language.Docopt.Option as O
import Language.Docopt.Parser.Desc as DE
import Language.Docopt.Parser.Usage (Usage(..)) as U
import Language.Docopt.Parser.Usage.Argument (Branch, Argument(..)) as U
import Language.Docopt.Parser.Usage.Option as UO

data Slurp a
  = Slurp (List a)
  | Keep  (List a)

data Node
  = Resolved   Argument
  | Unresolved U.Argument

runSlurp :: forall a. Slurp a -> List a
runSlurp (Slurp xs) = xs
runSlurp (Keep  xs) = xs

fail :: forall a. String -> Either SolveError a
fail = Left <<< SolveError

solveBranch :: U.Branch                 -- ^ the usage branch
            -> List Desc                -- ^ the option descriptions
            -> Either SolveError Branch -- ^ the canonical usage branch
solveBranch as ds = Branch <$> go as
  where
    go :: U.Branch -> Either SolveError (List Argument)
    go us = do
      xs <- solveArgs us
      return Nil

    solveArgs :: U.Branch -> Either SolveError (List Node)
    solveArgs Nil = return Nil
    solveArgs (Cons x Nil) = do
      m <- solveArg x Nothing
      return $ runSlurp m
    solveArgs (Cons x (Cons y xs)) = do
      m <- solveArg x (Just y)
      case m of
        Keep  zs -> (zs ++ _) <$> solveArgs (y:xs)
        Slurp zs -> (zs ++ _) <$> solveArgs xs

    simpleResolve v = Keep <<< singleton <$> return (Resolved v)

    -- | Solve two adjacent arguments.
    -- | Should the first argument be an option with an argument that
    -- | matches an adjacent command or positional, consume the adjacent
    -- | argument from the input (consume).
    solveArg :: U.Argument
              -> Maybe U.Argument
              -> Either SolveError (Slurp Node)

    solveArg (U.EOA) _ = simpleResolve EOA
    solveArg (U.Stdin) _ = simpleResolve Stdin
    solveArg (U.Command s r) _ = simpleResolve $ Command s r
    solveArg (U.Positional s r) _ = simpleResolve $ Positional s r

    solveArg (U.Group o bs r) _
      = Keep <<< singleton <<< Resolved <$> do
        flip (Group o) r <$> do
          flip solveBranch ds `traverse` bs

    solveArg r@(U.Reference _) _ = do
      return $ Keep $ singleton $ Unresolved r

    solveArg (lopt@(U.Option (opt@(UO.LOpt o)))) adjArg = do

      -- Find a matching option description, if any.
      match <- O.runOption <$> matchDesc o.name

      -- Check to see if this option has an explicitly bound argument.
      -- In this case, a check to consume an adjacent arg must not take place.
      case o.arg of
        (Just exarg) -> do
          -- Note: There is no check to see if an explicit argument is
          --       the same as specified in the option descriptions for
          --       convenience to the user.
          return
            $ Keep
              $ singleton
                $ Resolved
                  $ Option $ O.Option match

        Nothing -> do
          -- Look ahead if any of the following arguments should be slurped.
          -- Return either `Nothing` to signify that nothing should be slurped
          -- or a value signifieng that it should be slurped, and the
          -- `isRepeated` flag should be inherited.
          let mr = do
                guard (not o.repeatable)
                matchedArg <- O.runArgument <$> match.arg
                case adjArg of
                  Just (U.Positional n r) ->
                    return $ r <$ guardArgs n matchedArg.name
                  Just (U.Command n r) ->
                    return $ r <$ guardArgs n matchedArg.name
                  _ -> return $ fail
                      $ "Option-Argument specified in options-section missing"
                        ++ " --" ++ o.name

          case mr of
            Nothing -> return
              $ Keep
                $ singleton
                  $ Resolved
                    $ Option $ O.Option match
            Just er -> do
              r <- er
              return
                $ Slurp
                  $ singleton
                    $ Resolved
                      $ Option $ O.Option $ match { repeatable = r }

      where
        guardArgs :: String -> String -> Either SolveError Boolean
        guardArgs n n' | n ^= n' = return true
        guardArgs n n' = fail
          $ "Arguments mismatch for option --" ++ o.name ++ ": "
              ++ show n ++ " and " ++ show n'

        matchDesc :: String -> Either SolveError O.Option
        matchDesc n =
          case filter isMatch ds of
            xs | length xs > 1 -> fail
              $ "Multiple option descriptions for option --" ++ n
            (Cons (DE.OptionDesc (DE.Option desc)) Nil) -> do
              arg <- resolveOptArg o.arg desc.arg
              return $ O.Option { flag:       DE.getFlag desc.name
                                , name:       DE.getName desc.name
                                , arg:        arg
                                , env:        desc.env
                                , repeatable: o.repeatable
                                }
            -- default fallback: construct the option from itself alone
            _ -> return $ O.Option
                    $ { flag:       Nothing
                      , name:       pure n
                      , env:        Nothing
                      , arg:        convertArg o.arg
                      , repeatable: o.repeatable
                      }
          where
            isMatch (DE.OptionDesc (DE.Option { name = DE.Long n'   })) = n == n'
            isMatch (DE.OptionDesc (DE.Option { name = DE.Full _ n' })) = n == n'
            isMatch _ = false

    solveArg (U.OptionStack (opt@(UO.SOpt o))) adj
      = fromSubsumption <|> fromAdjacentArgOrDefault

      where
        -- | Subsumption method:
        -- | (Only applies for options w/o explicit arg)
        -- |
        -- | Concatenate the option stack into a string,
        -- | then do a substring check for each possible description.
        -- |
        -- | "armmsg"
        -- |    ~~~~
        -- |    ^^
        -- |    |`- the arg  matches - case INSENSITIVE
        -- |    `-- the flag matches - case SENSITIVE
        -- |
        -- | Should this check, yield a match, slice the matched
        -- | string off the stack and return the remainder option
        -- | stack (if any).
        -- |
        -- | The remaining options, must - in turn - be solved, too.
        -- | However, this solve is simpler as the option is proven
        -- | not to accept an argument at all.

        fromSubsumption :: Either SolveError (Slurp Node)
        fromSubsumption = do

          -- XXX: Well, this error should not be thrown, but rather,
          --      we should just not come to this code-path if this is
          --      the case. It would be an awkward user-facing error.
          if isJust o.arg
            then fail $ "Option stacks with explicit argument binding "
                     ++ "may not be subsumed."
            else pure unit

          let fs  = fromCharArray $ o.flag A.: o.stack

          maybe (fail "No description subsumed option")
                return
                -- XXX: Purescript is not lazy, so this is too expensive.
                --      We can just stop at the first `Just` value.
                (head $ catMaybes $ subsume fs <$> ds)

          where
            subsume :: String -> Desc -> Maybe (Slurp Node)
            subsume fs (DE.OptionDesc (DE.Option d)) = do
              f <- DE.getFlag d.name
              a <- DE.runArgument <$> d.arg

              -- the haystack needs to be modified, such that the
              -- the last (length a.name) characters are uppercased
              -- and hence compared case INSENSITIVELY.
              let needle = toUpper $ fromChar f ++ a.name
                  haystack = toUpper fs

              (Tuple fs o) <- if endsWith needle haystack
                then
                  let ix = S.length haystack - S.length needle
                   in if US.charAt ix fs == f
                        then return
                          $ Tuple (toCharArray (S.take (S.length fs - S.length a.name - 1) fs))
                                  (O.Option {
                                    flag:       pure f
                                  , name:       DE.getName d.name
                                  , arg:        pure $ O.Argument a
                                  , env:        d.env
                                  , repeatable: o.repeatable
                                  })
                    else Nothing
                else Nothing

              cs <- either (const Nothing)
                           (pure <<< id)
                           (matchDesc false `traverse` fs)

              return $ Keep
                     $ (Resolved <<< Option <$> toList cs)
                        ++ (singleton $ Resolved $ Option o)

            subsume _ _ = Nothing

        -- | Last flag method (w/ fallback):
        -- |
        -- | Find the last char in the option stack, look it up
        -- | in the descriptions and when it was found to have an
        -- | argument, that matches the adjacent argument (or it's
        -- | explicit binding), consume that argument and produce
        -- | a list of remaining short options.
        -- |
        -- | "armmsg=ARG"
        -- | OR:
        -- | "armmsg ARG"
        -- |       ~ ~~~
        -- |       ^  ^
        -- |       |  `-- only slurped if description found and
        -- |       |      has matching argument.
        -- |       `----- look for a description of `-g``
        -- |
        -- | The remaining options, must - in turn - be solved, too.
        -- | However, this solve is simpler as the option is proven
        -- | not to accept an argument at all.

        fromAdjacentArgOrDefault :: Either SolveError (Slurp Node)
        fromAdjacentArgOrDefault = do

          -- (flag, ...flags) -> (...flags, flag)
          (Tuple fs f) <- do
            return case A.last (o.stack) of
              Just f'  -> Tuple (o.flag A.: (fromJust $ A.init o.stack)) f'
              Nothing -> Tuple [] o.flag

          -- Look the trailing option up in the descriptions
          -- and combine it into the most complete option we
          -- can know about at this point.
          match   <- O.runOption <$> matchDesc true f
          matches <- (Option <$> _) <$> (matchDesc false `traverse` fs)

          -- Check to see if this option has an explicitly bound argument.
          -- In this case, a check to consume an adjacent arg must not take
          -- place.
          case o.arg of
            (Just exarg) -> do
              -- Note: There is no check to see if an explicit argument is
              --       the same as specified in the option descriptions for
              --       convenience to the user.
              return $ Keep
                    $ (Resolved <$> toList matches)
                      ++ (singleton $ Resolved $ Option $ O.Option match)

            Nothing ->
              -- Look ahead if any of the following arguments should be slurped.
              -- Return either `Nothing` to signify that nothing should be
              -- slurped or a value signifieng that it should be slurped, and
              -- the `isRepeated` flag should be inherited.
              let mr = do
                    guard $ not match.repeatable
                    arg' <- O.runArgument <$> match.arg
                    case adj of
                      Just (U.Positional n r) ->
                        return $ r <$ guardArgs n arg'.name
                      Just (U.Command n r) ->
                        return $ r <$ guardArgs n arg'.name
                      _ -> return $ fail
                          $ "Option-Argument specified in options-section missing"
                            ++ " -" ++ fromChar o.flag

               in case mr of
                Nothing -> do
                  return $ Keep
                    $ (Resolved <$> toList matches)
                      ++ (singleton
                          $ Resolved
                            $ Option $ O.Option match)
                Just er -> do
                  r <- er
                  return $ Slurp
                    $ (Resolved <$> toList matches)
                      ++ (singleton
                          $ Resolved
                            $ Option $ O.Option match { repeatable = r })

        guardArgs :: String -> String -> Either SolveError Boolean
        guardArgs n n' | n ^= n' = return true
        guardArgs n n' = fail
          $ "Arguments mismatch for option -" ++ fromChar o.flag ++ ": "
              ++ show n ++ " and " ++ show n'

        -- | Match a given flag with an option description.
        -- | `isTrailing` indicates if this flag is the last flag
        -- | in it's stack of flags.

        matchDesc :: Boolean -> Char -> Either SolveError O.Option
        matchDesc isTrailing f =
          case filter isMatch ds of
            xs | length xs > 1 -> fail
                    $ "Multiple option descriptions for option -"
                        ++ fromChar f

            (Cons (DE.OptionDesc (DE.Option desc)) Nil) -> do
              arg <- if isTrailing
                          then resolveOptArg o.arg desc.arg
                          else if isNothing desc.arg
                            then return Nothing
                            else fail
                              $ "Stacked option -" ++ fromChar f
                                  ++ " may not specify arguments"

              return $ O.Option { flag:       DE.getFlag desc.name
                                , name:       DE.getName desc.name
                                , arg:        arg
                                , env:        desc.env
                                , repeatable: o.repeatable
                                }

            -- default fallback: construct the option from itself alone
            _ -> return $ O.Option
                    $ { flag: pure f
                      , name: Nothing
                      , env:  Nothing
                      , arg:  if isTrailing
                                   then convertArg o.arg
                                   else Nothing
                      , repeatable: o.repeatable
                      }

          where
            isMatch (DE.OptionDesc (DE.Option { name = DE.Flag f'   })) = f == f'
            isMatch (DE.OptionDesc (DE.Option { name = DE.Full f' _ })) = f == f'
            isMatch _ = false

    -- | Resolve an option's argument name against that given in the
    -- | description, returning the most complete argument known.
    resolveOptArg :: Maybe { name :: String, optional :: Boolean }
                  -> Maybe DE.Argument
                  -> Either SolveError (Maybe O.Argument)

    resolveOptArg (Just a) Nothing = do
      return <<< pure $ O.Argument { name: a.name
                                   , optional: a.optional
                                   , default: Nothing }

    resolveOptArg Nothing (Just (DE.Argument de)) = do
      return <<< pure $ O.Argument { name:     de.name
                                   , optional: de.optional
                                   , default:  de.default }

    resolveOptArg (Just a) (Just (DE.Argument de)) = do
      return <<< pure
        $ O.Argument  { name:     de.name
                      , optional: de.optional || a.optional
                      , default:  de.default
                      }

    resolveOptArg _ _ = return Nothing

    convertArg :: Maybe { name :: String, optional :: Boolean }
               -> Maybe O.Argument
    convertArg arg = do
      a <- arg
      return $ O.Argument { name:     a.name
                          , optional: a.optional
                          , default:  Nothing }

solveUsage :: U.Usage -> List Desc -> Either SolveError Usage
solveUsage (U.Usage _ bs) ds = Usage <$> do traverse (flip solveBranch ds) bs

solve :: List U.Usage
      -> List Desc
      -> Either SolveError (List Usage)
solve us ds = traverse (flip solveUsage ds) us

-- | Resolve ambiguities by combining the parsed usage section with any parsed
-- | Option sections, as well as some best effort guessing.

module Language.Docopt.Solver where

import Prelude
import Data.Functor ((<$))
import Data.Either (Either(..), either)
import Data.Maybe.Unsafe (fromJust)
import Data.Maybe (Maybe(Nothing, Just), isNothing, maybe, isJust)
import Data.List (List(..), length, filter, singleton, toList, catMaybes, head,
                  (:))
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple))
import Control.MonadPlus (guard)
import Control.Alt ((<|>))
import Data.String (fromChar, fromCharArray, toCharArray, toUpper)
import Data.Array as A
import Data.String as S
import Data.String.Unsafe as US

import Data.String.Ext ((^=), endsWith)
import Language.Docopt.Errors (SolveError(..))
import Language.Docopt.Argument (Argument(..), Branch(..))
import Language.Docopt.Usage (Usage(..))
import Language.Docopt.Parser.Desc (Desc())
import Language.Docopt.Option as O
import Language.Docopt.Parser.Desc as DE
import Language.Docopt.Parser.Usage (Usage(..)) as U
import Language.Docopt.Parser.Usage.Argument (Branch, Argument(..)) as U
import Language.Docopt.Parser.Usage.Option as UO

data Slurp a
  = Slurp (List a)
  | Keep  (List a)

runSlurp :: Slurp Argument -> List Argument
runSlurp (Slurp xs) = xs
runSlurp (Keep  xs) = xs

fail :: forall a. String -> Either SolveError a
fail = Left <<< SolveError

solveBranch :: U.Branch                 -- ^ the usage branch
            -> List Desc                -- ^ the option descriptions
            -> Either SolveError Branch -- ^ the canonical usage branch
solveBranch as ds = Branch <$> go as
  where
    go :: U.Branch -> Either SolveError (List Argument)
    go Nil = return Nil
    go (Cons x Nil) = do runSlurp <$> do solveArgs x Nothing
    go (Cons x (Cons y xs)) = do
      m <- solveArgs x (Just y)
      case m of
        Keep  zs -> (zs ++ _) <$> go (y:xs)
        Slurp zs -> (zs ++ _) <$> go xs

    -- | Solve two adjacent arguments.
    -- | Should the first argument be an option with an argument that
    -- | matches an adjacent command or positional, consume the adjacent
    -- | argument from the input (consume).
    solveArgs :: U.Argument
              -> Maybe U.Argument
              -> Either SolveError (Slurp Argument)

    solveArgs (U.EOA) _ = Keep <<< singleton <$> return (EOA)
    solveArgs (U.Stdin) _ = Keep <<< singleton <$> return (Stdin)
    solveArgs (U.Command s r) _ = Keep <<< singleton <$> return (Command s r)
    solveArgs (U.Positional s r) _ = Keep <<< singleton <$> return (Positional s r)

    solveArgs (U.Group o bs r) _
      = Keep <<< singleton <$> do
        flip (Group o) r <$> do
          flip solveBranch ds `traverse` bs

    -- | Resolve the reference by expanding into real
    -- | options, as derived from the descriptions.
    -- |
    -- | XXX: Currently `r` is unused as all descriptions are in a flat list.
    -- |      once option descriptions are keyed, `r` can be used as the lookup
    -- |      into the map of `key => [Description]`
    solveArgs (U.Reference r) _ = do
      return $ Keep (catMaybes $ convert <$> ds)

      where
        -- | Expand `[options]` into optional groups.
        convert (DE.OptionDesc (DE.Option y)) =
          return
            $ Group
                true
                (singleton $ Branch $ singleton $ Option $
                  (O.Option { flag:       DE.getFlag y.name
                            , name:       DE.getName y.name
                            , arg:        convertDescArg y.arg
                            , env:        y.env
                            , repeatable: false
                            }))
                y.repeatable
          where
            convertDescArg (Just (DE.Argument arg)) = return $ O.Argument arg
            convertDescArg _ = Nothing

        convert _ = Nothing

    solveArgs (lopt@(U.Option (opt@(UO.LOpt o)))) adjArg = do

      -- Find a matching option description, if any.
      match <- O.runOption <$> matchDesc o.name

      -- Check to see if this option has an explicitly bound argument.
      -- In this case, a check to consume an adjacent arg must not take place.
      case o.arg of
        (Just exarg) -> do
          -- Note: There is no check to see if an explicit argument is
          --       the same as specified in the option descriptions for
          --       convenience to the user.
          return $ Keep (singleton $ Option $ O.Option match)

        Nothing -> do
          -- Look ahead if any of the following arguments should be slurped.
          -- Return either `Nothing` to signify that nothing should be slurped
          -- or a value signifieng that it should be slurped, and the
          -- `isRepeated` flag should be inherited.
          let mr = do
                guard (not o.repeatable)
                matchedArg <- O.runArgument <$> match.arg
                case adjArg of
                  Just (U.Positional n r) ->
                    return $ r <$ guardArgs n matchedArg.name
                  Just (U.Command n r) ->
                    return $ r <$ guardArgs n matchedArg.name
                  _ -> return $ fail
                      $ "Option-Argument specified in options-section missing"
                        ++ " --" ++ o.name

          case mr of
            Nothing -> do
              return $ Keep (singleton $ Option $ O.Option match)
            Just er -> do
              r <- er
              return $ Slurp (singleton $ Option $ O.Option $ match {
                                repeatable = r
                              })

      where
        guardArgs :: String -> String -> Either SolveError Boolean
        guardArgs n n' | n ^= n' = return true
        guardArgs n n' = fail
          $ "Arguments mismatch for option --" ++ o.name ++ ": "
              ++ show n ++ " and " ++ show n'

        matchDesc :: String -> Either SolveError O.Option
        matchDesc n =
          case filter isMatch ds of
            xs | length xs > 1 -> fail
              $ "Multiple option descriptions for option --" ++ n
            (Cons (DE.OptionDesc (DE.Option desc)) Nil) -> do
              arg <- resolveOptArg o.arg desc.arg
              return $ O.Option { flag:       DE.getFlag desc.name
                                , name:       DE.getName desc.name
                                , arg:        arg
                                , env:        desc.env
                                , repeatable: o.repeatable
                                }
            -- default fallback: construct the option from itself alone
            _ -> return $ O.Option
                    $ { flag:       Nothing
                      , name:       pure n
                      , env:        Nothing
                      , arg:        convertArg o.arg
                      , repeatable: o.repeatable
                      }
          where
            isMatch (DE.OptionDesc (DE.Option { name = DE.Long n'   })) = n == n'
            isMatch (DE.OptionDesc (DE.Option { name = DE.Full _ n' })) = n == n'
            isMatch _ = false

    solveArgs (U.OptionStack (opt@(UO.SOpt o))) adj = fromSubsumption
                                                  <|> fromAdjacentArgOrDefault

      where
        -- | Subsumption method:
        -- | (Only applies for options w/o explicit arg)
        -- |
        -- | Concatenate the option stack into a string,
        -- | then do a substring check for each possible description.
        -- |
        -- | "armmsg"
        -- |    ~~~~
        -- |    ^^
        -- |    |`- the arg  matches - case INSENSITIVE
        -- |    `-- the flag matches - case SENSITIVE
        -- |
        -- | Should this check, yield a match, slice the matched
        -- | string off the stack and return the remainder option
        -- | stack (if any).
        -- |
        -- | The remaining options, must - in turn - be solved, too.
        -- | However, this solve is simpler as the option is proven
        -- | not to accept an argument at all.

        fromSubsumption :: Either SolveError (Slurp Argument)
        fromSubsumption = do

          -- XXX: Well, this error should not be thrown, but rather,
          --      we should just not come to this code-path if this is
          --      the case. It would be an awkward user-facing error.
          if isJust o.arg
            then fail $ "Option stacks with explicit argument binding "
                     ++ "may not be subsumed."
            else pure unit

          let fs  = fromCharArray $ o.flag A.: o.stack

          maybe (fail "No description subsumed option")
                return
                -- XXX: Purescript is not lazy, so this is too expensive.
                --      We can just stop at the first `Just` value.
                (head $ catMaybes $ subsume fs <$> ds)

          where
            subsume :: String -> Desc -> Maybe (Slurp Argument)
            subsume fs (DE.OptionDesc (DE.Option d)) = do
              f <- DE.getFlag d.name
              a <- DE.runArgument <$> d.arg

              -- the haystack needs to be modified, such that the
              -- the last (length a.name) characters are uppercased
              -- and hence compared case INSENSITIVELY.
              let needle = toUpper $ fromChar f ++ a.name
                  haystack = toUpper fs

              (Tuple fs o) <- if endsWith needle haystack
                then
                  let ix = S.length haystack - S.length needle
                   in if US.charAt ix fs == f
                        then return
                          $ Tuple (toCharArray (S.take (S.length fs - S.length a.name - 1) fs))
                                  (O.Option {
                                    flag:       pure f
                                  , name:       DE.getName d.name
                                  , arg:        pure $ O.Argument a
                                  , env:        d.env
                                  , repeatable: o.repeatable
                                  })
                    else Nothing
                else Nothing

              cs <- either (const Nothing)
                           (pure <<< id)
                           (matchDesc false `traverse` fs)

              return $ Keep
                     $ (Option <$> toList cs) ++ (singleton $ Option o)

            subsume _ _ = Nothing

        -- | Last flag method (w/ fallback):
        -- |
        -- | Find the last char in the option stack, look it up
        -- | in the descriptions and when it was found to have an
        -- | argument, that matches the adjacent argument (or it's
        -- | explicit binding), consume that argument and produce
        -- | a list of remaining short options.
        -- |
        -- | "armmsg=ARG"
        -- | OR:
        -- | "armmsg ARG"
        -- |       ~ ~~~
        -- |       ^  ^
        -- |       |  `-- only slurped if description found and
        -- |       |      has matching argument.
        -- |       `----- look for a description of `-g``
        -- |
        -- | The remaining options, must - in turn - be solved, too.
        -- | However, this solve is simpler as the option is proven
        -- | not to accept an argument at all.

        fromAdjacentArgOrDefault :: Either SolveError (Slurp Argument)
        fromAdjacentArgOrDefault = do

          -- (flag, ...flags) -> (...flags, flag)
          (Tuple fs f) <- do
            return case A.last (o.stack) of
              Just f'  -> Tuple (o.flag A.: (fromJust $ A.init o.stack)) f'
              Nothing -> Tuple [] o.flag

          -- Look the trailing option up in the descriptions
          -- and combine it into the most complete option we
          -- can know about at this point.
          match   <- O.runOption <$> matchDesc true f
          matches <- (Option <$> _) <$> (matchDesc false `traverse` fs)

          -- Check to see if this option has an explicitly bound argument.
          -- In this case, a check to consume an adjacent arg must not take
          -- place.
          case o.arg of
            (Just exarg) -> do
              -- Note: There is no check to see if an explicit argument is
              --       the same as specified in the option descriptions for
              --       convenience to the user.
              return $ Keep
                    $ (toList matches)
                      ++ (singleton $ Option $ O.Option match)

            Nothing ->
              -- Look ahead if any of the following arguments should be slurped.
              -- Return either `Nothing` to signify that nothing should be
              -- slurped or a value signifieng that it should be slurped, and
              -- the `isRepeated` flag should be inherited.
              let mr = do
                    guard $ not match.repeatable
                    arg' <- O.runArgument <$> match.arg
                    case adj of
                      Just (U.Positional n r) ->
                        return $ r <$ guardArgs n arg'.name
                      Just (U.Command n r) ->
                        return $ r <$ guardArgs n arg'.name
                      _ -> return $ fail
                          $ "Option-Argument specified in options-section missing"
                            ++ " -" ++ fromChar o.flag

               in case mr of
                Nothing -> do
                  return $ Keep
                    $ (toList matches) ++ (singleton $ Option $ O.Option match)
                Just er -> do
                  r <- er
                  return $ Slurp
                    $ (toList matches) ++ (singleton $ Option $ O.Option match {
                        repeatable = r
                      })

        guardArgs :: String -> String -> Either SolveError Boolean
        guardArgs n n' | n ^= n' = return true
        guardArgs n n' = fail
          $ "Arguments mismatch for option -" ++ fromChar o.flag ++ ": "
              ++ show n ++ " and " ++ show n'

        -- | Match a given flag with an option description.
        -- | `isTrailing` indicates if this flag is the last flag
        -- | in it's stack of flags.

        matchDesc :: Boolean -> Char -> Either SolveError O.Option
        matchDesc isTrailing f =
          case filter isMatch ds of
            xs | length xs > 1 -> fail
                    $ "Multiple option descriptions for option -"
                        ++ fromChar f

            (Cons (DE.OptionDesc (DE.Option desc)) Nil) -> do
              arg <- if isTrailing
                          then resolveOptArg o.arg desc.arg
                          else if isNothing desc.arg
                            then return Nothing
                            else fail
                              $ "Stacked option -" ++ fromChar f
                                  ++ " may not specify arguments"

              return $ O.Option { flag:       DE.getFlag desc.name
                                , name:       DE.getName desc.name
                                , arg:        arg
                                , env:        desc.env
                                , repeatable: o.repeatable
                                }

            -- default fallback: construct the option from itself alone
            _ -> return $ O.Option
                    $ { flag: pure f
                      , name: Nothing
                      , env:  Nothing
                      , arg:  if isTrailing
                                   then convertArg o.arg
                                   else Nothing
                      , repeatable: o.repeatable
                      }

          where
            isMatch (DE.OptionDesc (DE.Option { name = DE.Flag f'   })) = f == f'
            isMatch (DE.OptionDesc (DE.Option { name = DE.Full f' _ })) = f == f'
            isMatch _ = false

    -- | Resolve an option's argument name against that given in the
    -- | description, returning the most complete argument known.
    resolveOptArg :: Maybe { name :: String, optional :: Boolean }
                  -> Maybe DE.Argument
                  -> Either SolveError (Maybe O.Argument)

    resolveOptArg (Just a) Nothing = do
      return <<< pure $ O.Argument { name: a.name
                                   , optional: a.optional
                                   , default: Nothing }

    resolveOptArg Nothing (Just (DE.Argument de)) = do
      return <<< pure $ O.Argument { name:     de.name
                                   , optional: de.optional
                                   , default:  de.default }

    resolveOptArg (Just a) (Just (DE.Argument de)) = do
      return <<< pure
        $ O.Argument  { name:     de.name
                      , optional: de.optional || a.optional
                      , default:  de.default
                      }

    resolveOptArg _ _ = return Nothing

    convertArg :: Maybe { name :: String, optional :: Boolean }
               -> Maybe O.Argument
    convertArg arg = do
      a <- arg
      return $ O.Argument { name:     a.name
                          , optional: a.optional
                          , default:  Nothing }

solveUsage :: U.Usage -> List Desc -> Either SolveError Usage
solveUsage (U.Usage _ bs) ds = Usage <$> do traverse (flip solveBranch ds) bs

solve :: List U.Usage
      -> List Desc
      -> Either SolveError (List Usage)
solve us ds = traverse (flip solveUsage ds) us


Add wrapper for parent

Add wrapper for parent

module Control.Monad.JQuery where

import Data.Foreign
import Control.Monad.Eff

-- An effect type which indicates DOM manipulation
foreign import data DOM :: !

-- The jQuery wrapper type
foreign import data JQuery :: *

-- Type of jQuery event objects
foreign import data JQueryEvent :: *

-- $(document).ready(function() { ... })
foreign import ready
  "function ready(func) { \
  \  return function () { \
  \    jQuery(document).ready(func); \
  \  }; \
  \}" :: forall eff a. Eff eff a -> Eff (dom :: DOM | eff) JQuery

-- Wrapper function for jQuery selection $('..')
foreign import select
  "function select(selector) { \
  \  return function () { \
  \    return jQuery(selector); \
  \  }; \
  \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

-- .find(...)
foreign import find
  "function select(selector) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.find(selector); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .parent()
foreign import parent
  "function parent(ob) { \
  \  return function () { \
  \    return ob.parent(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- Wrapper function for jQuery creation e.g. $('<div>')
foreign import create
  "function create(html) { \
  \  return function () { \
  \    return jQuery(html); \
  \  }; \
  \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

-- .attr({ ... })
foreign import setAttr
  "function setAttr(attr) { \
  \  return function(val) { \
  \    return function(ob) { \
  \      return function () { \
  \        return ob.attr(attr, val);\
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff a. String -> a -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .attr({ ... })
foreign import attr
  "function attr(attrs) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.attr(attrs);\
  \    }; \
  \  }; \
  \}" :: forall eff attr. { | attr } -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .css({ ... })
foreign import css
  "function css(props) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.css(props); \
  \    }; \
  \  }; \
  \}" :: forall eff css. { | css } -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .hasClass(...)
foreign import hasClass
  "function hasClass(cls) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.hasClass(cls); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) Boolean

-- .addClass(...)
foreign import addClass
  "function addClass(cls) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.addClass(cls); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .removeClass(...)
foreign import removeClass
  "function removeClass(cls) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.removeClass(cls); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .prop({ ... })
foreign import setProp
  "function setProp(p) { \
  \  return function(val) { \
  \    return function(ob) { \
  \      return function () { \
  \        return ob.prop(p, val);\
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall a eff. String -> a -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .prop({ ... })
foreign import getProp
  "function getProp(p) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.prop(p);\
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) Foreign

-- .append(...)
foreign import append
  "function append(ob1) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.append(ob1); \
  \    }; \
  \  }; \
  \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

foreign import appendAtIndex
  "function appendAtIndex(i) { \
  \  return function(ob1) { \
  \    return function(ob) { \
  \      return function () { \
  \        var children = ob.children();\
  \        if (children.length > 0) {\
  \          if (i <= 0) {\
  \             ob.prepend(ob1);\
  \          } else if (i >= children.length) {\
  \             ob.append(ob1);\
  \          } else {\
  \             ob1.insertBefore(jQuery(children[i]));\
  \          }\
  \          return ob;\
  \        } else {\
  \          return ob.append(ob1); \
  \        }\
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff. Number -> JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .remove()
foreign import remove
  "function remove(ob) { \
  \  return function () { \
  \    return ob.remove(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .empty()
foreign import clear
  "function clear(ob) { \
  \  return function () { \
  \    return ob.empty(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .before(...)
foreign import before
  "function before(ob) { \
  \  return function(ob1) { \
  \    return function () { \
  \      return ob1.before(ob); \
  \    }; \
  \  }; \
  \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .append(...)
foreign import appendText
  "function appendText(s) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.append(s); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- Get the document body
foreign import body
  "function body() { \
  \  return jQuery(document.body); \
  \}" :: forall eff. Eff (dom :: DOM | eff) JQuery

-- Get the text content of an element
foreign import getText
  "function getText(ob) { \
  \  return function() { \
  \    return ob.text(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

-- Set the text content of an element
foreign import setText
  "function setText(text) { \
  \  return function(ob) { \
  \    return function() { \
  \      return ob.text(text); \
  \    };\
  \  };\
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- Get the value of a text field
foreign import getValue
  "function getValue(ob) { \
  \  return function() { \
  \    return ob.val(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) Foreign

-- Set the value of a text field
foreign import setValue
  "function setValue(val) { \
  \  return function(ob) { \
  \    return function() { \
  \      return ob.val(val); \
  \    }; \
  \  }; \
  \}" :: forall eff a. a -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- Register an event handler
foreign import on
  "function on(evt) { \
  \  return function(act) { \
  \    return function(ob) { \
  \      return function() { \
  \        return ob.on(evt, function(e) { \
  \          act(e)(jQuery(this))(); \
  \        }); \
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff a. String -> (JQueryEvent -> JQuery -> Eff eff a) -> JQuery ->
         Eff (dom :: DOM | eff) JQuery

-- Register an event handler
foreign import on'
  "function on$prime(evt) { \
  \  return function(sel) { \
  \    return function(act) { \
  \      return function(ob) { \
  \        return function() { \
  \          return ob.on(evt, sel, function(e) { \
  \            act(e)(jQuery(this))(); \
  \          }); \
  \        }; \
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff a. String -> String -> (JQueryEvent -> JQuery -> Eff eff a) -> JQuery ->
         Eff (dom :: DOM | eff) JQuery

foreign import preventDefault
  "function preventDefault(e) { \
  \  return function() { \
  \    e.preventDefault(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit

foreign import stopPropagation
  "function stopPropagation(e) { \
  \  return function() { \
  \    e.stopPropagation(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit

foreign import stopImmediatePropagation
  "function stopImmediatePropagation(e) { \
  \  return function() { \
  \    e.stopImmediatePropagation(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit

module Control.Monad.JQuery where

import Data.Foreign
import Control.Monad.Eff

-- An effect type which indicates DOM manipulation
foreign import data DOM :: !

-- The jQuery wrapper type
foreign import data JQuery :: *

-- Type of jQuery event objects
foreign import data JQueryEvent :: *

-- $(document).ready(function() { ... })
foreign import ready
  "function ready(func) { \
  \  return function () { \
  \    jQuery(document).ready(func); \
  \  }; \
  \}" :: forall eff a. Eff eff a -> Eff (dom :: DOM | eff) JQuery

-- Wrapper function for jQuery selection $('..')
foreign import select
  "function select(selector) { \
  \  return function () { \
  \    return jQuery(selector); \
  \  }; \
  \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

-- .find(...)
foreign import find
  "function select(selector) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.find(selector); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- Wrapper function for jQuery creation e.g. $('<div>')
foreign import create
  "function create(html) { \
  \  return function () { \
  \    return jQuery(html); \
  \  }; \
  \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

-- .attr({ ... })
foreign import setAttr
  "function setAttr(attr) { \
  \  return function(val) { \
  \    return function(ob) { \
  \      return function () { \
  \        return ob.attr(attr, val);\
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff a. String -> a -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .attr({ ... })
foreign import attr
  "function attr(attrs) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.attr(attrs);\
  \    }; \
  \  }; \
  \}" :: forall eff attr. { | attr } -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .css({ ... })
foreign import css
  "function css(props) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.css(props); \
  \    }; \
  \  }; \
  \}" :: forall eff css. { | css } -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .hasClass(...)
foreign import hasClass
  "function hasClass(cls) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.hasClass(cls); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) Boolean

-- .addClass(...)
foreign import addClass
  "function addClass(cls) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.addClass(cls); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .removeClass(...)
foreign import removeClass
  "function removeClass(cls) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.removeClass(cls); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .prop({ ... })
foreign import setProp
  "function setProp(p) { \
  \  return function(val) { \
  \    return function(ob) { \
  \      return function () { \
  \        return ob.prop(p, val);\
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall a eff. String -> a -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .prop({ ... })
foreign import getProp
  "function getProp(p) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.prop(p);\
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) Foreign

-- .append(...)
foreign import append
  "function append(ob1) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.append(ob1); \
  \    }; \
  \  }; \
  \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

foreign import appendAtIndex
  "function appendAtIndex(i) { \
  \  return function(ob1) { \
  \    return function(ob) { \
  \      return function () { \
  \        var children = ob.children();\
  \        if (children.length > 0) {\
  \          if (i <= 0) {\
  \             ob.prepend(ob1);\
  \          } else if (i >= children.length) {\
  \             ob.append(ob1);\
  \          } else {\
  \             ob1.insertBefore(jQuery(children[i]));\
  \          }\
  \          return ob;\
  \        } else {\
  \          return ob.append(ob1); \
  \        }\
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff. Number -> JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .remove()
foreign import remove
  "function remove(ob) { \
  \  return function () { \
  \    return ob.remove(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .empty()
foreign import clear
  "function clear(ob) { \
  \  return function () { \
  \    return ob.empty(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

-- .before(...)
foreign import before
  "function before(ob) { \
  \  return function(ob1) { \
  \    return function () { \
  \      return ob1.before(ob); \
  \    }; \
  \  }; \
  \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .append(...)
foreign import appendText
  "function appendText(s) { \
  \  return function(ob) { \
  \    return function () { \
  \      return ob.append(s); \
  \    }; \
  \  }; \
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- Get the document body
foreign import body
  "function body() { \
  \  return jQuery(document.body); \
  \}" :: forall eff. Eff (dom :: DOM | eff) JQuery

-- Get the text content of an element
foreign import getText
  "function getText(ob) { \
  \  return function() { \
  \    return ob.text(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

-- Set the text content of an element
foreign import setText
  "function setText(text) { \
  \  return function(ob) { \
  \    return function() { \
  \      return ob.text(text); \
  \    };\
  \  };\
  \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- Get the value of a text field
foreign import getValue
  "function getValue(ob) { \
  \  return function() { \
  \    return ob.val(); \
  \  }; \
  \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) Foreign

-- Set the value of a text field
foreign import setValue
  "function setValue(val) { \
  \  return function(ob) { \
  \    return function() { \
  \      return ob.val(val); \
  \    }; \
  \  }; \
  \}" :: forall eff a. a -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- Register an event handler
foreign import on
  "function on(evt) { \
  \  return function(act) { \
  \    return function(ob) { \
  \      return function() { \
  \        return ob.on(evt, function(e) { \
  \          act(e)(jQuery(this))(); \
  \        }); \
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff a. String -> (JQueryEvent -> JQuery -> Eff eff a) -> JQuery ->
         Eff (dom :: DOM | eff) JQuery

-- Register an event handler
foreign import on'
  "function on$prime(evt) { \
  \  return function(sel) { \
  \    return function(act) { \
  \      return function(ob) { \
  \        return function() { \
  \          return ob.on(evt, sel, function(e) { \
  \            act(e)(jQuery(this))(); \
  \          }); \
  \        }; \
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff a. String -> String -> (JQueryEvent -> JQuery -> Eff eff a) -> JQuery ->
         Eff (dom :: DOM | eff) JQuery

foreign import preventDefault
  "function preventDefault(e) { \
  \  return function() { \
  \    e.preventDefault(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit

foreign import stopPropagation
  "function stopPropagation(e) { \
  \  return function() { \
  \    e.stopPropagation(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit

foreign import stopImmediatePropagation
  "function stopImmediatePropagation(e) { \
  \  return function() { \
  \    e.stopImmediatePropagation(); \
  \ } \
  \}" :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Unit


Update rxjs

Update rxjs

module OutWatch.Dom.SnabbdomHelpers (createVNodeData, emittersToEventObject, Properties) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff, unsafePerformEff)
import DOM (DOM)
import DOM.Event.Event (Event, target)
import DOM.HTML.HTMLInputElement (checked, value, valueAsNumber)
import DOM.HTML.Types (HTMLInputElement)
import DOM.Node.Types (Element)
import Data.Array (index)
import Data.Array (fromFoldable) as Array
import Data.Foldable (traverse_)
import Data.List (List, groupBy)
import Data.List.NonEmpty (NonEmptyList, head)
import Data.Maybe (Maybe(..))
import Data.StrMap (StrMap, fromFoldable, union)
import Data.Tuple (Tuple(..), fst, snd)
import OutWatch.Dom.VDomModifier (Attribute, DestroyHook, Emitter(..), InsertHook, UpdateHook, VNode, toProxy)
import OutWatch.Helpers.Helpers (forEachMaybe, tupleMaybes)
import OutWatch.Helpers.Promise (Promise, foreach, success)
import OutWatch.Helpers.Promise (empty) as Promise
import OutWatch.Sink (Observer(..))
import RxJS.Observable (Observable, RX, pairwise, startWith, subscribeNext)
import RxJS.Subscription (Subscription, unsubscribe)
import Snabbdom (VDOM, VNodeData, VNodeEventObject, VNodeProxy(..), getElement, h, patch, toVNodeEventObject, toVNodeHookObjectProxy, updateValueHook)
import Unsafe.Coerce (unsafeCoerce)

type Properties e =
  { attrs :: List Attribute
  , inserts :: List (InsertHook e)
  , destroys :: List (DestroyHook e)
  , updates :: List (UpdateHook e)
  }

emittersToEventObject :: forall e. List (Emitter e) -> VNodeEventObject e
emittersToEventObject list =
  let grouped = groupBy emittersEqual list
      tupled =  nonEmptyToTuple <$> grouped
      strMap = fromFoldable tupled
  in toVNodeEventObject strMap

createVNodeData :: forall e. Boolean -> Observable (Tuple (List Attribute) (List (VNode e)))
  -> Properties e -> VNodeEventObject e -> Boolean -> VNodeData e
createVNodeData recsNonEmpty changables props handlers valueExists =
  if recsNonEmpty then
    createReceiverVNodeData changables valueExists props handlers
  else
    createSimpleVNodeData props handlers

subscriberToEff :: forall e. Element -> InsertHook e -> Eff e Unit
subscriberToEff elem (Observer sink) =
  sink elem

updateSubscriberToEff :: forall e. Tuple Element Element -> UpdateHook e -> Eff e Unit
updateSubscriberToEff elems (Observer sink) =
  sink elems

mapHookToEff :: forall e. List (Observer e Element) -> Element -> Eff e Unit
mapHookToEff list elem =
  traverse_ (subscriberToEff elem) list

-- | Takes a Hook and returns a function from VNodeProxy to an Effect.
hookToSnabbdom :: forall e. List (Observer e Element) -> VNodeProxy e -> Eff e Unit
hookToSnabbdom list proxy =
  let maybe = map (\elem -> mapHookToEff list elem) (getElement proxy)
  in forEachMaybe maybe

createSimpleVNodeData :: forall e. Properties e -> VNodeEventObject e -> VNodeData e
createSimpleVNodeData { attrs , inserts , destroys , updates } eventObject =
  let attributes = attrsToSnabbdom attrs
      insertHook = Just (hookToSnabbdom inserts)
      deleteHook = Just (hookToSnabbdom destroys)
      updateHook = Just (createUpdateHook updates)

      hookObject = {insert: insertHook, destroy: deleteHook, update: updateHook}
  in {attrs: attributes, on: eventObject, hook: toVNodeHookObjectProxy hookObject}

createDestroyHook :: forall e. Promise e Subscription -> List (DestroyHook e) -> VNodeProxy e -> Eff e Unit
createDestroyHook promise hooks proxy =
  let callbackEff = hooksToEff hooks proxy
      promisedEff = foreach promise unsubscribe
  in do
    callbackEff
    promisedEff

createSubscription :: forall e. Observable (Tuple (List Attribute) (List (VNode e))) -> VNodeProxy e -> Eff (rx :: RX | e) Subscription
createSubscription changables proxy = changables
  # map (changablesToProxy proxy)
  # startWith proxy
  # pairwise
  # subscribeNext (unsafeCoerce patchPair)

createInsertHook :: forall e. Observable (Tuple (List Attribute) (List (VNode e)))
  -> Promise e Subscription -> List (InsertHook e) -> VNodeProxy e -> Eff e Unit
createInsertHook changables promise hooks proxy =
  let subscriptionEff = unsafeCoerceEff (createSubscription changables proxy)
      callbackEff = hooksToEff hooks proxy
  in do
    sub <- subscriptionEff
    unsafeCoerceEff (success promise sub)
    (unsafeCoerceEff callbackEff)

-- | Takes a list of Update Hooks and returns a function from VNodeProxy to VNodeProxy to an Effect.
createUpdateHook :: forall e. List (UpdateHook e) -> VNodeProxy e -> VNodeProxy e -> Eff e Unit
createUpdateHook hooks old cur =
  let tupled = tupleMaybes (getElement old) (getElement cur)
      maybe = map (updateHooksToEff hooks) tupled
  in forEachMaybe maybe

createUpdateHookWithValue :: forall e. List (UpdateHook e) -> VNodeProxy e -> VNodeProxy e -> Eff e Unit
createUpdateHookWithValue hooks old cur =
  let tupled = tupleMaybes (getElement old) (getElement cur)
      maybe = map (updateHooksToEff hooks) tupled
  in do
    updateValueHook old cur
    forEachMaybe maybe

updateHooksToEff :: forall e. List (UpdateHook e) -> Tuple Element Element -> Eff e Unit
updateHooksToEff hooks tuple =
  traverse_ (callNextUpdate tuple) hooks

callNextUpdate :: forall e. Tuple Element Element -> UpdateHook e -> Eff e Unit
callNextUpdate tuple (Observer sink) = sink tuple

hooksToEff :: forall e. List (Observer e Element) -> VNodeProxy e -> Eff e Unit
hooksToEff hooks proxy =
  let callback = hooksToCallback hooks proxy
      maybe = (map callback (getElement proxy))
  in forEachMaybe maybe

hooksToCallback :: forall e. List (InsertHook e) -> VNodeProxy e -> Element -> Eff e Unit
hooksToCallback hooks (VNodeProxy proxy) element =
  traverse_ (subscriberToEff element) hooks

createReceiverVNodeData :: forall e. Observable (Tuple (List Attribute) (List (VNode e)))
  -> Boolean -> Properties e -> VNodeEventObject e -> VNodeData e
createReceiverVNodeData changables valueExists props handlers =
  let attrs = attrsToSnabbdom props.attrs
      promise = Promise.empty
      insert = Just (createInsertHook changables promise props.inserts)
      destroy = Just (createDestroyHook promise props.destroys)
      update = Just (if (valueExists) then createUpdateHookWithValue props.updates else createUpdateHook props.updates)
      hookObject = toVNodeHookObjectProxy { insert , destroy, update }
   in { attrs : attrs , on : handlers , hook : hookObject}

patchPair :: forall e. Array (VNodeProxy e) -> Eff (vdom :: VDOM | e) Unit
patchPair arr =
  let maybeFirst = index arr 0
      maybeSecond = index arr 1
      maybeTuple = tupleMaybes maybeFirst maybeSecond
  in forEachMaybe (map (\tuple -> patch (fst tuple) (snd tuple)) maybeTuple)

changablesToProxy :: forall e. VNodeProxy e -> Tuple (List Attribute) (List (VNode e)) -> VNodeProxy e
changablesToProxy (VNodeProxy proxy)(Tuple attributes vnodes) =
  let updatedData = updateVNodeData attributes proxy.data
      updatedChildren =  proxy.children <> (Array.fromFoldable (map toProxy vnodes))
  in h proxy.sel updatedData updatedChildren

updateVNodeData :: forall e. List Attribute -> VNodeData e -> VNodeData e
updateVNodeData list vdata =
  let strMap = attrsToSnabbdom list
  in vdata { attrs = (union strMap vdata.attrs) }

emitterToEventFn :: forall e. Emitter e -> (Event -> Eff e Unit)
emitterToEventFn (EventEmitter { sink : (Observer fn)}) = fn
emitterToEventFn (InputEventEmitter { sink : (Observer fn)}) = unsafeCoerce fn
emitterToEventFn (MouseEventEmitter { sink : (Observer fn)}) = unsafeCoerce fn
emitterToEventFn (DragEventEmitter { sink : (Observer fn)}) = unsafeCoerce fn
emitterToEventFn (KeyboardEventEmitter { sink : (Observer fn)}) = unsafeCoerce fn
emitterToEventFn (StringEventEmitter { sink : (Observer fn)}) = callbackToEventFn fn value -- fn :: String -> Eff e Unit
emitterToEventFn (NumberEventEmitter { sink : (Observer fn)}) = callbackToEventFn fn valueAsNumber
emitterToEventFn (BoolEventEmitter { sink : (Observer fn)}) = callbackToEventFn fn checked

eventToInputElement :: Event -> HTMLInputElement
eventToInputElement ev = unsafeCoerce (target ev)

constantEmitterToEventFn :: forall a e. a -> Observer e a -> Event -> Eff e Unit
constantEmitterToEventFn constant (Observer fn) ev =
  fn constant

callbackToEventFn :: forall a e. (a -> Eff e Unit) -> (HTMLInputElement -> Eff (dom :: DOM) a) -> Event -> Eff e Unit
callbackToEventFn callback extractor ev =
  let inputValue = unsafePerformEff (extractor (eventToInputElement ev))
  in callback inputValue

combineEventFns :: forall e. NonEmptyList (Event -> Eff e Unit) -> Event -> Eff e Unit
combineEventFns list ev = traverse_ (\fn -> fn ev) list

emittersToEventFn :: forall e. NonEmptyList (Emitter e) -> Event -> Eff e Unit
emittersToEventFn list ev =
  let mapped = emitterToEventFn <$> list
  in combineEventFns mapped ev

emittersEqual :: forall e1 e2. Emitter e1 -> Emitter e2 -> Boolean
emittersEqual a b = getEventType a == getEventType b

getEventType :: forall e. Emitter e -> String
getEventType emitter = case emitter of
  (EventEmitter e) -> e.event
  (InputEventEmitter e) -> e.event
  (MouseEventEmitter e) -> e.event
  (DragEventEmitter e) -> e.event
  (KeyboardEventEmitter e) -> e.event
  (StringEventEmitter e) -> e.event
  (BoolEventEmitter e) -> e.event
  (NumberEventEmitter e) -> e.event

nonEmptyToTuple :: forall e. NonEmptyList (Emitter e) -> Tuple String (Event -> Eff e Unit)
nonEmptyToTuple list = Tuple (getEventType (head list)) (emittersToEventFn list)

attrsToSnabbdom :: List Attribute -> StrMap String
attrsToSnabbdom list =
  let tupled = map (\a -> Tuple a.name a.value) list
  in fromFoldable tupled

module OutWatch.Dom.SnabbdomHelpers (createVNodeData, emittersToEventObject, Properties) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff, unsafePerformEff)
import DOM (DOM)
import DOM.Event.Event (Event, target)
import DOM.HTML.HTMLInputElement (checked, value, valueAsNumber)
import DOM.HTML.Types (HTMLInputElement)
import DOM.Node.Types (Element)
import Data.Array (index)
import Data.Array (fromFoldable) as Array
import Data.Foldable (traverse_)
import Data.List (List, groupBy)
import Data.List.NonEmpty (NonEmptyList, head)
import Data.Maybe (Maybe(..))
import Data.StrMap (StrMap, fromFoldable, union)
import Data.Tuple (Tuple(..), fst, snd)
import OutWatch.Helpers.Helpers (forEachMaybe, tupleMaybes)
import OutWatch.Helpers.Promise (Promise, foreach, success)
import OutWatch.Helpers.Promise (empty) as Promise
import RxJS.Observable (Observable, pairwise, startWith, subscribeNext)
import RxJS.Subscription (Subscription, unsubscribe)
import OutWatch.Sink (Observer(..))
import Snabbdom (VDOM, VNodeData, VNodeEventObject, VNodeProxy(..), getElement, h, patch, toVNodeEventObject, toVNodeHookObjectProxy, updateValueHook)
import Unsafe.Coerce (unsafeCoerce)
import OutWatch.Dom.VDomModifier (Attribute, DestroyHook, Emitter(..), InsertHook, UpdateHook, VNode, toProxy)

type Properties e =
  { attrs :: List Attribute
  , inserts :: List (InsertHook e)
  , destroys :: List (DestroyHook e)
  , updates :: List (UpdateHook e)
  }

emittersToEventObject :: forall e. List (Emitter e) -> VNodeEventObject e
emittersToEventObject list =
  let grouped = groupBy emittersEqual list
      tupled =  nonEmptyToTuple <$> grouped
      strMap = fromFoldable tupled
  in toVNodeEventObject strMap

createVNodeData :: forall e. Boolean -> Observable (Tuple (List Attribute) (List (VNode e)))
  -> Properties e -> VNodeEventObject e -> Boolean -> VNodeData e
createVNodeData recsNonEmpty changables props handlers valueExists =
  if recsNonEmpty then
    createReceiverVNodeData changables valueExists props handlers
  else
    createSimpleVNodeData props handlers

subscriberToEff :: forall e. Element -> InsertHook e -> Eff e Unit
subscriberToEff elem (Observer sink) =
  sink elem

updateSubscriberToEff :: forall e. Tuple Element Element -> UpdateHook e -> Eff e Unit
updateSubscriberToEff elems (Observer sink) =
  sink elems

mapHookToEff :: forall e. List (Observer e Element) -> Element -> Eff e Unit
mapHookToEff list elem =
  traverse_ (subscriberToEff elem) list

-- | Takes a Hook and returns a function from VNodeProxy to an Effect.
hookToSnabbdom :: forall e. List (Observer e Element) -> VNodeProxy e -> Eff e Unit
hookToSnabbdom list proxy =
  let maybe = map (\elem -> mapHookToEff list elem) (getElement proxy)
  in forEachMaybe maybe

createSimpleVNodeData :: forall e. Properties e -> VNodeEventObject e -> VNodeData e
createSimpleVNodeData { attrs , inserts , destroys , updates } eventObject =
  let attributes = attrsToSnabbdom attrs
      insertHook = Just (hookToSnabbdom inserts)
      deleteHook = Just (hookToSnabbdom destroys)
      updateHook = Just (createUpdateHook updates)

      hookObject = {insert: insertHook, destroy: deleteHook, update: updateHook}
  in {attrs: attributes, on: eventObject, hook: toVNodeHookObjectProxy hookObject}

createDestroyHook :: forall e. Promise e Subscription -> List (DestroyHook e) -> VNodeProxy e -> Eff e Unit
createDestroyHook promise hooks proxy =
  let callbackEff = hooksToEff hooks proxy
      promisedEff = foreach promise unsubscribe
  in do
    callbackEff
    promisedEff

createSubscription :: forall e. Observable (Tuple (List Attribute) (List (VNode e))) -> VNodeProxy e -> Eff e Subscription
createSubscription changables proxy = changables
  # map (changablesToProxy proxy)
  # startWith proxy
  # pairwise
  # subscribeNext (unsafeCoerce patchPair)

createInsertHook :: forall e. Observable (Tuple (List Attribute) (List (VNode e)))
  -> Promise e Subscription -> List (InsertHook e) -> VNodeProxy e -> Eff e Unit
createInsertHook changables promise hooks proxy =
  let subscriptionEff = createSubscription changables proxy
      callbackEff = hooksToEff hooks proxy
  in do
    sub <- subscriptionEff
    unsafeCoerceEff (success promise sub)
    (unsafeCoerceEff callbackEff)

-- | Takes a list of Update Hooks and returns a function from VNodeProxy to VNodeProxy to an Effect.
createUpdateHook :: forall e. List (UpdateHook e) -> VNodeProxy e -> VNodeProxy e -> Eff e Unit
createUpdateHook hooks old cur =
  let tupled = tupleMaybes (getElement old) (getElement cur)
      maybe = map (updateHooksToEff hooks) tupled
  in forEachMaybe maybe

createUpdateHookWithValue :: forall e. List (UpdateHook e) -> VNodeProxy e -> VNodeProxy e -> Eff e Unit
createUpdateHookWithValue hooks old cur =
  let tupled = tupleMaybes (getElement old) (getElement cur)
      maybe = map (updateHooksToEff hooks) tupled
  in do
    updateValueHook old cur
    forEachMaybe maybe

updateHooksToEff :: forall e. List (UpdateHook e) -> Tuple Element Element -> Eff e Unit
updateHooksToEff hooks tuple =
  traverse_ (callNextUpdate tuple) hooks

callNextUpdate :: forall e. Tuple Element Element -> UpdateHook e -> Eff e Unit
callNextUpdate tuple (Observer sink) = sink tuple

hooksToEff :: forall e. List (Observer e Element) -> VNodeProxy e -> Eff e Unit
hooksToEff hooks proxy =
  let callback = hooksToCallback hooks proxy
      maybe = (map callback (getElement proxy))
  in forEachMaybe maybe

hooksToCallback :: forall e. List (InsertHook e) -> VNodeProxy e -> Element -> Eff e Unit
hooksToCallback hooks (VNodeProxy proxy) element =
  traverse_ (subscriberToEff element) hooks

createReceiverVNodeData :: forall e. Observable (Tuple (List Attribute) (List (VNode e)))
  -> Boolean -> Properties e -> VNodeEventObject e -> VNodeData e
createReceiverVNodeData changables valueExists props handlers =
  let attrs = attrsToSnabbdom props.attrs
      promise = Promise.empty
      insert = Just (createInsertHook changables promise props.inserts)
      destroy = Just (createDestroyHook promise props.destroys)
      update = Just (if (valueExists) then createUpdateHookWithValue props.updates else createUpdateHook props.updates)
      hookObject = toVNodeHookObjectProxy { insert , destroy, update }
   in { attrs : attrs , on : handlers , hook : hookObject}

patchPair :: forall e. Array (VNodeProxy e) -> Eff (vdom :: VDOM | e) Unit
patchPair arr =
  let maybeFirst = index arr 0
      maybeSecond = index arr 1
      maybeTuple = tupleMaybes maybeFirst maybeSecond
  in forEachMaybe (map (\tuple -> patch (fst tuple) (snd tuple)) maybeTuple)

changablesToProxy :: forall e. VNodeProxy e -> Tuple (List Attribute) (List (VNode e)) -> VNodeProxy e
changablesToProxy (VNodeProxy proxy)(Tuple attributes vnodes) =
  let updatedData = updateVNodeData attributes proxy.data
      updatedChildren =  proxy.children <> (Array.fromFoldable (map toProxy vnodes))
  in h proxy.sel updatedData updatedChildren

updateVNodeData :: forall e. List Attribute -> VNodeData e -> VNodeData e
updateVNodeData list vdata =
  let strMap = attrsToSnabbdom list
  in vdata { attrs = (union strMap vdata.attrs) }

emitterToEventFn :: forall e. Emitter e -> (Event -> Eff e Unit)
emitterToEventFn (EventEmitter { sink : (Observer fn)}) = fn
emitterToEventFn (InputEventEmitter { sink : (Observer fn)}) = unsafeCoerce fn
emitterToEventFn (MouseEventEmitter { sink : (Observer fn)}) = unsafeCoerce fn
emitterToEventFn (DragEventEmitter { sink : (Observer fn)}) = unsafeCoerce fn
emitterToEventFn (KeyboardEventEmitter { sink : (Observer fn)}) = unsafeCoerce fn
emitterToEventFn (StringEventEmitter { sink : (Observer fn)}) = callbackToEventFn fn value -- fn :: String -> Eff e Unit
emitterToEventFn (NumberEventEmitter { sink : (Observer fn)}) = callbackToEventFn fn valueAsNumber
emitterToEventFn (BoolEventEmitter { sink : (Observer fn)}) = callbackToEventFn fn checked

eventToInputElement :: Event -> HTMLInputElement
eventToInputElement ev = unsafeCoerce (target ev)

constantEmitterToEventFn :: forall a e. a -> Observer e a -> Event -> Eff e Unit
constantEmitterToEventFn constant (Observer fn) ev =
  fn constant

callbackToEventFn :: forall a e. (a -> Eff e Unit) -> (HTMLInputElement -> Eff (dom :: DOM) a) -> Event -> Eff e Unit
callbackToEventFn callback extractor ev =
  let inputValue = unsafePerformEff (extractor (eventToInputElement ev))
  in callback inputValue

combineEventFns :: forall e. NonEmptyList (Event -> Eff e Unit) -> Event -> Eff e Unit
combineEventFns list ev = traverse_ (\fn -> fn ev) list

emittersToEventFn :: forall e. NonEmptyList (Emitter e) -> Event -> Eff e Unit
emittersToEventFn list ev =
  let mapped = emitterToEventFn <$> list
  in combineEventFns mapped ev

emittersEqual :: forall e1 e2. Emitter e1 -> Emitter e2 -> Boolean
emittersEqual a b = getEventType a == getEventType b

getEventType :: forall e. Emitter e -> String
getEventType emitter = case emitter of
  (EventEmitter e) -> e.event
  (InputEventEmitter e) -> e.event
  (MouseEventEmitter e) -> e.event
  (DragEventEmitter e) -> e.event
  (KeyboardEventEmitter e) -> e.event
  (StringEventEmitter e) -> e.event
  (BoolEventEmitter e) -> e.event
  (NumberEventEmitter e) -> e.event

nonEmptyToTuple :: forall e. NonEmptyList (Emitter e) -> Tuple String (Event -> Eff e Unit)
nonEmptyToTuple list = Tuple (getEventType (head list)) (emittersToEventFn list)

attrsToSnabbdom :: List Attribute -> StrMap String
attrsToSnabbdom list =
  let tupled = map (\a -> Tuple a.name a.value) list
  in fromFoldable tupled


Fix example

Fix example

module Complex where

import Prelude
import Data.Array
import Data.Either
import Data.Foreign
import Data.Maybe
import Control.Monad.Eff

foreign import showUnsafe
  "var showUnsafe = JSON.stringify;" :: forall a. a -> String

data SomeObject = SomeObject { foo :: String
                             , bar :: Boolean
                             , baz :: Number
                             , list :: [ListItem] }

data ListItem = ListItem { x :: Number
                         , y :: Number
                         , z :: Maybe Number }

instance readListItem :: ReadForeign ListItem where
  read = do
    x <- prop "x"
    y <- prop "y"
    z <- prop "z"
    return $ ListItem { x: x, y: y, z: z }

instance readObject :: ReadForeign SomeObject where
  read = do
    foo <- prop "foo"
    bar <- prop "bar"
    baz <- prop "baz"
    list <- prop "list"
    return $ SomeObject { foo: foo, bar: bar, baz: baz, list: list }

main = do

  let json = "{\"foo\":\"hello\",\"bar\":true,\"baz\":1,\"list\":[{\"x\":1,\"y\":2},{\"x\":3,\"y\":4,\"z\":999}]}"
  Debug.Trace.trace case parseJSON json of
    Left err -> "Error parsing JSON:\n" ++ err
    Right (SomeObject result) -> showUnsafe result

module Complex where

import Prelude
import Data.Array
import Data.Either
import Data.Foreign
import Data.Maybe
import Control.Monad.Eff

foreign import showUnsafe
  "var showUnsafe = JSON.stringify;" :: forall a. a -> String

data Object = Object { foo :: String
                     , bar :: Boolean
                     , baz :: Number
                     , list :: [ListItem] }

data ListItem = ListItem { x :: Number
                         , y :: Number
                         , z :: Maybe Number }

instance readListItem :: ReadForeign ListItem where
  read = do
    x <- prop "x"
    y <- prop "y"
    z <- prop "z"
    return $ ListItem { x: x, y: y, z: z }

instance readObject :: ReadForeign Object where
  read = do
    foo <- prop "foo"
    bar <- prop "bar"
    baz <- prop "baz"
    list <- prop "list"
    return $ Object { foo: foo, bar: bar, baz: baz, list: list }

main = do

  let json = "{\"foo\":\"hello\",\"bar\":true,\"baz\":1,\"list\":[{\"x\":1,\"y\":2},{\"x\":3,\"y\":4,\"z\":999}]}"
  Debug.Trace.trace case parseJSON json of
    Left err -> "Error parsing JSON:\n" ++ err
    Right (Object result) -> showUnsafe result