Refactor middleware tests

Refactor middleware tests

module Test.App (testSuite) where

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Exception
import Data.Array (zip, zipWith, foldM, length, filter, null)
import Data.Foreign.Class
import Data.Foreign.Null
import Data.Foreign.Undefined
import Data.Function
import Data.Maybe
import Data.Tuple
import Node.Express.Types
import Node.Express.Internal.App
import Prelude
import Test.Unit
import Test.Unit.Console
import Unsafe.Coerce

type FnCall = { name :: String, arguments :: Array String }

fnCall :: String -> Array String -> FnCall
fnCall name args = { name: name, arguments: args }

foreign import putCall :: Fn2 Application FnCall Unit
foreign import getCalls :: Fn1 Application (Array FnCall)
foreign import clearCalls :: Fn1 Application Unit

foreign import createMockApp :: Fn0 Application
foreign import createMockMiddleware :: Fn1 Application (Fn3 Request Response (ExpressM Unit) (ExpressM Unit))

type TestExpress e a = Eff ( express :: Express, testOutput :: TestOutput | e ) a
type AssertionExpress e = Assertion ( express :: Express, testOutput :: TestOutput | e)

toString :: forall a. a -> String
toString = unsafeCoerce

assertMatch :: forall a e. (Show a, Eq a) => String -> a -> a -> Assertion e
assertMatch what expected actual = do
    let errorMessage = what ++ " mismatch: Expected [ " ++ show expected ++ " ], Got [ " ++ show actual ++ " ]"
    assert errorMessage (expected == actual)

assertProperty ::
    forall a e. (Show a, Eq a, IsForeign a) =>
    Application -> String -> Maybe a -> AssertionExpress e
assertProperty mockApp property expected = do
    actual <- liftEff $ intlAppGetProp mockApp property
    assertMatch "Property" expected actual

assertCalls :: forall e. Application -> Array FnCall -> Assertion e
assertCalls mockApp expectedCalls = do
    let actualCalls = runFn1 getCalls mockApp
    assertMatch "Calls size" (length expectedCalls) (length actualCalls)
    foldM assertCallsMatch unit (zip expectedCalls actualCalls)
  where
    assertCallsMatch _ (Tuple expected actual) = do
        assertMatch "Call name" expected.name actual.name
        assertArgumentsMatch expected.arguments actual.arguments
    assertArgumentsMatch expected actual = do
        let lengthMatch = length expected == length actual
            argsMatch = null $ filter unmatched (zip expected actual)
            unmatched (Tuple e a) = e /= a
            errorMessage = "Call arguments mismatch: Expected [ " ++ show expected ++ " ], Got [ " ++ show actual ++ " ]"
        assert errorMessage (lengthMatch && argsMatch)

genHandler :: Application -> Request -> Response -> ExpressM Unit -> ExpressM Unit
genHandler mockApp req resp next =
    return $ runFn2 putCall mockApp $
        fnCall "handler" [toString req, toString resp, toString next]

genErrorHandler :: Application -> Error -> Request -> Response -> ExpressM Unit -> ExpressM Unit
genErrorHandler mockApp err req resp next =
    return $ runFn2 putCall mockApp $
        fnCall "handler" [toString err, toString req, toString resp, toString next]

testBindHttp :: forall e. Application -> Method -> String -> AssertionExpress e
testBindHttp mockApp method route = do
    return $ runFn1 clearCalls mockApp
    liftEff $ intlAppHttp mockApp (show method) route (genHandler mockApp)
    assertCalls mockApp [
        fnCall (show method) [route],
        fnCall "handler" ["request", "response", "next"]
    ]

testMiddleware :: forall e h.
    Application
    -> (Application -> h -> ExpressM Unit)
    -> (Application -> h)
    -> Array FnCall
    -> AssertionExpress e
testMiddleware mockApp useFn handlerGenFn expectedCalls = do
    return $ runFn1 clearCalls mockApp
    liftEff $ useFn mockApp (handlerGenFn mockApp)
    assertCalls mockApp expectedCalls

testSuite = do
    let mockApp = runFn0 createMockApp
    test "Internal.App.getProperty" do
        assertProperty mockApp "stringProperty" (Just "string")
        -- FIXME: Uncomment when there is IsForeign Int instance
        -- assertProperty mockApp "intProperty" (Just 42)
        assertProperty mockApp "floatProperty" (Just 100.1)
        assertProperty mockApp "booleanProperty" (Just true)
        assertProperty mockApp "booleanFalseProperty" (Just false)
        assertProperty mockApp "arrayProperty" (Just ["a", "b", "c"])
        assertProperty mockApp "emptyArrayProperty" (Just [] :: Maybe (Array String))
    test "Internal.App.setProperty" do
        assertProperty mockApp "testProperty" (Nothing :: Maybe String)
        liftEff $ intlAppSetProp mockApp "testProperty" "OK"
        assertProperty mockApp "testProperty" (Just "OK")
    test "Internal.App.bindHttp" do
        testBindHttp mockApp ALL "/some/path"
        testBindHttp mockApp GET "/some/path"
        testBindHttp mockApp POST "/some/path"
        testBindHttp mockApp PUT "/some/path"
        testBindHttp mockApp DELETE "/some/path"
        testBindHttp mockApp OPTIONS "/some/path"
        testBindHttp mockApp HEAD "/some/path"
        testBindHttp mockApp TRACE "/some/path"
    test "Internal.App.useMiddleware" do
        testMiddleware mockApp intlAppUse genHandler
            [ fnCall "use" [], fnCall "handler" ["request", "response", "next"] ]
    test "Internal.App.useMiddlewareOnError" do
        testMiddleware mockApp intlAppUseOnError genErrorHandler
            [ fnCall "use" [], fnCall "handler" ["error", "request", "response", "next"] ]
    test "Internal.App.useExternalMiddleware" do
        testMiddleware mockApp intlAppUseExternal (runFn1 createMockMiddleware)
            [ fnCall "use" [], fnCall "handler" ["request", "response", "next"] ]
    test "Internal.App.useMiddlewareAt" do
        let route = "/some/path"
            intlAppUseAtWrapper a = intlAppUseAt a route
        testMiddleware mockApp intlAppUseAtWrapper genHandler
            [ fnCall "use" [route], fnCall "handler" ["request", "response", "next"] ]

module Test.App (testSuite) where

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Exception
import Data.Array (zip, zipWith, foldM, length, filter, null)
import Data.Foreign.Class
import Data.Foreign.Null
import Data.Foreign.Undefined
import Data.Function
import Data.Maybe
import Data.Tuple
import Node.Express.Types
import Node.Express.Internal.App
import Prelude
import Test.Unit
import Test.Unit.Console
import Unsafe.Coerce

type FnCall = { name :: String, arguments :: Array String }

fnCall :: String -> Array String -> FnCall
fnCall name args = { name: name, arguments: args }

foreign import putCall :: Fn2 Application FnCall Unit
foreign import getCalls :: Fn1 Application (Array FnCall)
foreign import clearCalls :: Fn1 Application Unit

foreign import createMockApp :: Fn0 Application
foreign import createMockMiddleware :: Fn1 Application (Fn3 Request Response (ExpressM Unit) (ExpressM Unit))

type TestExpress e a = Eff ( express :: Express, testOutput :: TestOutput | e ) a
type AssertionExpress e = Assertion ( express :: Express, testOutput :: TestOutput | e)

toString :: forall a. a -> String
toString = unsafeCoerce

assertMatch :: forall a e. (Show a, Eq a) => String -> a -> a -> Assertion e
assertMatch what expected actual = do
    let errorMessage = what ++ " mismatch: Expected [ " ++ show expected ++ " ], Got [ " ++ show actual ++ " ]"
    assert errorMessage (expected == actual)

assertProperty ::
    forall a e. (Show a, Eq a, IsForeign a) =>
    Application -> String -> Maybe a -> AssertionExpress e
assertProperty mockApp property expected = do
    actual <- liftEff $ intlAppGetProp mockApp property
    assertMatch "Property" expected actual

assertCalls :: forall e. Application -> Array FnCall -> Assertion e
assertCalls mockApp expectedCalls = do
    let actualCalls = runFn1 getCalls mockApp
    assertMatch "Calls size" (length expectedCalls) (length actualCalls)
    foldM assertCallsMatch unit (zip expectedCalls actualCalls)
  where
    assertCallsMatch _ (Tuple expected actual) = do
        assertMatch "Call name" expected.name actual.name
        assertArgumentsMatch expected.arguments actual.arguments
    assertArgumentsMatch expected actual = do
        let lengthMatch = length expected == length actual
            argsMatch = null $ filter unmatched (zip expected actual)
            unmatched (Tuple e a) = e /= a
            errorMessage = "Call arguments mismatch: Expected [ " ++ show expected ++ " ], Got [ " ++ show actual ++ " ]"
        assert errorMessage (lengthMatch && argsMatch)

genHandler :: Application -> Request -> Response -> ExpressM Unit -> ExpressM Unit
genHandler mockApp req resp next =
    return $ runFn2 putCall mockApp $
        fnCall "handler" [toString req, toString resp, toString next]

genErrorHandler :: Application -> Error -> Request -> Response -> ExpressM Unit -> ExpressM Unit
genErrorHandler mockApp err req resp next =
    return $ runFn2 putCall mockApp $
        fnCall "handler" [toString err, toString req, toString resp, toString next]

