Clean up `Generate.purs`

Clean up `Generate.purs`

module Docopt.Generate (
  mkBranchParser
, runCliParser
, CliParser ()
, lexArgv
, Token (..)
) where

import Prelude
import Control.Plus (empty)
import Debug.Trace
import Control.Monad.State (State(), evalState)
import Control.Apply ((*>), (<*))
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList)
import Data.Foldable (foldl, intercalate)
import Data.String (fromCharArray, stripPrefix)
import qualified Data.List as L
import qualified Data.List.Unsafe as LU
import qualified Data.Array as A
import qualified Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Tuple (Tuple(..))
import Data.Monoid (mempty)

import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P

import Docopt
import Docopt.Parser.Base (alphaNum, space, getInput, debug)

--------------------------------------------------------------------------------
-- Input Lexer
--------------------------------------------------------------------------------

data Token
  = LOpt String (Maybe String)
  | SOpt Char (Array Char) (Maybe String)
  | Lit  String

prettyPrintToken :: Token -> String
prettyPrintToken (Lit s) = show s
prettyPrintToken (LOpt n a)
  = "--" ++ n ++ " " ++ (show a)
prettyPrintToken (SOpt n s a)
  = "-"  ++ (fromCharArray (A.cons n s)) ++ " " ++ (show a)

instance showToken :: Show Token where
  show (LOpt s a)    = "LOpt " ++ show s ++ " " ++ show a
  show (SOpt c cs a) = "SOpt " ++ show c ++ " " ++ show cs ++ " " ++ show a
  show (Lit  s)      = "Lit "  ++ show s

parseToken :: P.Parser String Token
parseToken = do
  P.choice $ P.try <$> [ sopt, lopt, lit ]
  <* P.eof
  where
    sopt :: P.Parser String Token
    sopt = do
      P.char '-'
      x  <- alphaNum
      xs <- A.many alphaNum
      arg <- P.choice $ P.try <$> [
        Just <$> do
          many space *> P.char '=' <* many space
          fromCharArray <$> do A.many P.anyChar
      , pure Nothing
      ]
      pure $ SOpt x xs arg
    lopt :: P.Parser String Token
    lopt = do
      P.string "--"
      xs <- fromCharArray <$> do
        A.many alphaNum
      arg <- P.choice $ P.try <$> [
        Just <$> do
          many space *> P.char '=' <* many space
          fromCharArray <$> do A.many P.anyChar
      , pure Nothing
      ]
      pure $ LOpt xs arg
    lit :: P.Parser String Token
    lit = Lit <<< fromCharArray <$> do
      A.many P.anyChar

lexArgv :: (List String) -> Either P.ParseError (List Token)
lexArgv = foldM step Nil
  where
    step :: List Token -> String -> Either P.ParseError (List Token)
    step a b = do
      x <- flip P.runParser parseToken b
      return (a ++ (Cons x Nil))

--------------------------------------------------------------------------------
-- Input Token Parser
--------------------------------------------------------------------------------

type CliParser a = P.Parser (List Token) a

runCliParser :: forall a.
                (List Token)
              -> CliParser a
              -> Either P.ParseError a