testBindHttp :: forall e. Application -> Method -> String -> AssertionExpress e
testBindHttp mockApp method route = do
    return $ runFn1 clearCalls mockApp
    liftEff $ intlAppHttp mockApp (show method) route (genHandler mockApp)
    assertCalls mockApp [
        fnCall (show method) [route],
        fnCall "handler" ["request", "response", "next"]
    ]

testSuite = do
    let mockApp = runFn0 createMockApp
    test "Internal.App.getProperty" do
        assertProperty mockApp "stringProperty" (Just "string")
        -- Uncomment when there is IsForeign Int instance
        -- assertProperty mockApp "intProperty" (Just 42)
        assertProperty mockApp "floatProperty" (Just 100.1)
        assertProperty mockApp "booleanProperty" (Just true)
        assertProperty mockApp "booleanFalseProperty" (Just false)
        assertProperty mockApp "arrayProperty" (Just ["a", "b", "c"])
        assertProperty mockApp "emptyArrayProperty" (Just [] :: Maybe (Array String))
    test "Internal.App.setProperty" do
        assertProperty mockApp "testProperty" (Nothing :: Maybe String)
        liftEff $ intlAppSetProp mockApp "testProperty" "OK"
        assertProperty mockApp "testProperty" (Just "OK")
    test "Internal.App.bindHttp" do
        testBindHttp mockApp ALL "/some/path"
        testBindHttp mockApp GET "/some/path"
        testBindHttp mockApp POST "/some/path"
        testBindHttp mockApp PUT "/some/path"
        testBindHttp mockApp DELETE "/some/path"
        testBindHttp mockApp OPTIONS "/some/path"
        testBindHttp mockApp HEAD "/some/path"
        testBindHttp mockApp TRACE "/some/path"
    test "Internal.App.useMiddleware" do
        return $ runFn1 clearCalls mockApp
        liftEff $ intlAppUse mockApp (genHandler mockApp)
        assertCalls mockApp [
            fnCall "use" [],
            fnCall "handler" ["request", "response", "next"]
        ]
    test "Internal.App.useMiddlewareOnError" do
        return $ runFn1 clearCalls mockApp
        liftEff $ intlAppUseOnError mockApp (genErrorHandler mockApp)
        assertCalls mockApp [
            fnCall "use" [],
            fnCall "handler" ["error", "request", "response", "next"]
        ]
    test "Internal.App.useExternalMiddleware" do
        return $ runFn1 clearCalls mockApp
        liftEff $ intlAppUseExternal mockApp (runFn1 createMockMiddleware mockApp)
        assertCalls mockApp [
            fnCall "use" [],
            fnCall "handler" ["request", "response", "next"]
        ]
    test "Internal.App.useMiddlewareAt" do
        let route = "/some/path"
        return $ runFn1 clearCalls mockApp
        liftEff $ intlAppUseAt mockApp route (genHandler mockApp)
        assertCalls mockApp [
            fnCall "use" [route],
            fnCall "handler" ["request", "response", "next"]
        ]


Fix extra https:// in fixed-point combinator link

module Components.Help
  ( component
  ) where

import Lambda.Prelude

import React.Basic (JSX, fragment)
import React.Basic.DOM as R

component :: {} -> JSX
component _ = fragment $ toJSX <$> tutorial

data Markup
  = Header String
  | Para (Array Leaf)
  | Code (Array String)
  | Comments (Array Comment)

data Leaf
  = Text String
  | Bold String
  | Mono String
  | Link String String

data Comment
  = Comment String (Array Leaf)

-- | Convert `Markup` to styled `JSX`
toJSX :: Markup -> JSX
toJSX = case _ of
  Header t ->
    R.h3_ [R.text t]
  Para ls ->
    R.p
      { children: formatLeaf <$> ls
      }
  Code cs ->
    R.p
      { className: "preformatted"
      , children: formatCode <$> cs
      }
  Comments as ->
    R.table_ [R.tbody_ $ formatComment <$> as]
 where
  formatLeaf :: Leaf -> JSX
  formatLeaf = case _ of
    Text t ->
      R.text t
    Bold t ->
      R.strong_ [R.text t]
    Link url t ->
      R.a
        { href: "https://" <> url
        , children: [R.text t]
        }
    Mono t ->
      R.span
        { className: "monospace-font"
        , children: [R.text t]
        }

  formatCode :: String -> JSX
  formatCode code = R.text $ "  " <> code <> "\n"

  formatComment :: Comment -> JSX
  formatComment (Comment t cs) =
    R.tr_
      [ R.td_
        [ R.span
          { className: "preformatted"
          , children: [formatCode t]
          }
        ]
      , R.td
        { className: "comment"
        , children: formatLeaf <$> cs
        }
      ]

tutorial :: Array Markup
tutorial =
  [ Header "Hello!"
  , Para
    [ Text "Welcome to Lambda Machine, a tool for stepping through expressions in the untyped lambda calculus."
    ]
  , Header "Expressions"
  , Para
    [ Text "Lambda Machine accepts "
    , Bold "expressions"
    , Text " and "
    , Bold "definitions"
    , Text ". An "
    , Bold "expression"
    , Text " consists of variables, applications, and lambdas. Lambdas can be written with a backslash "
    , Bold "\\"
    , Text " or the Greek letter "
    , Bold "λ"
    , Text ". We'll use "
    , Bold "\\"
    , Text " since it's easier to type. Here's an expression that represents a function that accepts one argument and returns it immediately."
    ]
  , Code
    [ "\\x. x"
    ]
  , Para
    [ Text "We call this function "
    , Bold "identity"
    , Text "."
    ]
  , Para
    [ Text "Here's a function that returns its first argument after throwing away its second argument."
    ]
  , Code
    [ "\\x. \\y. x"
    ]
  , Para
    [ Text "We usually call this function "
    , Bold "const"
    , Text "."
    ]
  , Para
    [ Text "Note that the expression above is a function that returns another function."
    , Text " For convenience we can write it as a single lambda with two arguments."
    ]
  , Code
    [ "\\x y. x"
    ]
  , Para
    [ Text "We'll use the multi-argument form instead of manually nesting lambdas from now on."
    ]
  , Para
    [ Text "We can apply "
    , Bold "const"
    , Text " to "
    , Bold "identity"
    , Text " twice using "
    , Bold "juxtaposition"
    , Text ", which is a fancy word for \"putting things next to one another\"."
    ]
  , Code
    [ "(\\x y. x) (\\x. x) (\\x. x)"
    ]
  , Para
    [ Text "Even if we rename the arguments to our "
    , Bold "identity"
    , Text " functions, they still do the same thing."
    ]
  , Code
    [ "(\\x y. x) (\\a. a) (\\b. b)"
    ]
  , Para
    [ Text "Specifically, this expression reduces as follows."
    ]
  , Comments
    [ Comment
      "(\\x y. x) (\\a. a) (\\b. b)"
      [ Text "Replace "
      , Mono "x"
      , Text " with "
      , Mono "(\\a. a)"
      , Text " in "
      , Mono "(\\x y. x)"
      ]
    , Comment
      "(\\y. \\a. a) (\\b. b)"
      [ Text "Replace "
      , Mono "y"
      , Text " with "
      , Mono "(\\b. b)"
      , Text " in "
      , Mono "(\\y. \\a. a)"
      ]
    , Comment "\\a. a" []
    ]
  , Header "Definitions"
  , Para
    [ Text "To avoid repeating ourselves, we can enter a "
    , Bold "definition"
    , Text ". A "
    , Bold "definition"
    , Text " consists of a name, zero or more arguments, an equals sign, and an "
    , Bold "expression"
    , Text ". Let's make definitions for "
    , Bold "identity"
    , Text " and "
    , Bold "const"
    , Text "."
    ]
  , Code
    [ "identity = \\x. x"
    , "const = \\x y. x"
    ]
  , Para
    [ Text "We can also write these like so."
    ]
  , Code
    [ "identity x = x"
    , "const x y = x"
    ]
  , Para
    [ Text "Now we can refer to them by name."
    ]
  , Code
    [ "const identity identity"
    ]
  , Para
    [ Text "A name is reduced by replacing it with the expression on the right-hand-side of its definition."
    ]
  , Comments
    [ Comment
      "const identity identity"
      [ Text "Replace "
      , Mono "const"
      , Text " with "
      , Mono "\\x. \\y. x"
      ]
    , Comment
      "(\\x. \\y. x) identity identity"
      [ Text "Replace "
      , Mono "x"
      , Text " with "
      , Mono "identity"
      , Text " in "
      , Mono "(\\x. \\y. x)"
      ]
    , Comment
      "(\\y. identity) identity"
      [ Text "Replace "
      , Mono "y"
      , Text " with "
      , Mono "identity"
      , Text " in "
      , Mono "(\\y. identity)"
      ]
    , Comment
      "identity"
      [ Text "Replace "
      , Mono "identity"
      , Text " with "
      , Mono "\\x. x"
      ]
    , Comment "\\x. x" []
    ]
  , Header "Syntactic Sugar"
  , Para
    [ Text "Lambda Machine can parse natural numbers. A natural number "
    , Bold "n"
    , Text " is parsed as a function that applies "
    , Bold "s"
    , Text " to "
    , Bold "z n"
    , Text " times."
    ]
  , Code
    [ "0 -> \\s. \\z. z"
    , "1 -> \\s. \\z. s z"
    , "2 -> \\s. \\z. s (s z)"
    , "3 -> \\s. \\z. s (s (s z))"
    , "4 -> \\s. \\z. s (s (s (s z)))"
    ]
  , Para
    [ Text "You can read more about this encoding "
    , Link "en.wikipedia.org/wiki/Church_encoding" "here"
    , Text "."
    ]
  , Para
    [ Text "Lambda Machine can also parse lists."
    , Text " A list is parsed as a right fold over the elements using "
    , Bold "cons"
    , Text " and "
    , Bold "nil"
    , Text "."
    ]
  , Code
    [ "[a] -> \\cons. \\nil. cons a nil"
    , "[a, b] -> \\cons. \\nil. cons a (cons b nil)"
    , "[a, b, c] -> \\cons. \\nil. cons a (cons b (cons c nil))"
    ]
  , Para
    [ Text "This works with natural numbers as well."
    ]
  , Code
    [ "[1] -> \\cons. \\nil. cons (\\s. \\z. s z) nil"
    , "[1, 2] -> \\cons. \\nil. cons (\\s. \\z. s z) (cons (\\s. \\z. s (s z)) nil)"
    ]
  , Header "Recursion"
  , Para
    [ Text "The lambda calculus doesn't have recursive definitions."
    , Text " After all, how would an anonymous function call itself?"
    , Text " Instead, there are several well-known "
    , Bold "fixed-point combinators"
    , Text " that can "
    , Bold "pass a copy of a function to itself"
    , Text ", which it can then apply (effectively giving us the power of recursion)."
    ]
  , Para
    [ Text "You can read about fixed-point combinators "
    , Link "en.wikipedia.org/wiki/Fixed-point_combinator" "here"
    , Text "."
    ]
  , Para
    [ Text "We used to predefine this one:"
    ]
  , Code
    [ "fix f = (λx. f (x x)) (λy. f (y y))"
    ]
  , Para
    [ Mono "fix"
    , Text " is powerful enough to define recursive functions,"
    , Text " but it can be difficult to follow their reduction."
    , Text " Many steps are spent just duplicating the function"
    , Text " and passing it to itself."
    , Text " Therefore, lambda-machine allows top-level definitions to"
    , Text " be defined using direct recursion."
    , Text " For examples, see the definitions of "
    , Mono "iterate"
    , Text " and "
    , Mono "repeat"
    , Text "."
    ]
  , Header "Bye!"
  , Para
    [ Text "Have fun and "
    , Link "github.com/cdparks/lambda-machine" "let me know if you find this useful"
    , Text "!"
    ]
  ]

module Components.Help
  ( component
  ) where

import Lambda.Prelude

import React.Basic (JSX, fragment)
import React.Basic.DOM as R

component :: {} -> JSX
component _ = fragment $ toJSX <$> tutorial

data Markup
  = Header String
  | Para (Array Leaf)
  | Code (Array String)
  | Comments (Array Comment)

data Leaf
  = Text String
  | Bold String
  | Mono String
  | Link String String

data Comment
  = Comment String (Array Leaf)

-- | Convert `Markup` to styled `JSX`
toJSX :: Markup -> JSX
toJSX = case _ of
  Header t ->
    R.h3_ [R.text t]
  Para ls ->
    R.p
      { children: formatLeaf <$> ls
      }
  Code cs ->
    R.p
      { className: "preformatted"
      , children: formatCode <$> cs
      }
  Comments as ->
    R.table_ [R.tbody_ $ formatComment <$> as]
 where
  formatLeaf :: Leaf -> JSX
  formatLeaf = case _ of
    Text t ->
      R.text t
    Bold t ->
      R.strong_ [R.text t]
    Link url t ->
      R.a
        { href: "https://" <> url
        , children: [R.text t]
        }
    Mono t ->
      R.span
        { className: "monospace-font"
        , children: [R.text t]
        }

  formatCode :: String -> JSX
  formatCode code = R.text $ "  " <> code <> "\n"

  formatComment :: Comment -> JSX
  formatComment (Comment t cs) =
    R.tr_
      [ R.td_
        [ R.span
          { className: "preformatted"
          , children: [formatCode t]
          }
        ]
      , R.td
        { className: "comment"
        , children: formatLeaf <$> cs
        }
      ]

tutorial :: Array Markup
tutorial =
  [ Header "Hello!"
  , Para
    [ Text "Welcome to Lambda Machine, a tool for stepping through expressions in the untyped lambda calculus."
    ]
  , Header "Expressions"
  , Para
    [ Text "Lambda Machine accepts "
    , Bold "expressions"
    , Text " and "
    , Bold "definitions"
    , Text ". An "
    , Bold "expression"
    , Text " consists of variables, applications, and lambdas. Lambdas can be written with a backslash "
    , Bold "\\"
    , Text " or the Greek letter "
    , Bold "λ"
    , Text ". We'll use "
    , Bold "\\"
    , Text " since it's easier to type. Here's an expression that represents a function that accepts one argument and returns it immediately."
    ]
  , Code
    [ "\\x. x"
    ]
  , Para
    [ Text "We call this function "
    , Bold "identity"
    , Text "."
    ]
  , Para
    [ Text "Here's a function that returns its first argument after throwing away its second argument."
    ]
  , Code
    [ "\\x. \\y. x"
    ]
  , Para
    [ Text "We usually call this function "
    , Bold "const"
    , Text "."
    ]
  , Para
    [ Text "Note that the expression above is a function that returns another function."
    , Text " For convenience we can write it as a single lambda with two arguments."
    ]
  , Code
    [ "\\x y. x"
    ]
  , Para
    [ Text "We'll use the multi-argument form instead of manually nesting lambdas from now on."
    ]
  , Para
    [ Text "We can apply "
    , Bold "const"
    , Text " to "
    , Bold "identity"
    , Text " twice using "
    , Bold "juxtaposition"
    , Text ", which is a fancy word for \"putting things next to one another\"."
    ]
  , Code
    [ "(\\x y. x) (\\x. x) (\\x. x)"
    ]
  , Para
    [ Text "Even if we rename the arguments to our "
    , Bold "identity"
    , Text " functions, they still do the same thing."
    ]
  , Code
    [ "(\\x y. x) (\\a. a) (\\b. b)"
    ]
  , Para
    [ Text "Specifically, this expression reduces as follows."
    ]
  , Comments
    [ Comment
      "(\\x y. x) (\\a. a) (\\b. b)"
      [ Text "Replace "
      , Mono "x"
      , Text " with "
      , Mono "(\\a. a)"
      , Text " in "
      , Mono "(\\x y. x)"
      ]
    , Comment
      "(\\y. \\a. a) (\\b. b)"
      [ Text "Replace "
      , Mono "y"
      , Text " with "
      , Mono "(\\b. b)"
      , Text " in "
      , Mono "(\\y. \\a. a)"
      ]
    , Comment "\\a. a" []
    ]
  , Header "Definitions"
  , Para
    [ Text "To avoid repeating ourselves, we can enter a "
    , Bold "definition"
    , Text ". A "
    , Bold "definition"
    , Text " consists of a name, zero or more arguments, an equals sign, and an "
    , Bold "expression"
    , Text ". Let's make definitions for "
    , Bold "identity"
    , Text " and "
    , Bold "const"
    , Text "."
    ]
  , Code
    [ "identity = \\x. x"
    , "const = \\x y. x"
    ]
  , Para
    [ Text "We can also write these like so."
    ]
  , Code
    [ "identity x = x"
    , "const x y = x"
    ]
  , Para
    [ Text "Now we can refer to them by name."
    ]
  , Code
    [ "const identity identity"
    ]
  , Para
    [ Text "A name is reduced by replacing it with the expression on the right-hand-side of its definition."
    ]
  , Comments
    [ Comment
      "const identity identity"
      [ Text "Replace "
      , Mono "const"
      , Text " with "
      , Mono "\\x. \\y. x"
      ]
    , Comment
      "(\\x. \\y. x) identity identity"
      [ Text "Replace "
      , Mono "x"
      , Text " with "
      , Mono "identity"
      , Text " in "
      , Mono "(\\x. \\y. x)"
      ]
    , Comment
      "(\\y. identity) identity"
      [ Text "Replace "
      , Mono "y"
      , Text " with "
      , Mono "identity"
      , Text " in "
      , Mono "(\\y. identity)"
      ]
    , Comment
      "identity"
      [ Text "Replace "
      , Mono "identity"
      , Text " with "
      , Mono "\\x. x"
      ]
    , Comment "\\x. x" []
    ]
  , Header "Syntactic Sugar"
  , Para
    [ Text "Lambda Machine can parse natural numbers. A natural number "
    , Bold "n"
    , Text " is parsed as a function that applies "
    , Bold "s"
    , Text " to "
    , Bold "z n"
    , Text " times."
    ]
  , Code
    [ "0 -> \\s. \\z. z"
    , "1 -> \\s. \\z. s z"
    , "2 -> \\s. \\z. s (s z)"
    , "3 -> \\s. \\z. s (s (s z))"
    , "4 -> \\s. \\z. s (s (s (s z)))"
    ]
  , Para
    [ Text "You can read more about this encoding "
    , Link "en.wikipedia.org/wiki/Church_encoding" "here"
    , Text "."
    ]
  , Para
    [ Text "Lambda Machine can also parse lists."
    , Text " A list is parsed as a right fold over the elements using "
    , Bold "cons"
    , Text " and "
    , Bold "nil"
    , Text "."
    ]
  , Code
    [ "[a] -> \\cons. \\nil. cons a nil"
    , "[a, b] -> \\cons. \\nil. cons a (cons b nil)"
    , "[a, b, c] -> \\cons. \\nil. cons a (cons b (cons c nil))"
    ]
  , Para
    [ Text "This works with natural numbers as well."
    ]
  , Code
    [ "[1] -> \\cons. \\nil. cons (\\s. \\z. s z) nil"
    , "[1, 2] -> \\cons. \\nil. cons (\\s. \\z. s z) (cons (\\s. \\z. s (s z)) nil)"
    ]
  , Header "Recursion"
  , Para
    [ Text "The lambda calculus doesn't have recursive definitions."
    , Text " After all, how would an anonymous function call itself?"
    , Text " Instead, there are several well-known "
    , Bold "fixed-point combinators"
    , Text " that can "
    , Bold "pass a copy of a function to itself"
    , Text ", which it can then apply (effectively giving us the power of recursion)."
    ]
  , Para
    [ Text "You can read about fixed-point combinators "
    , Link "https://en.wikipedia.org/wiki/Fixed-point_combinator" "here"
    , Text "."
    ]
  , Para
    [ Text "We used to predefine this one:"
    ]
  , Code
    [ "fix f = (λx. f (x x)) (λy. f (y y))"
    ]
  , Para
    [ Mono "fix"
    , Text " is powerful enough to define recursive functions,"
    , Text " but it can be difficult to follow their reduction."
    , Text " Many steps are spent just duplicating the function"
    , Text " and passing it to itself."
    , Text " Therefore, lambda-machine allows top-level definitions to"
    , Text " be defined using direct recursion."
    , Text " For examples, see the definitions of "
    , Mono "iterate"
    , Text " and "
    , Mono "repeat"
    , Text "."
    ]
  , Header "Bye!"
  , Para
    [ Text "Have fun and "
    , Link "github.com/cdparks/lambda-machine" "let me know if you find this useful"
    , Text "!"
    ]
  ]