runCliParser input = P.runParser input

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> CliParser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case test tok of
        Just a ->
          let nextpos = pos -- neglect pos (for now)
          in
            { consumed: true
            , input:    xs
            , result:   Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "expected token, met EOF"

data Acc a
  = Free (CliParser a)
  | Pending (CliParser a) (List Argument)

command :: String -> CliParser Value
command n = token go P.<?> "command"
  where
    go (Lit s) | s == n = Just (BoolValue true)
    go _                = Nothing

positional :: CliParser Value
positional = token go P.<?> "positional"
  where
    go (Lit _) = Just (BoolValue true)
    go _       = Nothing

type HasConsumedArg = Boolean
data OptParse = OptParse Value (Maybe Token) HasConsumedArg

longOption :: Name -> (Maybe OptionArgument) -> CliParser Value
longOption n a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe Nil singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where

    takesArg = isJust a
    def      = maybe Nothing (\(OptionArgument _ v) -> v) a

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | takesArg  && (n' == n)
      = case v of
          -- XXX: The val needs to be parsed into a `Value`
          Just val -> return $ OptParse (StringValue val) Nothing false
          _  -> case atok of
            -- XXX: The lit needs to be parsed into a `Value`
            Just (Lit s) -> return $ OptParse (StringValue s) Nothing true
            _ -> case def of
              Just defval -> return $ OptParse defval Nothing false
              _ -> Left "Argument required"

    -- case 2:
    -- The name is a substring of the input and no explicit argument has been
    -- provdided.
    go (LOpt n' Nothing) atok | takesArg
      = case stripPrefix n n' of
          Just s -> return $ OptParse (StringValue s) Nothing false
          _      -> Left "Argument required"

    go _ _ = Left "Invalid token"

shortOption :: Char -> (Maybe OptionArgument) -> CliParser Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe Nil singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where

    takesArg = isJust a
    def      = maybe Nothing (\(OptionArgument _ v) -> v) a

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && takesArg && (A.length xs == 0)
      = case v of
          -- XXX: The val needs to be parsed into a `Value`
          Just val -> return $ OptParse (StringValue val) Nothing false
          _  -> case atok of
            -- XXX: The lit needs to be parsed into a `Value`
            Just (Lit s) -> return $ OptParse (StringValue s) Nothing true
            _ -> case def of
              Just defval -> return $ OptParse defval Nothing false
              _ -> Left "Argument required"

    -- case 2:
    -- The leading flag matches, there are stacked options, no explicit
    -- argument has been passed and the option takes an argument.
    go (SOpt f' xs Nothing) _ | (f' == f) && takesArg && (A.length xs > 0)
      = return $ OptParse (StringValue $ fromCharArray xs) Nothing false

    -- case 3:
    -- The leading flag matches, there are stacked options, the option takes
    -- no argument and an explicit argument has not been provided.
    go (SOpt f' xs v) _ | (f' == f) && (takesArg == false) && (A.length xs > 0)
      = return $ OptParse
                (BoolValue true)
                (Just $ SOpt (AU.head xs) (AU.tail xs) v)
                false

    go a b = Left $ "Invalid token " ++ show a ++ " (input: " ++ show b ++ ")"

-- | Generate a parser for a single usage branch
mkBranchParser :: Branch -> CliParser (List (Tuple Argument Value))
mkBranchParser (Branch xs) = do
  either
    (\_   -> P.fail "Failed to generate parser")
    (\acc -> case acc of
      Free p       -> p
      Pending p xs -> do
        a  <- p
        as <- mkExaustiveParser xs
        return (a ++ as))
    (foldM step (Free $ pure empty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    --
    -- XXX: Replace this with a manual iteration - i.e. consume each
    --      argument. Only fail if an argument has not been consumed
    --      that was declared as *required*.
    --
    --      This will allow for repeating flags in any order, i.e.:
    --      "-vbvbvb" would be equivalent to "-vvvbbb" (only the latter being
    --                                                 currenlty possible)
    mkExaustiveParser :: List Argument
                      -> CliParser (List (Tuple Argument Value))
    mkExaustiveParser Nil = pure empty
    mkExaustiveParser ps  = do
      let ls = reduce <$> (permute ps)
      P.choice $ P.try <$> ls
      where
          reduce :: List Argument -> CliParser (List (Tuple Argument Value))
          reduce ls = (foldl step (pure empty) ls) P.<?> errormsg
            where step acc p = do
                    as <- acc
                    a  <- mkParser p
                    return (as ++ a)
                  errormsg = "at least one of each of "
                    ++ (intercalate ", " $ prettyPrintArg <$> ps)

          permute :: forall a. (Eq a) => List a -> List (List a)
          permute Nil = Cons Nil Nil
          permute xs  = do
              x  <- xs
              ys <- permute $ delete x xs
              return (x:ys)

    -- Options always transition to the `Pending state`
    step (Free p) x@(Option _ _ _ _) = Right $ Pending p (singleton x)

    -- Any other argument causes immediate evaluation
    step (Free p) x = Right $ Free do
      a  <- p
      as <- (mkParser x)
      return (a ++ as)

    -- Options always keep accumulating
    step (Pending p xs) x@(Option _ _ _ _) = Right $
      Pending p (x:xs)

    -- Any non-options always leaves the pending state
    step (Pending p xs) y = Right $
      Free do
        a  <- p
        as <- mkExaustiveParser xs
        return (a ++ as)

    -- Parser generator for a single `Argument`
    mkParser :: Argument -> CliParser (List (Tuple Argument Value))

    -- Generate a parser for a `Command` argument
    mkParser x@(Command n) = do
      singleton <<< Tuple x <$> do
        command n

    -- Generate a parser for a `Positional` argument
    mkParser x@(Positional n r) = do
      if r then (some go) else (singleton <$> go)
      where go = Tuple x <$> positional

    -- Generate a parser for a `Option` argument
    mkParser x@(Option f n a r) = do
      if r then (some go) else (singleton <$> go)
      where
        go = do
          P.choice $ P.try <$> [
            Tuple x <$> (mkLoptParser n a)
          , Tuple x <$> (mkSoptParser f a)
          ]

        mkLoptParser (Just n) a = longOption n a
        mkLoptParser Nothing _  = P.fail "no long name"

        mkSoptParser (Just f) a = shortOption f a
        mkSoptParser Nothing _  = P.fail "not no flag"

    -- Generate a parser for a argument `Group`
    mkParser (Group o bs r) =
      -- XXX: Recursively generate a parser.
      --      NOTE: THIS COMPUTATION MAY FAIL:
      --            `mkParser` must be in the Either monad
      -- XXX: Consider `r` here - we must either return a list, always, or
      --      a data type that ensures that at least one value is present:
      --      `X Xs`, where both `X` and `Xs` are data constructors.
      pure empty

module Docopt.Generate (
  mkBranchParser
, runCliParser
, CliParser ()
, lexArgv
, Token (..)
) where

import Prelude
import Control.Plus (empty)
import Debug.Trace
import Control.Monad.State (State(), evalState)
import Control.Apply ((*>), (<*))
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList)
import Data.Foldable (foldl, intercalate)
import Data.String (fromCharArray, stripPrefix)
import qualified Data.List as L
import qualified Data.List.Unsafe as LU
import qualified Data.Array as A
import qualified Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Tuple (Tuple(..))
import Data.Monoid (mempty)

import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P

import Docopt
import Docopt.Parser.Base (alphaNum, space, getInput, debug)

--------------------------------------------------------------------------------
-- Input Lexer
--------------------------------------------------------------------------------

data Token
  = LOpt String (Maybe String)
  | SOpt Char (Array Char) (Maybe String)
  | Lit  String

prettyPrintToken :: Token -> String
prettyPrintToken (Lit s) = show s
prettyPrintToken (LOpt n a)
  = "--" ++ n ++ " " ++ (show a)
prettyPrintToken (SOpt n s a)
  = "-"  ++ (fromCharArray (A.cons n s)) ++ " " ++ (show a)

instance showToken :: Show Token where
  show (LOpt s a)    = "LOpt " ++ show s ++ " " ++ show a
  show (SOpt c cs a) = "SOpt " ++ show c ++ " " ++ show cs ++ " " ++ show a
  show (Lit  s)      = "Lit "  ++ show s

parseToken :: P.Parser String Token
parseToken = do
  P.choice $ P.try <$> [ sopt, lopt, lit ]
  <* P.eof
  where
    sopt :: P.Parser String Token
    sopt = do
      P.char '-'
      x  <- alphaNum
      xs <- A.many alphaNum
      arg <- P.choice $ P.try <$> [
        Just <$> do
          many space *> P.char '=' <* many space
          fromCharArray <$> do A.many P.anyChar
      , pure Nothing
      ]
      pure $ SOpt x xs arg
    lopt :: P.Parser String Token
    lopt = do
      P.string "--"
      xs <- fromCharArray <$> do
        A.many alphaNum
      arg <- P.choice $ P.try <$> [
        Just <$> do
          many space *> P.char '=' <* many space
          fromCharArray <$> do A.many P.anyChar
      , pure Nothing
      ]
      pure $ LOpt xs arg
    lit :: P.Parser String Token
    lit = Lit <<< fromCharArray <$> do
      A.many P.anyChar

lexArgv :: (List String) -> Either P.ParseError (List Token)
lexArgv = foldM step Nil
  where
    step :: List Token -> String -> Either P.ParseError (List Token)
    step a b = do
      x <- flip P.runParser parseToken b
      return (a ++ (Cons x Nil))

--------------------------------------------------------------------------------
-- Input Token Parser
--------------------------------------------------------------------------------

type CliParser a = P.Parser (List Token) a

runCliParser :: forall a.
                (List Token)
              -> CliParser a
              -> Either P.ParseError a
runCliParser input = P.runParser input

-- | Test the string at the head of the stream
token :: forall a. (Token -> Maybe a) -> CliParser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case test tok of
        Just a ->
          let nextpos = pos -- neglect pos
          in
            { consumed: true
            , input:    xs
            , result:   Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "expected token, met EOF"

-- XXX: Should the `Pending` constructor store a list of `Parsers` instead?
data Acc a
  = Free (CliParser a)
  | Pending (CliParser a) (List Argument)

command :: String -> CliParser Value
command n = token go P.<?> "command"
  where
    go (Lit s) | s == n = Just (BoolValue true)
    go _                = Nothing

positional :: CliParser Value
positional = token go P.<?> "positional"
  where
    go (Lit _) = Just (BoolValue true)
    go _       = Nothing

-- | Parse the token at the head of the input stream and possibly replace
-- | it with another token. Consider, e.g. an option was parsed but has a
-- | valid remainder, that remainder should be offered to subsequent parsers.
token' :: forall a. (Token -> Tuple (Maybe Token) (Maybe a)) -> CliParser a
token' f = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case f tok of
        Tuple remainder (Just a) ->
          let nextpos = pos -- neglect pos
          in {
            consumed: maybe true (const false) remainder
          , input:    maybe xs (\r -> (r:xs)) remainder
          , result:   Right a
          , position: nextpos
          }
        _ -> P.parseFailed toks pos "bad token"
    _ -> P.parseFailed toks pos "expected token, met EOF"

(\\) :: forall a b. a -> b -> Tuple a b
(\\) = Tuple

type HasConsumedArg = Boolean
data OptParse = OptParse Value (Maybe Token) HasConsumedArg

longOption :: Name -> (Maybe OptionArgument) -> CliParser Value
longOption n a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe Nil singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where

    takesArg = isJust a
    def      = maybe Nothing (\(OptionArgument _ v) -> v) a

    go :: Token
        -> (Maybe Token)
        -> Either String OptParse

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | takesArg  && (n' == n)
      = case v of
          -- XXX: The val needs to be parsed into a `Value`
          Just val -> return $ OptParse (StringValue val) Nothing false
          _  -> case atok of
            -- XXX: The lit needs to be parsed into a `Value`
            Just (Lit s) -> return $ OptParse (StringValue s) Nothing true
            _ -> case def of
              Just defval -> return $ OptParse defval Nothing false
              _ -> Left "Argument required"

    -- case 2:
    -- The name is a substring of the input and no explicit argument has been
    -- provdided.
    go (LOpt n' Nothing) atok | takesArg
      = case stripPrefix n n' of
          Just s -> return $ OptParse (StringValue s) Nothing false
          _      -> Left "Argument required"

    go _ _ = Left "Invalid token"

shortOption :: Char -> (Maybe OptionArgument) -> CliParser Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe Nil singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where

    takesArg = isJust a
    def      = maybe Nothing (\(OptionArgument _ v) -> v) a

    go :: Token
        -> (Maybe Token)
        -> Either String OptParse

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && takesArg && (A.length xs == 0)
      = case v of
          -- XXX: The val needs to be parsed into a `Value`
          Just val -> return $ OptParse (StringValue val) Nothing false
          _  -> case atok of
            -- XXX: The lit needs to be parsed into a `Value`
            Just (Lit s) -> return $ OptParse (StringValue s) Nothing true
            _ -> case def of
              Just defval -> return $ OptParse defval Nothing false
              _ -> Left "Argument required"

    -- case 2:
    -- The leading flag matches, there are stacked options, no explicit
    -- argument has been passed and the option takes an argument.
    go (SOpt f' xs Nothing) _ | (f' == f) && takesArg && (A.length xs > 0)
      = return $ OptParse (StringValue $ fromCharArray xs) Nothing false

    -- case 3:
    -- The leading flag matches, there are stacked options, the option takes
    -- no argument and an explicit argument has not been provided.
    go (SOpt f' xs v) _ | (f' == f) && (takesArg == false) && (A.length xs > 0)
      = return $ OptParse
                (BoolValue true)
                (Just $ SOpt (AU.head xs) (AU.tail xs) v)
                false

    go a b = Left $ "Invalid token " ++ show a ++ " (input: " ++ show b ++ ")"

-- | Generate a parser for a single usage branch
mkBranchParser :: Branch -> CliParser (List (Tuple Argument Value))
mkBranchParser (Branch xs) = do
  either
    (\_ -> P.fail "Failed to generate parser")
    (\acc -> case acc of
      Free p       -> p
      Pending p xs -> do
        a  <- p
        as <- mkExaustiveParser xs
        return (a ++ as))
    (foldM step (Free $ pure empty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    --
    -- XXX: Replace this with a manual iteration - i.e. consume each
    --      argument. Only fail if an argument has not been consumed
    --      that was declared as *required*.
    --
    --      This will allow for repeating flags in any order, i.e.:
    --      "-vbvbvb" would be equivalent to "-vvvbbb" (only the latter being
    --                                                 currenlty possible)
    mkExaustiveParser :: List Argument
                      -> CliParser (List (Tuple Argument Value))
    mkExaustiveParser Nil = pure empty
    mkExaustiveParser ps  = do
      let ls = reduce <$> (permute ps)
      P.choice $ P.try <$> ls
      where
          reduce :: List Argument -> CliParser (List (Tuple Argument Value))
          reduce ls = (foldl step (pure empty) ls) P.<?> errormsg
            where step acc p = do
                    as <- acc
                    a  <- mkParser p
                    return (as ++ a)
                  errormsg = "at least one of each of "
                    ++ (intercalate ", " $ prettyPrintArg <$> ps)

          permute :: forall a. (Eq a) => List a -> List (List a)
          permute Nil = Cons Nil Nil
          permute xs  = do
              x  <- xs
              ys <- permute $ delete x xs
              return (x:ys)

    -- Options always transition to the `Pending state`
    step (Free p) x@(Option _ _ _ _) = Right $ Pending p (singleton x)

    -- Any other argument causes immediate evaluation
    step (Free p) x = Right $ Free do
      a  <- p
      as <- (mkParser x)
      return (a ++ as)

    -- Options always keep accumulating
    step (Pending p xs) x@(Option _ _ _ _) = Right $
      Pending p (x:xs)

    -- Any non-options always leaves the pending state
    step (Pending p xs) y = Right $
      Free do
        a  <- p
        as <- mkExaustiveParser xs
        return (a ++ as)

    -- Parser generator for a single `Argument`
    mkParser :: Argument -> CliParser (List (Tuple Argument Value))

    -- Generate a parser for a `Command` argument
    mkParser x@(Command n) = do
      singleton <<< Tuple x <$> do
        command n

    -- Generate a parser for a `Positional` argument
    mkParser x@(Positional n r) = do
      if r then (some go) else (singleton <$> go)
      where go = Tuple x <$> positional

    -- Generate a parser for a `Option` argument
    mkParser x@(Option f n a r) = do
      if r then (some go) else (singleton <$> go)
      where
        go = do
          P.choice $ P.try <$> [
            Tuple x <$> (mkLoptParser n a)
          , Tuple x <$> (mkSoptParser f a)
          ]

        mkLoptParser (Just n) a = longOption n a
        mkLoptParser Nothing _  = P.fail "no long name"

        mkSoptParser (Just f) a = shortOption f a
        mkSoptParser Nothing _  = P.fail "not no flag"

    -- Generate a parser for a argument `Group`
    mkParser (Group o bs r) =
      -- XXX: Recursively generate a parser.
      --      NOTE: THIS COMPUTATION MAY FAIL:
      --            `mkParser` must be in the Either monad
      -- XXX: Consider `r` here - we must either return a list, always, or
      --      a data type that ensures that at least one value is present:
      --      `X Xs`, where both `X` and `Xs` are data constructors.
      pure empty


Making sure to trim multiline HTML templates

JQuery apparently gets fidgetty (and breaks) when you give it HTML
that has extra whitespace on the outside....  Whatevas!

module Element (genCardCheckbox, genCardEntryColumn, genPlayerRow) where

import Control.Monad.Eff(Eff(..))
import Control.Monad.JQuery(append, create, find, JQuery(..), remove, removeClass)

import Data.String(toLower, trim)

import DOM(DOM(..))
import JQueryUI(attrStr, click, load, replaceWith)
import StringUtils(slugify)

(|>) a f = f a

genCardCheckbox :: forall eff. String -> Boolean -> Eff (dom :: DOM | eff) JQuery
genCardCheckbox cardname isEnabled = create html
  where
    name    = slugify cardname
    checked = if isEnabled then " checked" else ""
    html    = trim $
      """
      <input type="checkbox" id='check-""" ++ name ++ """' name="version" class='check-button version-button dynamic-check-button'""" ++ checked ++ """/>
      """ ++ cardname ++ """
      """

genCardEntryColumn :: forall eff. String -> String -> String -> String -> Eff (dom :: DOM | eff) JQuery
genCardEntryColumn name id url faction = do
    column    <- create "	"
    cardEntry <- genCardEntry name id url faction
    append cardEntry column

genPlayerRow :: forall eff. String -> String -> String -> (JQuery -> Eff (dom :: DOM| eff) JQuery) -> Eff (dom :: DOM | eff) JQuery
genPlayerRow name id imgID onClickF = do
    imgJQ          <- create imgHTML
    clickableImgJQ <- click onClickF imgJQ
    elemJQ         <- create elemHTML
    findAndReplace ".placeholder" clickableImgJQ elemJQ
  where
    imgHTML      = ""
    elemHTML = trim $
      """

                  """ ++ name ++ """

      """

genCardEntry :: forall eff. String -> String -> String -> String -> Eff (dom :: DOM | eff) JQuery
genCardEntry name id url faction = do
    jq     <- create html
    imgJQ  <- genCardImage id url faction
    textJQ <- genCardText name
    r1     <- findAndReplace imgHolderClass imgJQ jq
    findAndReplace textHolderClass textJQ r1
  where
    imgHolderClass  = ".img-placeholder"
    textHolderClass = ".text-placeholder"
    html            = trim $
      """

      """

genCardImage :: forall eff. String -> String -> String -> Eff (dom :: DOM | eff) JQuery
genCardImage id url faction = do
    jq      <- create ""
    animJQ  <- genLoadingAnim id bgClass
    imgJQ   <- genCardCoreImage id url animJQ bgClass
    withImg <- append imgJQ jq
    append animJQ withImg
  where
    bgClass = faction |> (toLower >>> (\x -> x ++ "-backgrounded"))

genCardText :: forall eff. String -> Eff (dom :: DOM | eff) JQuery
genCardText text = create html
  where
    html = trim $
      """

            """ ++ text ++ """

      """

genCardCoreImage :: forall eff. String -> String -> JQuery -> String -> Eff (dom :: DOM | eff) JQuery
genCardCoreImage id url anim bgClass = do
    jq <- create html
    load loadFunc jq
  where
    html      = ""
    domCopyOf elem = do
      soulmateID <- attrStr "id" elem
      create $ "#" ++ soulmateID
    loadFunc this = do
      a <- domCopyOf anim
      remove a
      t <- domCopyOf this
      removeClass "hidden" t

genLoadingAnim :: forall eff. String -> String -> Eff (dom :: DOM | eff) JQuery
genLoadingAnim idBasis bgClass = create html
  where
    id   = idBasis ++ "-loading"
    html = trim $
      """

      """

findAndReplace :: forall eff. String -> JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery
findAndReplace findTerm replaceTerm root = do
  found <- find findTerm root
  replaceWith replaceTerm found

module Element (genCardCheckbox, genCardEntryColumn, genPlayerRow) where

import Control.Monad.Eff(Eff(..))
import Control.Monad.JQuery(append, create, find, JQuery(..), remove, removeClass)

import Data.String(toLower)

import DOM(DOM(..))
import JQueryUI(attrStr, click, load, replaceWith)
import StringUtils(slugify)

(|>) a f = f a

genCardCheckbox :: forall eff. String -> Boolean -> Eff (dom :: DOM | eff) JQuery
genCardCheckbox cardname isEnabled = create html
  where
    name    = slugify cardname
    checked = if isEnabled then " checked" else ""
    html    =
      """
      <input type="checkbox" id='check-""" ++ name ++ """' name="version" class='check-button version-button dynamic-check-button'""" ++ checked ++ """/>
      """ ++ cardname ++ """
      """

genCardEntryColumn :: forall eff. String -> String -> String -> String -> Eff (dom :: DOM | eff) JQuery
genCardEntryColumn name id url faction = do
    column    <- create "	"
    cardEntry <- genCardEntry name id url faction
    append cardEntry column

genPlayerRow :: forall eff. String -> String -> String -> (JQuery -> Eff (dom :: DOM| eff) JQuery) -> Eff (dom :: DOM | eff) JQuery
genPlayerRow name id imgID onClickF = do
    imgJQ          <- create imgHTML
    clickableImgJQ <- click onClickF imgJQ
    elemJQ         <- create elemHTML
    findAndReplace ".placeholder" clickableImgJQ elemJQ
  where
    imgHTML      = ""
    elemHTML =
      """

                  """ ++ name ++ """

      """

genCardEntry :: forall eff. String -> String -> String -> String -> Eff (dom :: DOM | eff) JQuery
genCardEntry name id url faction = do
    jq     <- create html
    imgJQ  <- genCardImage id url faction
    textJQ <- genCardText name
    r1     <- findAndReplace imgHolderClass imgJQ jq
    findAndReplace textHolderClass textJQ r1
  where
    imgHolderClass  = ".img-placeholder"
    textHolderClass = ".text-placeholder"
    html            =
      """

      """

genCardImage :: forall eff. String -> String -> String -> Eff (dom :: DOM | eff) JQuery
genCardImage id url faction = do
    jq      <- create ""
    animJQ  <- genLoadingAnim id bgClass
    imgJQ   <- genCardCoreImage id url animJQ bgClass
    withImg <- append imgJQ jq
    append animJQ withImg
  where
    bgClass = faction |> (toLower >>> (\x -> x ++ "-backgrounded"))

genCardText :: forall eff. String -> Eff (dom :: DOM | eff) JQuery
genCardText text = create html
  where
    html =
      """

            """ ++ text ++ """

      """

genCardCoreImage :: forall eff. String -> String -> JQuery -> String -> Eff (dom :: DOM | eff) JQuery
genCardCoreImage id url anim bgClass = do
    jq <- create html
    load loadFunc jq
  where
    html      = ""
    domCopyOf elem = do
      soulmateID <- attrStr "id" elem
      create $ "#" ++ soulmateID
    loadFunc this = do
      a <- domCopyOf anim
      remove a
      t <- domCopyOf this
      removeClass "hidden" t

genLoadingAnim :: forall eff. String -> String -> Eff (dom :: DOM | eff) JQuery
genLoadingAnim idBasis bgClass = create html
  where
    id   = idBasis ++ "-loading"
    html =
      """

      """

findAndReplace :: forall eff. String -> JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery
findAndReplace findTerm replaceTerm root = do
  found <- find findTerm root
  replaceWith replaceTerm found


connectV, withDispatchV, dispatchV family of functions

module React.Redox
  ( ConnectState(..)
  , DispatchFn
  , DispatchFnFiber
  , RedoxContext
  , RedoxSpec
  , withStore
  , connect'
  , connectEq'
  , connect
  , connectEq
  , connectV'
  , connectEqV'
  , connectV
  , connectEqV
  , withDispatch
  , withDispatchV
  , dispatch
  , dispatchV
  , asReactClass
  , overRedoxSpec
  , unsafeShallowEqual
  ) where

import Prelude

import Control.Monad.Aff (Fiber)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Uncurried (EffFn1, EffFn2, runEffFn1, runEffFn2)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Newtype (class Newtype, over)
import Data.Traversable (traverse_)
import React (ReactClass, ReactElement, ReactSpec, ReactThis, childrenToArray, createClass, createElement, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

type DispatchFn a state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) a
type DispatchFnFiber state dsl reff eff = DispatchFn (Fiber (redox :: RedoxStore reff | eff) Unit) state dsl reff eff

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

foreign import writeIsMountedImpl
  :: forall props state e
   . EffFn2 e (ReactThis props state) Boolean Unit

writeIsMounted :: forall props state e. ReactThis props state -> Boolean -> Eff e Unit
writeIsMounted this isMounted = runEffFn2 writeIsMountedImpl this isMounted

foreign import readIsMountedImpl
  :: forall props state e
   . EffFn1 e (ReactThis props state) Boolean

readIsMounted :: forall props state e. ReactThis props state -> Eff e Boolean
readIsMounted this = runEffFn1 readIsMountedImpl this

createClassStatelessWithContext
  :: forall props ctx
   . (props -> ctx -> ReactElement)
  -> ReactClass props
createClassStatelessWithContext fn = unsafeCoerce f
  where
    f :: Fn2 props { ctx :: ctx } ReactElement
    f = mkFn2 (\a { ctx } -> fn a ctx)

newtype RedoxContext state dsl reff eff = RedoxContext
  { store :: Store state
  , dispatch :: DispatchFnFiber state dsl reff eff
  }

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function available through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.  It serves the same purpose
-- | as
-- | [Provider](https://github.com/reactjs/react-redux/blob/master/docs/api.md#provider-store)
-- | class in `react-redux`.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFnFiber state dsl reff eff)
  -> ReactClass props
  -> Eff eff (ReactClass props)
withStore store dispatch_ cls =
  pure $ withContext cls { redox: RedoxContext { store, dispatch: dispatch_ store } }

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

derive instance newtypeConnectState :: Newtype (ConnectState state) _

-- Read redox contenxt.
readRC
  :: forall state state' props dsl reff eff
   . ReactThis props (ConnectState state')
  -> Eff (context :: CONTEXT | eff) (RedoxContext state dsl reff eff)
readRC this = _.redox <$> readContext Proxy this

-- | Internal `_connect` implementation.
_connect
  :: forall res state state' dsl props props' reff eff
  -- | compare state in `componentShouldUpdate`
   . (state' -> state' -> Boolean)
  -- | compare props in `componentShouldUpdate`
  -> (props' -> props' -> Boolean)
  -- | lens which gets the internal state (`state'`) from the store's state
  -- | (`state`)
  -> Getter' state state'
  -> ((DispatchFn res state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ((Fiber (redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff) Unit) -> res)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect eqs eqp _lns _iso fn cls = (R.spec' getInitialState rndr)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = didMount
    , componentWillUnmount = willUnmount
    , shouldComponentUpdate = shouldUpdate
    }
  where
    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cwc :: ReactClass props
    cwc = accessContext cls

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

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

    -- | Subscription to redox store happens in `componentDidMount`, rather than
    -- | on `componentWillMount`.  This is because `componentWillUnmount` and
    -- | `componentDidMount` do not fire in SSR. Otherwise we'd have a memory
    -- | leak.
    didMount this = do
      writeIsMounted this true
      RedoxContext { store } <- unsafeCoerceEff $ readRC this
      ConnectState { state } <- readState this
      sid <- Redox.subscribe store $ update this
      state' <- view _lns <$> Redox.getState store
      _ <- if state `eqs` state'
        then writeState this (ConnectState { sid: Just sid, state })
        else writeState this (ConnectState { sid: Just sid, state: state' })
      pure unit

    willUnmount this = do
      writeIsMounted this false
      RedoxContext ctx <- unsafeCoerceEff $ readRC this
      ConnectState { sid } <- R.readState this
      traverse_ (Redox.unsubscribe ctx.store) sid

    -- | If `Eq state'` and `Eq props'` are not tight enought you might end up
    -- | with an infitinte loop of actions.  If you see a stack overflow error
    -- | this the usal the cause.  You can use `Data.Record.equal` or
    -- | `Unsafe.Reference.unsafeRefEq` (i.e. JavaScripts `===`) or
    -- | `React.Redox.unsafeShallowEqual` functions.
    shouldUpdate this nPr (ConnectState nSt) = do
      pr <- getProps this
      ConnectState st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not (st.state `eqs` nSt.state) || not (pr `eqp` nPr)

    rndr this = do
      props' <- R.getProps this
      children <- R.getChildren this
      RedoxContext ctx <- unsafeCoerceEff $ readRC this
      ConnectState { state } <- R.readState this
      pure $ R.createElement cwc (_iso (map fn <<< ctx.dispatch) state props') children

-- | Newtype wrapper around `ReactSpec`.  Use  `overRedoxSpec` to change the
-- | underlying spec and `asReactClass` to create a react class.
newtype RedoxSpec props state eff = RedoxSpec (ReactSpec props state eff)

overRedoxSpec
  :: forall props state eff
   . (ReactSpec props state eff ->  ReactSpec props state eff)
  -> RedoxSpec props state eff
  -> RedoxSpec props state eff
overRedoxSpec f (RedoxSpec spec) = RedoxSpec <<< f $ spec

asReactClass :: forall props state eff. RedoxSpec props state eff -> ReactClass props
asReactClass (RedoxSpec spec) = accessContext <<< createClass $ spec

coerceAny :: forall a. a -> Unit
coerceAny _ = unit

-- | This function makes the redox store and dispatch function available
-- | through context.  The first argument is a lens that identifies the part
-- | of redox store's state that you want to subscribe for.  The view on this
-- | lens will be checked for changes, so if you want to optimise your code,
-- | return as 'tight' lens as possible.
-- |
-- | Use `asReactClass` function to create react class from `RedoxSpec` that
-- | this function returns and `overRedoxSpec` to possibly change the spec, for
-- | example by changing the `shouldComponentUpdate` react life cycle method.
-- |
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
-- |
-- | Not the `Eq` type classes must be resolved when you apply this fuction.
-- | Otherwise you will endup with
-- | [re-mounts](https://github.com/purescript-contrib/purescript-react/issues/105).
-- | This can lead to components loosing focus (in case of `input` elements).
connect'
  :: forall state state' dsl props props' reff eff
   . Proxy state
  -> (state' -> state' -> Boolean)
  -> (props' -> props' -> Boolean)
  -> Getter' state state'
  -> (DispatchFnFiber state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> RedoxSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ eqs eqp _lns _iso cls = RedoxSpec $ _connect eqs eqp _lns _iso id cls

connectEq'
  :: forall state state' dsl props props' reff eff
   . Eq state'
  => Eq props'
  => Proxy state
  -> Getter' state state'
  -> (DispatchFnFiber state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> RedoxSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectEq' p = connect' p (==) (==)

-- | Like `connect'` but for `ReactClass`-es.
connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> (state' -> state' -> Boolean)
  -> (props' -> props' -> Boolean)
  -> Getter' state state'
  -> (DispatchFnFiber state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p eqs eqp _lns _iso cls = asReactClass $ connect' p eqs eqp _lns _iso cls

connectEq
  :: forall state state' dsl props props' reff eff'
   . Eq state'
  => Eq props'
  => Proxy state
  -> Getter' state state'
  -> (DispatchFnFiber state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connectEq p = connect p (==) (==)

-- | Like `connect'`, only the dispatch function returns `Eff eff Unit` rather
-- | than `Eff eff (Fiber eff Unit)`.
connectV'
  :: forall state state' dsl props props' reff eff
   . Proxy state
  -> (state' -> state' -> Boolean)
  -> (props' -> props' -> Boolean)
  -> Getter' state state'
  -> (DispatchFn Unit state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> RedoxSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectV' _ eqs eqp _lns _iso cls = RedoxSpec $ _connect eqs eqp _lns _iso coerceAny cls

connectEqV'
  :: forall state state' dsl props props' reff eff
   . Eq state'
  => Eq props'
  => Proxy state
  -> Getter' state state'
  -> (DispatchFn Unit state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> RedoxSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectEqV' p = connectV' p (==) (==)

connectEqV
  :: forall state state' dsl props props' reff eff'
   . Eq state'
  => Eq props'
  => Proxy state
  -> Getter' state state'
  -> (DispatchFn Unit state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connectEqV p = connectV p (==) (==)

connectV
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> (state' -> state' -> Boolean)
  -> (props' -> props' -> Boolean)
  -> Getter' state state'
  -> (DispatchFn Unit state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connectV p eqs eqp _lns _iso cls = asReactClass $ connectV' p eqs eqp _lns _iso cls

_withDispatch
  :: forall res state props props' dsl reff eff'
   . (Fiber (redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff') Unit -> res)
  -> (DispatchFn res state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
_withDispatch gn fn cls = accessContext $ createClassStatelessWithContext
  \props' { redox: RedoxContext { dispatch: disp }}
  -> createElement cls (fn (map gn <<< disp) props') (childrenToArray (unsafeCoerce props').children)

-- | If you just want to wrap your actions with a dispatch function use this
-- | function.  Unlike `connect'` (and `connect`) it does not wrap your
-- | component inside another component.
withDispatch
  :: forall state props props' dsl reff eff'
   . (DispatchFnFiber state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
withDispatch = _withDispatch id

withDispatchV
  :: forall state props props' dsl reff eff'
   . (DispatchFn Unit state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
withDispatchV = _withDispatch coerceAny

_dispatch
  :: forall res dsl rProps rState state reff eff
   . ((Fiber (context :: CONTEXT, redox :: RedoxStore reff | eff) Unit) -> res)
  -> ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) res
_dispatch fn this dsl =
  let proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) })
      proxy = Proxy
  in do
    { redox: RedoxContext { dispatch: disp } } <- readContext proxy this
    fn <$> disp dsl

-- | The component must be wrapped with `accessContext` to use this function.
-- | `connect` and `asReactClass` do that for you.
dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Fiber (context :: CONTEXT, redox :: RedoxStore reff | eff) Unit)
dispatch = _dispatch id

-- | Like `dispatch'`, only the dispatch function returns `Eff eff Unit` rather
-- | than `Eff eff (Fiber eff Unit)`.
dispatchV
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) Unit
dispatchV = _dispatch coerceAny

module React.Redox
  ( ConnectState(..)
  , DispatchFn
  , RedoxContext
  , RedoxSpec
  , withStore
  , connect'
  , connectEq'
  , connect
  , connectEq
  , withDispatch
  , dispatch
  , asReactClass
  , overRedoxSpec
  , unsafeShallowEqual
  ) where

import Prelude

import Control.Monad.Aff (Fiber)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Uncurried (EffFn1, EffFn2, runEffFn1, runEffFn2)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Newtype (class Newtype, over)
import Data.Traversable (traverse_)
import React (ReactClass, ReactElement, ReactSpec, ReactThis, childrenToArray, createClass, createElement, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

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

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

foreign import writeIsMountedImpl
  :: forall props state e
   . EffFn2 e (ReactThis props state) Boolean Unit

writeIsMounted :: forall props state e. ReactThis props state -> Boolean -> Eff e Unit
writeIsMounted this isMounted = runEffFn2 writeIsMountedImpl this isMounted

foreign import readIsMountedImpl
  :: forall props state e
   . EffFn1 e (ReactThis props state) Boolean

readIsMounted :: forall props state e. ReactThis props state -> Eff e Boolean
readIsMounted this = runEffFn1 readIsMountedImpl this

createClassStatelessWithContext
  :: forall props ctx
   . (props -> ctx -> ReactElement)
  -> ReactClass props
createClassStatelessWithContext fn = unsafeCoerce f
  where
    f :: Fn2 props { ctx :: ctx } ReactElement
    f = mkFn2 (\a { ctx } -> fn a ctx)

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

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function available through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.  It serves the same purpose
-- | as
-- | [Provider](https://github.com/reactjs/react-redux/blob/master/docs/api.md#provider-store)
-- | class in `react-redux`.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> Eff eff (ReactClass props)
withStore store dispatch_ cls =
  pure $ withContext cls { redox: RedoxContext { store, dispatch: dispatch_ store } }

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

derive instance newtypeConnectState :: Newtype (ConnectState state) _

-- Read redox contenxt.
readRC
  :: forall state state' props dsl reff eff
   . ReactThis props (ConnectState state')
  -> Eff (context :: CONTEXT | eff) (RedoxContext state dsl reff eff)
readRC this = _.redox <$> readContext Proxy this

-- | Internal `_connect` implementation.
_connect
  :: forall state state' dsl props props' reff eff
  -- | compare state in `componentShouldUpdate`
   . (state' -> state' -> Boolean)
  -- | compare props in `componentShouldUpdate`
  -> (props' -> props' -> Boolean)
  -- | lens which gets the internal state (`state'`) from the store's state
  -- | (`state`)
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect eqs eqp _lns _iso cls = (R.spec' getInitialState rndr)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = didMount
    , componentWillUnmount = willUnmount
    , shouldComponentUpdate = shouldUpdate
    }
  where
    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cwc :: ReactClass props
    cwc = accessContext cls

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

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

    -- | Subscription to redox store happens in `componentDidMount`, rather than
    -- | on `componentWillMount`.  This is because `componentWillUnmount` and
    -- | `componentDidMount` do not fire in SSR. Otherwise we'd have a memory
    -- | leak.
    didMount this = do
      writeIsMounted this true
      RedoxContext { store } <- unsafeCoerceEff $ readRC this
      ConnectState { state } <- readState this
      sid <- Redox.subscribe store $ update this
      state' <- view _lns <$> Redox.getState store
      _ <- if state `eqs` state'
        then writeState this (ConnectState { sid: Just sid, state })
        else writeState this (ConnectState { sid: Just sid, state: state' })
      pure unit

    willUnmount this = do
      writeIsMounted this false
      RedoxContext ctx <- unsafeCoerceEff $ readRC this
      ConnectState { sid } <- R.readState this
      traverse_ (Redox.unsubscribe ctx.store) sid

    -- | If `Eq state'` and `Eq props'` are not tight enought you might end up
    -- | with an infitinte loop of actions.  If you see a stack overflow error
    -- | this the usal the cause.  You can use `Data.Record.equal` or
    -- | `Unsafe.Reference.unsafeRefEq` (i.e. JavaScripts `===`) or
    -- | `React.Redox.unsafeShallowEqual` functions.
    shouldUpdate this nPr (ConnectState nSt) = do
      pr <- getProps this
      ConnectState st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not (st.state `eqs` nSt.state) || not (pr `eqp` nPr)

    rndr this = do
      props' <- R.getProps this
      children <- R.getChildren this
      RedoxContext ctx <- unsafeCoerceEff $ readRC this
      ConnectState { state } <- R.readState this
      pure $ R.createElement cwc (_iso ctx.dispatch state props') children

-- | Newtype wrapper around `ReactSpec`.  Use  `overRedoxSpec` to change the
-- | underlying spec and `asReactClass` to create a react class.
newtype RedoxSpec props state eff = RedoxSpec (ReactSpec props state eff)

overRedoxSpec
  :: forall props state eff
   . (ReactSpec props state eff ->  ReactSpec props state eff)
  -> RedoxSpec props state eff
  -> RedoxSpec props state eff
overRedoxSpec f (RedoxSpec spec) = RedoxSpec <<< f $ spec

asReactClass :: forall props state eff. RedoxSpec props state eff -> ReactClass props
asReactClass (RedoxSpec spec) = accessContext <<< createClass $ spec

-- | This function makes the redox store and dispatch function available
-- | through context.  The first argument is a lens that identifies the part
-- | of redox store's state that you want to subscribe for.  The view on this
-- | lens will be checked for changes, so if you want to optimise your code,
-- | return as 'tight' lens as possible.
-- |
-- | Use `asReactClass` function to create react class from `RedoxSpec` that
-- | this function returns and `overRedoxSpec` to possibly change the spec, for
-- | example by changing the `shouldComponentUpdate` react life cycle method.
-- |
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
-- |
-- | Not the `Eq` type classes must be resolved when you apply this fuction.
-- | Otherwise you will endup with
-- | [re-mounts](https://github.com/purescript-contrib/purescript-react/issues/105).
-- | This can lead to components loosing focus (in case of `input` elements).
connect'
  :: forall state state' dsl props props' reff eff
   . Proxy state
  -> (state' -> state' -> Boolean)
  -> (props' -> props' -> Boolean)
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> RedoxSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ eqs eqp _lns _iso cls = RedoxSpec $ _connect eqs eqp _lns _iso cls

connectEq'
  :: forall state state' dsl props props' reff eff
   . Eq state'
  => Eq props'
  => Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> RedoxSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectEq' p = connect' p (==) (==)

-- | Like `connect'` but for `ReactClass`-es.
connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> (state' -> state' -> Boolean)
  -> (props' -> props' -> Boolean)
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p eqs eqp _lns _iso cls = asReactClass $ connect' p eqs eqp _lns _iso cls

connectEq
  :: forall state state' dsl props props' reff eff'
   . Eq state'
  => Eq props'
  => Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connectEq p = connect p (==) (==)

-- | If you just want to wrap your actions with a dispatch function use this
-- | function.  Unlike `connect'` (and `connect`) it does not wrap your
-- | component inside another component.
withDispatch
  :: forall state props props' dsl reff eff'
   . (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
withDispatch fn cls = accessContext $ createClassStatelessWithContext
  \props' { redox: RedoxContext { dispatch: disp }}
  -> createElement cls (fn disp props') (childrenToArray (unsafeCoerce props').children)

-- | The component must be wrapped with `accessContext` to use this function.
-- | `connect` and `asReactClass` do that for you.
dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Fiber (context :: CONTEXT, redox :: RedoxStore reff | eff) Unit)
dispatch this dsl =
  let proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) })
      proxy = Proxy
  in do
    { redox: RedoxContext { dispatch: disp } } <- readContext proxy this
    disp dsl