Don’t let MonadZero imply its deprecation warning (#68)

Co-authored-by: JordanMartinez <76564d8b0fc09c8f5cd6adc16b4076fbfd63082b@gmail.com>
Co-authored-by: Thomas Honeyman <d033e22ae348aeb5660fc2140aec35850c4da997@thomashoneyman.com>

-- | This module is **deprecated** and will be removed in a future release.
-- |
-- | The annihilation law witnessed by `MonadZero` is trivially satisfied by
-- | lawful monads due to parametricity: while evaluating `empty >>= f`, the
-- | function `f` can’t ever be called, since that would require `empty` to
-- | produce a value, which means that `empty >>= f` must be the same as
-- | `empty >>= pure`, which by the monad laws is just `empty`.
-- |
-- | Use `Monad` and `Alternative` constraints instead.

module Control.MonadZero
  ( class MonadZeroIsDeprecated
  , class MonadZero
  , module Control.Alt
  , module Control.Alternative
  , module Control.Applicative
  , module Control.Apply
  , module Control.Bind
  , module Control.Monad
  , module Control.Plus
  , module Data.Functor
  ) where

import Control.Alt (class Alt, alt, (<|>))
import Control.Alternative (class Alternative, guard)
import Control.Applicative (class Applicative, pure, liftA1, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Bind (class Bind, bind, ifM, join, (<=<), (=<<), (>=>), (>>=))
import Control.Monad (class Monad, ap, liftM1)
import Control.Plus (class Plus, empty)

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))

import Prim.TypeError (class Warn, Text)

class MonadZeroIsDeprecated
instance monadZeroIsDeprecated :: Warn (Text "'MonadZero' is deprecated, use 'Monad' and 'Alternative' constraints instead") => MonadZeroIsDeprecated

-- | The `MonadZero` type class has no members of its own; it just specifies
-- | that the type has both `Monad` and `Alternative` instances.
-- |
-- | Types which have `MonadZero` instances should also satisfy the following
-- | laws:
-- |
-- | - Annihilation: `empty >>= f = empty`
class (Monad m, Alternative m, MonadZeroIsDeprecated) <= MonadZero m

instance monadZeroArray :: MonadZero Array

-- | This module is **deprecated** and will be removed in a future release.
-- |
-- | The annihilation law witnessed by `MonadZero` is trivially satisfied by
-- | lawful monads due to parametricity: while evaluating `empty >>= f`, the
-- | function `f` can’t ever be called, since that would require `empty` to
-- | produce a value, which means that `empty >>= f` must be the same as
-- | `empty >>= pure`, which by the monad laws is just `empty`.
-- |
-- | Use `Monad` and `Alternative` constraints instead.

module Control.MonadZero
  ( class MonadZero
  , module Control.Alt
  , module Control.Alternative
  , module Control.Applicative
  , module Control.Apply
  , module Control.Bind
  , module Control.Monad
  , module Control.Plus
  , module Data.Functor
  ) where

import Control.Alt (class Alt, alt, (<|>))
import Control.Alternative (class Alternative, guard)
import Control.Applicative (class Applicative, pure, liftA1, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Bind (class Bind, bind, ifM, join, (<=<), (=<<), (>=>), (>>=))
import Control.Monad (class Monad, ap, liftM1)
import Control.Plus (class Plus, empty)

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))

import Prim.TypeError (class Warn, Text)

-- | The `MonadZero` type class has no members of its own; it just specifies
-- | that the type has both `Monad` and `Alternative` instances.
-- |
-- | Types which have `MonadZero` instances should also satisfy the following
-- | laws:
-- |
-- | - Annihilation: `empty >>= f = empty`
class (Monad m, Alternative m, Warn (Text "'MonadZero' is deprecated, use 'Monad' and 'Alternative' constraints instead")) <= MonadZero m

instance monadZeroArray :: MonadZero Array


Remove unused import

Remove unused import

module Halogen.Component
  ( ComponentP()
  , Component()
  , Render()
  , Eval()
  , Peek()
  , PeekP()
  , renderComponent
  , queryComponent
  , component
  , component'
  , ChildState()
  , createChild
  , createChild'
  , ParentComponent()
  , ParentComponentP()
  , InstalledComponent()
  , InstalledState()
  , installedState
  , ChildF(..)
  , QueryF()
  , mkQuery
  , mkQuery'
  , liftQuery
  , query
  , query'
  , install
  , install'
  ) where

import Prelude

import Control.Apply ((<*))
import Control.Bind ((=<<), (<=<), (>=>))
import Control.Coroutine (await)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (MonadEff, liftEff)
import Control.Monad.Free (Free(), foldFree, liftF, mapF)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (State(), runState)
import Control.Monad.Trans (lift)
import Control.Plus (Plus, empty)
import qualified Control.Monad.State.Class as CMS
import qualified Control.Monad.State.Trans as CMS

import Data.Bifunctor (bimap, lmap, rmap)
import Data.Const (Const())
import Data.Either (Either(..), either)
import Data.Functor.Coproduct (Coproduct(..), coproduct, left, right)
import Data.Maybe (Maybe(..), maybe, fromMaybe')
import Data.NaturalTransformation (Natural())
import Data.Tuple (Tuple(..), snd)
import Data.Void (Void())
import qualified Data.Either.Unsafe as U
import qualified Data.Map as M
import qualified Data.Maybe.Unsafe as U

import Halogen.Component.ChildPath (ChildPath(), injState, injQuery, injSlot, prjState, prjQuery, prjSlot)
import Halogen.HTML.Core (HTML(..), fillSlot)
import Halogen.Query (HalogenF(), get)
import Halogen.Query.StateF (StateF(), mapState)
import Halogen.Query.SubscribeF (SubscribeF(), subscribeN, remapSubscribe, hoistSubscribe)

-- | Data type for Halogen components.
-- | - `s` - the type of the component state
-- | - `f` - the component's query algebra
-- | - `g` - the monad handling the component's non-state effects
-- | - `o` - the type of values observable via `peek`, used to allow parent
-- |         components to see queries their children have acted upon.
-- | - `p` - the type of slots within the component, used to specify locations
-- |         at which child components can be installed.
newtype ComponentP s f g o p = Component
  { render :: State s (HTML p (f Unit))
  , eval   :: Eval f s f g
  , peek   :: PeekP s f g o
  }

-- | A type alias for Halogen components where `peek` is not used.
type Component s f g = ComponentP s f g (Const Void)

instance functorComponent :: Functor (ComponentP s f g o) where
  map f (Component c) = Component { render: lmap f <$> c.render, eval: c.eval, peek: c.peek }

-- | A type alias for a component `render` function.
type Render s f p = s -> HTML p (f Unit)

-- | A type alias for a component `eval` function that takes a value from the
-- | component's query algebra and returns a `Free` monad of the Halogen
-- | component algebra.
type Eval i s f g = Natural i (Free (HalogenF s f g))

-- | A type alias for a component `peek` function that observes inputs to child
-- | components.
type Peek s s' f f' g p p' = PeekP s f (QueryF s s' f' g p p') (ChildF p f')

-- | A lower level form of the `Peek` type synonym, used internally.
type PeekP s f g o = forall a. o a -> Free (HalogenF s f g) Unit

-- | Runs a component's `render` function with the specified state, returning
-- | the generated `HTML` and new state.
renderComponent :: forall s f g o p. ComponentP s f g o p -> s -> Tuple (HTML p (f Unit)) s
renderComponent (Component c) = runState c.render

-- | Runs a compnent's `query` function with the specified query input and
-- | returns the pending computation as a `Free` monad.
queryComponent :: forall s f g o p. ComponentP s f g o p -> Eval f s f g
queryComponent (Component c) = c.eval

-- | Runs a parent component's `peek` function.
peekComponent :: forall s f g o p. ComponentP s f g o p -> PeekP s f g o
peekComponent (Component c) = c.peek

-- | Builds a new [`Component`](#component) from a [`Render`](#render) and
-- | [`Eval`](#eval) function.
component :: forall s f g p. Render s f p -> Eval f s f g -> Component s f g p
component r q = Component { render: CMS.gets r, eval: q, peek: const (pure unit) }

-- | Builds a new [`ComponentP`](#componentp) from a [`Render`](#render),
-- | [`Eval`](#eval), and [`Peek`](#peek) function. This is used in cases where
-- | defining a parent component that needs to observe inputs to its children.
component' :: forall s s' f f' g p p'. Render s f p -> Eval f s f (QueryF s s' f' g p p') -> Peek s s' f f' g p p' -> ParentComponentP s s' f f' g p p'
component' r q p = Component { render: CMS.gets r, eval: q, peek: p }

-- | A type synonym for a component combined with its state. This is used when
-- | installing components into slots.
type ChildState s f g p = Tuple (Component s f g p) s

-- | Creates a `ChildState` for a component.
createChild :: forall s f g p. Component s f g p -> s -> ChildState s f g p
createChild c s = Tuple c s

-- | Creates a `ChildState` for a component that is being installed into a
-- | parent with multiple different types of child component.
createChild' :: forall s s' f f' g p p' q. (Functor g) => ChildPath s s' f f' p p' -> Component s f g q -> s -> ChildState s' f' g q
createChild' i c s = Tuple (transform i c) (injState i s)

-- | A type alias used to simplify the type signature for a `Component s f g p`
-- | that is intended to have components of type `Component s' f' g p'`
-- | installed into it.
type ParentComponent s s' f f' g p p' = Component s f (QueryF s s' f' g p p') p

-- | A type alias similar to `ParentComponent`, but for components that `peek`
-- | on their children.
type ParentComponentP s s' f f' g p p' = ComponentP s f (QueryF s s' f' g p p') (ChildF p f') p

-- | A type alias use to simplify the type signature for a `Component s f g p`
-- | that has had components of type `Component s' f' g p'` installed into it.
type InstalledComponent s s' f f' g p p' = Component (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g p'

-- | The type used by component containers for their state where `s` is the
-- | state local to the container, `p` is the type of slot used by the
-- | container, and the remaining parameters are the type variables for the
-- | child components.
type InstalledState s s' f' g p p' =
  { parent   :: s
  , children :: M.Map p (ChildState s' f' g p')
  }

-- | Creates an initial `InstalledState` value for a component container based
-- | on a state value for the container.
installedState :: forall s s' f' g p p'. (Ord p) => s -> InstalledState s s' f' g p p'
installedState = { parent: _, children: M.empty }

-- | An intermediate algebra that parent components "produce" from their `eval`
-- | and `peek` functions. This takes the place of `g` when compared to a leaf
-- | (non-parent) component.
type QueryF s s' f' g p p' = Free (HalogenF (InstalledState s s' f' g p p') (ChildF p f') g)

-- | An intermediate algebra used to associate values from a child component's
-- | algebra with the slot the component was installed into.
data ChildF p f i = ChildF p (f i)

instance functorChildF :: (Functor f) => Functor (ChildF p f) where
  map f (ChildF p fi) = ChildF p (f <$> fi)

-- | Queries a child component, for use within a parent component's `eval` or
-- | `peek` function.
query :: forall s s' f f' g p p' i. (Functor g, Ord p)
      => p
      -> f' i
      -> Free (HalogenF s f (QueryF s s' f' g p p')) (Maybe i)
query p q = liftQuery (mkQuery p q)

-- | A version of [`query`](#query) for use when a parent component has multiple
-- | types of child component.
query' :: forall s s' s'' f f' f'' g p p' p'' i. (Functor g, Ord p)
      => ChildPath s'' s' f'' f' p'' p
      -> p''
      -> f'' i
      -> Free (HalogenF s f (QueryF s s' f' g p p')) (Maybe i)
query' i p q = liftQuery (mkQuery' i p q)

-- | Creates a query for a child component where `p` is the slot the component
-- | was installed into and `f' i` in the input query.
-- |
-- | If a component is not found for the slot the result of the query
-- | will be `Nothing`.
mkQuery :: forall s s' f' p p' g i. (Functor g, Ord p)
      => p
      -> f' i
      -> QueryF s s' f' g p p' (Maybe i)
mkQuery p q = do
  st <- get
  case M.lookup p st.children of
    Nothing -> pure Nothing
    Just (Tuple c _) -> Just <$> mapF (coproduct (left <<< mapStateFChild p) (right <<< coproduct (left <<< remapSubscribe (ChildF p)) right)) (queryComponent c q)

-- | A version of [`mkQuery`](#mkQuery) for use when a parent component has
-- | multiple types of child component.
mkQuery' :: forall s s' s'' f f' g p p' p'' i. (Functor g, Ord p')
         => ChildPath s'' s' f f' p p'
         -> p
         -> f i
         -> QueryF s s' f' g p' p'' (Maybe i)
mkQuery' i p q = mkQuery (injSlot i p) (injQuery i q)

-- | Lifts a value in the `QueryF` algebra into the monad used by a component's
-- | `eval` function.
liftQuery :: forall s s' f f' g p p'. (Functor g)
          => Eval (QueryF s s' f' g p p') s f (QueryF s s' f' g p p')
liftQuery qf = liftF (right (right qf))

-- | Installs children into a parent component by using a function that produces
-- | `ChildState` values for a given slot.
install :: forall s s' f f' g p p'. (Plus g, Ord p)
        => ParentComponent s s' f f' g p p'
        -> (p -> ChildState s' f' g p')
        -> InstalledComponent s s' f f' g p p'
install c f = Component { render: render c f, eval: eval, peek: const (pure unit) }
  where
  eval :: Eval (Coproduct f (ChildF p f')) (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g
  eval = coproduct (queryParent c) queryChild

-- | A version of [`install`](#install) for use with parent components that
-- | `peek` on their children.
install' :: forall s s' f f' g p p'. (Plus g, Ord p)
        => ParentComponentP s s' f f' g p p'
        -> (p -> ChildState s' f' g p')
        -> InstalledComponent s s' f f' g p p'
install' c f = Component { render: render c f, eval: eval, peek: const (pure unit) }
  where
  eval :: Eval (Coproduct f (ChildF p f')) (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g
  eval = coproduct (queryParent c) (\q -> queryChild q <* peek q)

  peek :: PeekP (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g (ChildF p f')
  peek q =
    let runSubscribeF' = runSubscribeF (queryParent c)
    in foldFree (coproduct mergeParentStateF (coproduct runSubscribeF' liftChildF)) (peekComponent c q)

mapStateFParent :: forall s s' f' g p p'. Natural (StateF s) (StateF (InstalledState s s' f' g p p'))
mapStateFParent = mapState (_.parent) (\f st -> { parent: f st.parent, children: st.children })

mapStateFChild :: forall s s' f' g p p'. (Ord p) => p -> Natural (StateF s') (StateF (InstalledState s s' f' g p p'))
mapStateFChild p = mapState (\st -> U.fromJust $ snd <$> M.lookup p st.children)
                            (\f st -> { parent: st.parent, children: M.update (Just <<< rmap f) p st.children })

render :: forall s s' f f' g o p p'. (Ord p)
       => ComponentP s f (QueryF s s' f' g p p') o p
       -> (p -> ChildState s' f' g p')
       -> State (InstalledState s s' f' g p p') (HTML p' ((Coproduct f (ChildF p f')) Unit))
render c f = do
    st <- CMS.get
    case renderComponent c st.parent of
      Tuple html s -> do
        -- Empty the state so that we don't keep children that are no longer
        -- being rendered...
        CMS.put { parent: s, children: M.empty :: M.Map p (ChildState s' f' g p') }
        -- ...but then pass through the old state so we can lookup child
        -- components that are being re-rendered
        fillSlot (renderChild st) left html

  where

  renderChild :: InstalledState s s' f' g p p'
              -> p
              -> State (InstalledState s s' f' g p p') (HTML p' ((Coproduct f (ChildF p f')) Unit))
  renderChild st p = renderChild' st p $ fromMaybe' (\_ -> f p) (M.lookup p st.children)

  renderChild' :: InstalledState s s' f' g p p'
               -> p
               -> ChildState s' f' g p'
               -> State (InstalledState s s' f' g p p') (HTML p' ((Coproduct f (ChildF p f')) Unit))
  renderChild' st p (Tuple c s) = case renderComponent c s of
    Tuple html s' -> do
      CMS.modify (\st -> st { children = M.insert p (Tuple c s') st.children })
      pure $ right <<< ChildF p <$> html

queryParent :: forall s s' f f' g o p p' q. (Functor g)
            => ComponentP s f (QueryF s s' f' g p p') o q
            -> Eval f (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g
queryParent c q = foldFree (coproduct mergeParentStateF (coproduct (runSubscribeF (queryParent c)) liftChildF)) (queryComponent c q)

mergeParentStateF :: forall s s' f f' g p p'. Eval (StateF s) (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g
mergeParentStateF = liftF <<< left <<< mapStateFParent

runSubscribeF :: forall s s' f f' g p p'. (Functor g)
              => Eval f (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g
              -> Eval (SubscribeF f (Free (HalogenF (InstalledState s s' f' g p p') (ChildF p f') g))) (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g
runSubscribeF queryParent' = subscribeN (forever $ lift <<< queryParent' =<< await) <<< hoistSubscribe liftChildF

liftChildF :: forall s s' f f' g p p'. (Functor g)
           => Eval (Free (HalogenF (InstalledState s s' f' g p p') (ChildF p f') g)) (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g
liftChildF = mapF (coproduct left (right <<< coproduct (left <<< remapSubscribe right) right))

queryChild :: forall s s' f f' g p p'. (Plus g, Ord p)
           => Eval (ChildF p f') (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g
queryChild (ChildF p q) = mapF (coproduct left (right <<< coproduct (left <<< remapSubscribe right) right)) (mkQuery p q) >>= maybe empty' pure
  where
  empty' :: forall s f g a. (Plus g) => Free (HalogenF s f g) a
  empty' = liftF (right (right empty))

adaptState :: forall s t m a. (Monad m) => (s -> t) -> (t -> s) -> CMS.StateT s m a -> CMS.StateT t m a
adaptState st ts (CMS.StateT f) = CMS.StateT \state -> f (ts state) >>= \(Tuple a s) -> pure $ Tuple a (st s)

transform' :: forall s s' f f' g o o' p p'. (Functor g)
           => (s -> s')
           -> (s' -> s)
           -> Natural f f'
           -> Natural f' f
           -> Natural o' o
           -> (p -> p')
           -> ComponentP s f g o p
           -> ComponentP s' f' g o' p'
transform' sTo sFrom fTo fFrom oFrom tp (Component c) =
  Component { render: bimap tp fTo <$> adaptState sTo sFrom c.render
            , eval: mapF natHF <<< c.eval <<< fFrom
            , peek: mapF natHF <<< c.peek <<< oFrom
            }
  where
  natHF :: Natural (HalogenF s f g) (HalogenF s' f' g)
  natHF = coproduct (left <<< mapState sFrom (\f s -> sTo (f (sFrom s))))
                    (right <<< coproduct (left <<< remapSubscribe fTo) right)

transform :: forall s s' f f' g p p' q. (Functor g)
          => ChildPath s s' f f' p p'
          -> Component s f g q
          -> Component s' f' g q
transform i = transform' (injState i) (U.fromJust <<< prjState i) (injQuery i) (U.fromJust <<< prjQuery i) id id

module Halogen.Component
  ( ComponentP()
  , Component()
  , Render()
  , Eval()
  , Peek()
  , PeekP()
  , renderComponent
  , queryComponent
  , component
  , component'
  , ChildState()
  , createChild
  , createChild'
  , ParentComponent()
  , ParentComponentP()
  , InstalledComponent()
  , InstalledState()
  , installedState
  , ChildF(..)
  , QueryF()
  , mkQuery
  , mkQuery'
  , liftQuery
  , query
  , query'
  , install
  , install'
  ) where

import Prelude

import Control.Apply ((<*))
import Control.Bind ((=<<), (<=<), (>=>))
import Control.Coroutine (await)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (MonadEff, liftEff)
import Control.Monad.Free (Free(), foldFree, liftF, mapF)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (State(), runState)
import Control.Monad.Trans (lift)
import Control.Plus (Plus, empty)
import qualified Control.Monad.State.Class as CMS
import qualified Control.Monad.State.Trans as CMS

import Data.Bifunctor (bimap, lmap, rmap)
import Data.Const (Const())
import Data.Either (Either(..), either)
import Data.Functor.Coproduct (Coproduct(..), runCoproduct, coproduct, left, right)
import Data.Maybe (Maybe(..), maybe, fromMaybe')
import Data.NaturalTransformation (Natural())
import Data.Tuple (Tuple(..), snd)
import Data.Void (Void())
import qualified Data.Either.Unsafe as U
import qualified Data.Map as M
import qualified Data.Maybe.Unsafe as U

import Halogen.Component.ChildPath (ChildPath(), injState, injQuery, injSlot, prjState, prjQuery, prjSlot)
import Halogen.HTML.Core (HTML(..), fillSlot)
import Halogen.Query (HalogenF(), get)
import Halogen.Query.StateF (StateF(), mapState)
import Halogen.Query.SubscribeF (SubscribeF(), subscribeN, remapSubscribe, hoistSubscribe)

-- | Data type for Halogen components.
-- | - `s` - the type of the component state
-- | - `f` - the component's query algebra
-- | - `g` - the monad handling the component's non-state effects
-- | - `o` - the type of values observable via `peek`, used to allow parent
-- |         components to see queries their children have acted upon.
-- | - `p` - the type of slots within the component, used to specify locations
-- |         at which child components can be installed.
newtype ComponentP s f g o p = Component
  { render :: State s (HTML p (f Unit))
  , eval   :: Eval f s f g
  , peek   :: PeekP s f g o
  }

-- | A type alias for Halogen components where `peek` is not used.
type Component s f g = ComponentP s f g (Const Void)

instance functorComponent :: Functor (ComponentP s f g o) where
  map f (Component c) = Component { render: lmap f <$> c.render, eval: c.eval, peek: c.peek }

-- | A type alias for a component `render` function.
type Render s f p = s -> HTML p (f Unit)

-- | A type alias for a component `eval` function that takes a value from the
-- | component's query algebra and returns a `Free` monad of the Halogen
-- | component algebra.
type Eval i s f g = Natural i (Free (HalogenF s f g))

-- | A type alias for a component `peek` function that observes inputs to child
-- | components.
type Peek s s' f f' g p p' = PeekP s f (QueryF s s' f' g p p') (ChildF p f')

-- | A lower level form of the `Peek` type synonym, used internally.
type PeekP s f g o = forall a. o a -> Free (HalogenF s f g) Unit

-- | Runs a component's `render` function with the specified state, returning
-- | the generated `HTML` and new state.
renderComponent :: forall s f g o p. ComponentP s f g o p -> s -> Tuple (HTML p (f Unit)) s
renderComponent (Component c) = runState c.render

-- | Runs a compnent's `query` function with the specified query input and
-- | returns the pending computation as a `Free` monad.
queryComponent :: forall s f g o p. ComponentP s f g o p -> Eval f s f g
queryComponent (Component c) = c.eval

-- | Runs a parent component's `peek` function.
peekComponent :: forall s f g o p. ComponentP s f g o p -> PeekP s f g o
peekComponent (Component c) = c.peek

-- | Builds a new [`Component`](#component) from a [`Render`](#render) and
-- | [`Eval`](#eval) function.
component :: forall s f g p. Render s f p -> Eval f s f g -> Component s f g p
component r q = Component { render: CMS.gets r, eval: q, peek: const (pure unit) }

-- | Builds a new [`ComponentP`](#componentp) from a [`Render`](#render),
-- | [`Eval`](#eval), and [`Peek`](#peek) function. This is used in cases where
-- | defining a parent component that needs to observe inputs to its children.
component' :: forall s s' f f' g p p'. Render s f p -> Eval f s f (QueryF s s' f' g p p') -> Peek s s' f f' g p p' -> ParentComponentP s s' f f' g p p'
component' r q p = Component { render: CMS.gets r, eval: q, peek: p }

-- | A type synonym for a component combined with its state. This is used when
-- | installing components into slots.
type ChildState s f g p = Tuple (Component s f g p) s

-- | Creates a `ChildState` for a component.
createChild :: forall s f g p. Component s f g p -> s -> ChildState s f g p
createChild c s = Tuple c s

-- | Creates a `ChildState` for a component that is being installed into a
-- | parent with multiple different types of child component.
createChild' :: forall s s' f f' g p p' q. (Functor g) => ChildPath s s' f f' p p' -> Component s f g q -> s -> ChildState s' f' g q
createChild' i c s = Tuple (transform i c) (injState i s)

-- | A type alias used to simplify the type signature for a `Component s f g p`
-- | that is intended to have components of type `Component s' f' g p'`
-- | installed into it.
type ParentComponent s s' f f' g p p' = Component s f (QueryF s s' f' g p p') p

-- | A type alias similar to `ParentComponent`, but for components that `peek`
-- | on their children.
type ParentComponentP s s' f f' g p p' = ComponentP s f (QueryF s s' f' g p p') (ChildF p f') p

-- | A type alias use to simplify the type signature for a `Component s f g p`
-- | that has had components of type `Component s' f' g p'` installed into it.
type InstalledComponent s s' f f' g p p' = Component (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g p'

-- | The type used by component containers for their state where `s` is the
-- | state local to the container, `p` is the type of slot used by the
-- | container, and the remaining parameters are the type variables for the
-- | child components.
type InstalledState s s' f' g p p' =
  { parent   :: s
  , children :: M.Map p (ChildState s' f' g p')
  }

-- | Creates an initial `InstalledState` value for a component container based
-- | on a state value for the container.
installedState :: forall s s' f' g p p'. (Ord p) => s -> InstalledState s s' f' g p p'
installedState = { parent: _, children: M.empty }

-- | An intermediate algebra that parent components "produce" from their `eval`
-- | and `peek` functions. This takes the place of `g` when compared to a leaf
-- | (non-parent) component.
type QueryF s s' f' g p p' = Free (HalogenF (InstalledState s s' f' g p p') (ChildF p f') g)

-- | An intermediate algebra used to associate values from a child component's
-- | algebra with the slot the component was installed into.
data ChildF p f i = ChildF p (f i)

instance functorChildF :: (Functor f) => Functor (ChildF p f) where
  map f (ChildF p fi) = ChildF p (f <$> fi)

-- | Queries a child component, for use within a parent component's `eval` or
-- | `peek` function.
query :: forall s s' f f' g p p' i. (Functor g, Ord p)
      => p
      -> f' i
      -> Free (HalogenF s f (QueryF s s' f' g p p')) (Maybe i)
query p q = liftQuery (mkQuery p q)

-- | A version of [`query`](#query) for use when a parent component has multiple
-- | types of child component.
query' :: forall s s' s'' f f' f'' g p p' p'' i. (Functor g, Ord p)
      => ChildPath s'' s' f'' f' p'' p
      -> p''
      -> f'' i
      -> Free (HalogenF s f (QueryF s s' f' g p p')) (Maybe i)
query' i p q = liftQuery (mkQuery' i p q)

-- | Creates a query for a child component where `p` is the slot the component
-- | was installed into and `f' i` in the input query.
-- |
-- | If a component is not found for the slot the result of the query
-- | will be `Nothing`.
mkQuery :: forall s s' f' p p' g i. (Functor g, Ord p)
      => p
      -> f' i
      -> QueryF s s' f' g p p' (Maybe i)
mkQuery p q = do
  st <- get
  case M.lookup p st.children of
    Nothing -> pure Nothing
    Just (Tuple c _) -> Just <$> mapF (coproduct (left <<< mapStateFChild p) (right <<< coproduct (left <<< remapSubscribe (ChildF p)) right)) (queryComponent c q)

-- | A version of [`mkQuery`](#mkQuery) for use when a parent component has
-- | multiple types of child component.
mkQuery' :: forall s s' s'' f f' g p p' p'' i. (Functor g, Ord p')
         => ChildPath s'' s' f f' p p'
         -> p
         -> f i
         -> QueryF s s' f' g p' p'' (Maybe i)
mkQuery' i p q = mkQuery (injSlot i p) (injQuery i q)

-- | Lifts a value in the `QueryF` algebra into the monad used by a component's
-- | `eval` function.
liftQuery :: forall s s' f f' g p p'. (Functor g)
          => Eval (QueryF s s' f' g p p') s f (QueryF s s' f' g p p')
liftQuery qf = liftF (right (right qf))

-- | Installs children into a parent component by using a function that produces
-- | `ChildState` values for a given slot.
install :: forall s s' f f' g p p'. (Plus g, Ord p)
        => ParentComponent s s' f f' g p p'
        -> (p -> ChildState s' f' g p')
        -> InstalledComponent s s' f f' g p p'
install c f = Component { render: render c f, eval: eval, peek: const (pure unit) }
  where
  eval :: Eval (Coproduct f (ChildF p f')) (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g
  eval = coproduct (queryParent c) queryChild

-- | A version of [`install`](#install) for use with parent components that
-- | `peek` on their children.
install' :: forall s s' f f' g p p'. (Plus g, Ord p)
        => ParentComponentP s s' f f' g p p'
        -> (p -> ChildState s' f' g p')
        -> InstalledComponent s s' f f' g p p'
install' c f = Component { render: render c f, eval: eval, peek: const (pure unit) }
  where
  eval :: Eval (Coproduct f (ChildF p f')) (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g
  eval = coproduct (queryParent c) (\q -> queryChild q <* peek q)

  peek :: PeekP (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g (ChildF p f')
  peek q =
    let runSubscribeF' = runSubscribeF (queryParent c)
    in foldFree (coproduct mergeParentStateF (coproduct runSubscribeF' liftChildF)) (peekComponent c q)

mapStateFParent :: forall s s' f' g p p'. Natural (StateF s) (StateF (InstalledState s s' f' g p p'))
mapStateFParent = mapState (_.parent) (\f st -> { parent: f st.parent, children: st.children })

mapStateFChild :: forall s s' f' g p p'. (Ord p) => p -> Natural (StateF s') (StateF (InstalledState s s' f' g p p'))
mapStateFChild p = mapState (\st -> U.fromJust $ snd <$> M.lookup p st.children)
                            (\f st -> { parent: st.parent, children: M.update (Just <<< rmap f) p st.children })

render :: forall s s' f f' g o p p'. (Ord p)
       => ComponentP s f (QueryF s s' f' g p p') o p
       -> (p -> ChildState s' f' g p')
       -> State (InstalledState s s' f' g p p') (HTML p' ((Coproduct f (ChildF p f')) Unit))
render c f = do
    st <- CMS.get
    case renderComponent c st.parent of
      Tuple html s -> do
        -- Empty the state so that we don't keep children that are no longer
        -- being rendered...
        CMS.put { parent: s, children: M.empty :: M.Map p (ChildState s' f' g p') }
        -- ...but then pass through the old state so we can lookup child
        -- components that are being re-rendered
        fillSlot (renderChild st) left html

  where

  renderChild :: InstalledState s s' f' g p p'
              -> p
              -> State (InstalledState s s' f' g p p') (HTML p' ((Coproduct f (ChildF p f')) Unit))
  renderChild st p = renderChild' st p $ fromMaybe' (\_ -> f p) (M.lookup p st.children)

  renderChild' :: InstalledState s s' f' g p p'
               -> p
               -> ChildState s' f' g p'
               -> State (InstalledState s s' f' g p p') (HTML p' ((Coproduct f (ChildF p f')) Unit))
  renderChild' st p (Tuple c s) = case renderComponent c s of
    Tuple html s' -> do
      CMS.modify (\st -> st { children = M.insert p (Tuple c s') st.children })
      pure $ right <<< ChildF p <$> html

queryParent :: forall s s' f f' g o p p' q. (Functor g)
            => ComponentP s f (QueryF s s' f' g p p') o q
            -> Eval f (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g
queryParent c q = foldFree (coproduct mergeParentStateF (coproduct (runSubscribeF (queryParent c)) liftChildF)) (queryComponent c q)

mergeParentStateF :: forall s s' f f' g p p'. Eval (StateF s) (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g
mergeParentStateF = liftF <<< left <<< mapStateFParent

runSubscribeF :: forall s s' f f' g p p'. (Functor g)
              => Eval f (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g
              -> Eval (SubscribeF f (Free (HalogenF (InstalledState s s' f' g p p') (ChildF p f') g))) (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g
runSubscribeF queryParent' = subscribeN (forever $ lift <<< queryParent' =<< await) <<< hoistSubscribe liftChildF

liftChildF :: forall s s' f f' g p p'. (Functor g)
           => Eval (Free (HalogenF (InstalledState s s' f' g p p') (ChildF p f') g)) (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g
liftChildF = mapF (coproduct left (right <<< coproduct (left <<< remapSubscribe right) right))

queryChild :: forall s s' f f' g p p'. (Plus g, Ord p)
           => Eval (ChildF p f') (InstalledState s s' f' g p p') (Coproduct f (ChildF p f')) g
queryChild (ChildF p q) = mapF (coproduct left (right <<< coproduct (left <<< remapSubscribe right) right)) (mkQuery p q) >>= maybe empty' pure
  where
  empty' :: forall s f g a. (Plus g) => Free (HalogenF s f g) a
  empty' = liftF (right (right empty))

adaptState :: forall s t m a. (Monad m) => (s -> t) -> (t -> s) -> CMS.StateT s m a -> CMS.StateT t m a
adaptState st ts (CMS.StateT f) = CMS.StateT \state -> f (ts state) >>= \(Tuple a s) -> pure $ Tuple a (st s)

transform' :: forall s s' f f' g o o' p p'. (Functor g)
           => (s -> s')
           -> (s' -> s)
           -> Natural f f'
           -> Natural f' f
           -> Natural o' o
           -> (p -> p')
           -> ComponentP s f g o p
           -> ComponentP s' f' g o' p'
transform' sTo sFrom fTo fFrom oFrom tp (Component c) =
  Component { render: bimap tp fTo <$> adaptState sTo sFrom c.render
            , eval: mapF natHF <<< c.eval <<< fFrom
            , peek: mapF natHF <<< c.peek <<< oFrom
            }
  where
  natHF :: Natural (HalogenF s f g) (HalogenF s' f' g)
  natHF = coproduct (left <<< mapState sFrom (\f s -> sTo (f (sFrom s))))
                    (right <<< coproduct (left <<< remapSubscribe fTo) right)

transform :: forall s s' f f' g p p' q. (Functor g)
          => ChildPath s s' f f' p p'
          -> Component s f g q
          -> Component s' f' g q
transform i = transform' (injState i) (U.fromJust <<< prjState i) (injQuery i) (U.fromJust <<< prjQuery i) id id


add an Eq instance for the InputType

add an Eq instance for the InputType

module Models.Input where

data InputType
	= TextInput
	| CodeInput
	| FormulaInput
	| FileInput

instance eqInputType :: Eq InputType where
	(==) TextInput TextInput = true
	(==) CodeInput CodeInput = true
	(==) FormulaInput FormulaInput = true
	(==) FileInput FileInput = true
	(==) _ _ = false
	(/=) a b = not $ a == b


Clear Markdown state for each run

Clear Markdown state for each run

module Input.Notebook
  ( CellResultContent(..)
  , Input(..)
  , updateState
  , cellContent
  ) where

import Data.Array (filter, modifyAt, (!!))
import Data.Date (Date(), toEpochMilliseconds)
import Data.Either (Either(..), either)
import Data.Foldable (intercalate)
import Data.Function (on)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple (fst)
import Model.Notebook
import Model.Notebook.Cell
import Model.Notebook.Cell.FileInput (_showFiles)
import Model.Notebook.Domain (_cells, addCell, insertCell)
import Model.Notebook.Port (Port(..), VarMapValue())
import Optic.Core (LensP(), (..), (<>~), (%~), (+~), (.~), (^.), (?~), lens)
import Optic.Fold ((^?))
import Optic.Setter (mapped)
import Text.Markdown.SlamDown.Html (FormFieldValue(..), SlamDownEvent(..), SlamDownState(..), applySlamDownEvent, emptySlamDownState)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.StrMap as SM
import qualified ECharts.Options as EC
import qualified Model.Notebook.Cell.JTableContent as JTC
import qualified Model.Notebook.Cell.Markdown as Ma

data CellResultContent
  = AceContent String
  | JTableContent JTC.JTableContent
  | MarkdownContent

data Input
  = WithState (State -> State)
  | Dropdown Number
  | CloseDropdowns
  | AddCell CellContent
  | TrashCell CellId

  | RequestCellContent Cell
  | ReceiveCellContent Cell

  | StartRunCell CellId Date
  | StopCell CellId
  | CellResult CellId Date (Either (NEL.NonEmpty FailureMessage) CellResultContent)

  | UpdateCell CellId (Cell -> Cell)
  | CellSlamDownEvent CellId SlamDownEvent
  | InsertCell Cell CellContent
  | SetEChartsOption String EC.Option

updateState :: State -> Input -> State

updateState state (WithState f) =
  f state

updateState state (UpdateCell cellId fn) =
  state # _notebook.._cells..mapped %~ onCell cellId fn

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # _dropdowns %~
  (modifyAt i _{visible = visSet}) <<< (_{visible = false} <$>)

updateState state CloseDropdowns =
  state # (_dropdowns %~ (_{visible = false} <$>))
       .. (_notebook .. _cells .. mapped %~ _content .. _FileInput .. _showFiles .~ false)

updateState state (AddCell content) =
  state # _notebook %~ (fst <<< addCell content)

updateState state (InsertCell parent content) =
  state # _notebook %~ (fst <<< insertCell parent content)

updateState state (TrashCell cellId) =
  state # _notebook.._cells %~ filter (not <<< isCell cellId)

updateState state (CellResult cellId date content) =
  let finished d = RunFinished $ on (-) toEpochMilliseconds date d

      fromState (RunningSince d) = cellContent content <<< setRunState (finished d)
      fromState a = setRunState a -- In bad state or cancelled. Leave content.

      f cell = fromState (cell ^. _runState) cell # (_hasRun .~ true)

  in state # _notebook.._cells..mapped %~ onCell cellId f

updateState state (ReceiveCellContent cell) =
  state # _notebook.._cells..mapped %~ onCell (cell ^. _cellId) (const cell)

updateState state (StartRunCell cellId date) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState (RunningSince date) <<< (_expandedStatus .~ false))

updateState state (StopCell cellId) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState RunInitial)

updateState state (CellSlamDownEvent cellId event) =
  state # _notebook.._cells..mapped %~ onCell cellId (slamDownOutput <<< runSlamDownEvent event)

updateState state i = state

toStrMap :: forall a. M.Map String a -> SM.StrMap a
toStrMap = SM.fromList <<< M.toList

slamDownStateMap :: LensP SlamDownState (M.Map String FormFieldValue)
slamDownStateMap = lens (\(SlamDownState m) -> m) (const SlamDownState)

slamDownOutput :: Cell -> Cell
slamDownOutput cell =
  cell # _output .~ VarMap m
  where
    m = maybe SM.empty ((fromFormValue <$>) <<< toStrMap) state
    fromFormValue (SingleValue s) = s
    fromFormValue (MultipleValues s) = "[" <> intercalate ", " (S.toList s) <> "]" -- TODO: is this anything like we want for multi-values?
    state = cell ^? _content.._Markdown..Ma._state..slamDownStateMap

runSlamDownEvent :: SlamDownEvent -> Cell -> Cell
runSlamDownEvent event cell =
  cell # _content.._Markdown..Ma._state %~ flip applySlamDownEvent event

cellContent :: Either (NEL.NonEmpty FailureMessage) CellResultContent -> Cell -> Cell
cellContent = either (setFailures <<< NEL.toArray) success
  where
  success :: CellResultContent -> Cell -> Cell
  success (AceContent content) =
    setFailures [ ]
    <<< (_content.._AceContent .~ content)
    <<< (_content.._Markdown..Ma._state .~ emptySlamDownState)
  success (JTableContent content) =
    setFailures [ ]
    <<< (_content.._JTableContent .~ content)
  success MarkdownContent = setFailures [ ]

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

setFailures :: [FailureMessage] -> Cell -> Cell
setFailures fs (Cell o) = Cell $ o { failures = fs }

setRunState :: RunState -> Cell -> Cell
setRunState = modifyRunState <<< const

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'

module Input.Notebook
  ( CellResultContent(..)
  , Input(..)
  , updateState
  , cellContent
  ) where

import Data.Array (filter, modifyAt, (!!))
import Data.Date (Date(), toEpochMilliseconds)
import Data.Either (Either(..), either)
import Data.Foldable (intercalate)
import Data.Function (on)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple (fst)
import Model.Notebook
import Model.Notebook.Cell
import Model.Notebook.Cell.FileInput (_showFiles)
import Model.Notebook.Domain (_cells, addCell, insertCell)
import Model.Notebook.Port (Port(..), VarMapValue())
import Optic.Core (LensP(), (..), (<>~), (%~), (+~), (.~), (^.), (?~), lens)
import Optic.Fold ((^?))
import Optic.Setter (mapped)
import Text.Markdown.SlamDown.Html (FormFieldValue(..), SlamDownEvent(..), SlamDownState(..), applySlamDownEvent)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.StrMap as SM
import qualified ECharts.Options as EC
import qualified Model.Notebook.Cell.JTableContent as JTC
import qualified Model.Notebook.Cell.Markdown as Ma

data CellResultContent
  = AceContent String
  | JTableContent JTC.JTableContent
  | MarkdownContent

data Input
  = WithState (State -> State)
  | Dropdown Number
  | CloseDropdowns
  | AddCell CellContent
  | TrashCell CellId

  | RequestCellContent Cell
  | ReceiveCellContent Cell

  | StartRunCell CellId Date
  | StopCell CellId
  | CellResult CellId Date (Either (NEL.NonEmpty FailureMessage) CellResultContent)

  | UpdateCell CellId (Cell -> Cell)
  | CellSlamDownEvent CellId SlamDownEvent
  | InsertCell Cell CellContent
  | SetEChartsOption String EC.Option

updateState :: State -> Input -> State

updateState state (WithState f) =
  f state

updateState state (UpdateCell cellId fn) =
  state # _notebook.._cells..mapped %~ onCell cellId fn

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # _dropdowns %~
  (modifyAt i _{visible = visSet}) <<< (_{visible = false} <$>)

updateState state CloseDropdowns =
  state # (_dropdowns %~ (_{visible = false} <$>))
       .. (_notebook .. _cells .. mapped %~ _content .. _FileInput .. _showFiles .~ false)

updateState state (AddCell content) =
  state # _notebook %~ (fst <<< addCell content)

updateState state (InsertCell parent content) =
  state # _notebook %~ (fst <<< insertCell parent content)

updateState state (TrashCell cellId) =
  state # _notebook.._cells %~ filter (not <<< isCell cellId)

updateState state (CellResult cellId date content) =
  let finished d = RunFinished $ on (-) toEpochMilliseconds date d

      fromState (RunningSince d) = cellContent content <<< setRunState (finished d)
      fromState a = setRunState a -- In bad state or cancelled. Leave content.

      f cell = fromState (cell ^. _runState) cell # (_hasRun .~ true)

  in state # _notebook.._cells..mapped %~ onCell cellId f

updateState state (ReceiveCellContent cell) =
  state # _notebook.._cells..mapped %~ onCell (cell ^. _cellId) (const cell)

updateState state (StartRunCell cellId date) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState (RunningSince date) <<< (_expandedStatus .~ false))

updateState state (StopCell cellId) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState RunInitial)

updateState state (CellSlamDownEvent cellId event) =
  state # _notebook.._cells..mapped %~ onCell cellId (slamDownOutput <<< runSlamDownEvent event)

updateState state i = state

toStrMap :: forall a. M.Map String a -> SM.StrMap a
toStrMap = SM.fromList <<< M.toList

slamDownStateMap :: LensP SlamDownState (M.Map String FormFieldValue)
slamDownStateMap = lens (\(SlamDownState m) -> m) (const SlamDownState)

slamDownOutput :: Cell -> Cell
slamDownOutput cell =
  cell # _output .~ VarMap m
  where
    m = maybe SM.empty ((fromFormValue <$>) <<< toStrMap) state
    fromFormValue (SingleValue s) = s
    fromFormValue (MultipleValues s) = "[" <> intercalate ", " (S.toList s) <> "]" -- TODO: is this anything like we want for multi-values?
    state = cell ^? _content.._Markdown..Ma._state..slamDownStateMap

runSlamDownEvent :: SlamDownEvent -> Cell -> Cell
runSlamDownEvent event cell =
  cell # _content.._Markdown..Ma._state %~ flip applySlamDownEvent event

cellContent :: Either (NEL.NonEmpty FailureMessage) CellResultContent -> Cell -> Cell
cellContent = either (setFailures <<< NEL.toArray) success
  where
  success :: CellResultContent -> Cell -> Cell
  success (AceContent content) = setFailures [ ] <<< (_content .. _AceContent .~ content)
  success (JTableContent content) = setFailures [ ] <<< (_content .. _JTableContent .~ content)
  success MarkdownContent = setFailures [ ]

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

setFailures :: [FailureMessage] -> Cell -> Cell
setFailures fs (Cell o) = Cell $ o { failures = fs }

setRunState :: RunState -> Cell -> Cell
setRunState = modifyRunState <<< const

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'