JS AST equality

JS AST equality

module Language.PureScript.CodeGen.JS.AST where

import Data.Array (map)
import Data.Either
import Data.Foldable (foldl)
import Data.Maybe
import Data.Tuple

-- |
-- Built-in unary operators
--
data UnaryOperator
  -- |
  -- Numeric negation
  --
  = Negate
  -- |
  -- Boolean negation
  --
  | Not
  -- |
  -- Bitwise negation
  --
  | BitwiseNot
  -- |
  -- Numeric unary \'plus\'
  --
  | Positive

instance showUnaryOperator :: Show UnaryOperator where
  show Negate = "Negate"
  show Not = "Not"
  show BitwiseNot = "BitwiseNot"
  show Positive = "Positive"

instance eqUnaryOperator :: Eq UnaryOperator where
  (==) Negate     Negate     = true
  (==) Not        Not        = true
  (==) BitwiseNot BitwiseNot = true
  (==) Positive   Positive   = true
  (==) _          _          = false
  (/=) u1         u2         = not (u1 == u2)

-- |
-- Built-in binary operators
--
data BinaryOperator
  -- |
  -- Numeric addition
  --
  = Add
  -- |
  -- Numeric subtraction
  --
  | Subtract
  -- |
  -- Numeric multiplication
  --
  | Multiply
  -- |
  -- Numeric division
  --
  | Divide
  -- |
  -- Remainder
  --
  | Modulus
  -- |
  -- Generic equality test
  --
  | EqualTo
  -- |
  -- Generic inequality test
  --
  | NotEqualTo
  -- |
  -- Numeric less-than
  --
  | LessThan
  -- |
  -- Numeric less-than-or-equal
  --
  | LessThanOrEqualTo
  -- |
  -- Numeric greater-than
  --
  | GreaterThan
  -- |
  -- Numeric greater-than-or-equal
  --
  | GreaterThanOrEqualTo
  -- |
  -- Boolean and
  --
  | And
  -- |
  -- Boolean or
  --
  | Or
  -- |
  -- Bitwise and
  --
  | BitwiseAnd
  -- |
  -- Bitwise or
  --
  | BitwiseOr
  -- |
  -- Bitwise xor
  --
  | BitwiseXor
  -- |
  -- Bitwise left shift
  --
  | ShiftLeft
  -- |
  -- Bitwise right shift
  --
  | ShiftRight
  -- |
  -- Bitwise right shift with zero-fill
  --
  | ZeroFillShiftRight

instance showBinaryOperator :: Show BinaryOperator where
  show Add                   = "Add"
  show Subtract              = "Subtract"
  show Multiply              = "Multiply"
  show Divide                = "Divide"
  show Modulus               = "Modulus"
  show EqualTo               = "EqualTo"
  show NotEqualTo            = "NotEqualTo"
  show LessThan              = "LessThan"
  show LessThanOrEqualTo     = "LessThanOrEqualTo"
  show GreaterThan           = "GreaterThan"
  show GreaterThanOrEqualTo  = "GreaterThanOrEqualTo"
  show And                   = "And"
  show Or                    = "Or"
  show BitwiseAnd            = "BitwiseAnd"
  show BitwiseOr             = "BitwiseOr"
  show BitwiseXor            = "BitwiseXor"
  show ShiftLeft             = "ShiftLeft"
  show ShiftRight            = "ShiftRight"
  show ZeroFillShiftRight    = "ZeroFillShiftRight"

instance eqBinaryOperator :: Eq BinaryOperator where
  (==) Add                  Add                  = true
  (==) Subtract             Subtract             = true
  (==) Multiply             Multiply             = true
  (==) Divide               Divide               = true
  (==) Modulus              Modulus              = true
  (==) EqualTo              EqualTo              = true
  (==) NotEqualTo           NotEqualTo           = true
  (==) LessThan             LessThan             = true
  (==) LessThanOrEqualTo    LessThanOrEqualTo    = true
  (==) GreaterThan          GreaterThan          = true
  (==) GreaterThanOrEqualTo GreaterThanOrEqualTo = true
  (==) And                  And                  = true
  (==) Or                   Or                   = true
  (==) BitwiseAnd           BitwiseAnd           = true
  (==) BitwiseOr            BitwiseOr            = true
  (==) BitwiseXor           BitwiseXor           = true
  (==) ShiftLeft            ShiftLeft            = true
  (==) ShiftRight           ShiftRight           = true
  (==) ZeroFillShiftRight   ZeroFillShiftRight   = true
  (==) _                    _                    = false
  (/=) b1                   b2                   = not (b1 == b2)

-- |
-- Data type for simplified Javascript expressions
--
data JS
  -- |
  -- A numeric literal
  --
  = JSNumericLiteral Number
  -- |
  -- A string literal
  --
  | JSStringLiteral String
  -- |
  -- A boolean literal
  --
  | JSBooleanLiteral Boolean
  -- |
  -- A unary operator application
  --
  | JSUnary UnaryOperator JS
  -- |
  -- A binary operator application
  --
  | JSBinary BinaryOperator JS JS
  -- |
  -- An array literal
  --
  | JSArrayLiteral [JS]
  -- |
  -- An array indexer expression
  --
  | JSIndexer JS JS
  -- |
  -- An object literal
  --
  | JSObjectLiteral [Tuple String JS]
  -- |
  -- An object property accessor expression
  --
  | JSAccessor String JS
  -- |
  -- A function introduction (optional name, arguments, body)
  --
  | JSFunction (Maybe String) [String] JS
  -- |
  -- Function application
  --
  | JSApp JS [JS]
  -- |
  -- Variable
  --
  | JSVar String
  -- |
  -- Conditional expression
  --
  | JSConditional JS JS JS
  -- |
  -- A block of expressions in braces
  --
  | JSBlock [JS]
  -- |
  -- A variable introduction and optional initialization
  --
  | JSVariableIntroduction String (Maybe JS)
  -- |
  -- A variable assignment
  --
  | JSAssignment JS JS
  -- |
  -- While loop
  --
  | JSWhile JS JS
  -- |
  -- For loop
  --
  | JSFor String JS JS JS
  -- |
  -- ForIn loop
  --
  | JSForIn String JS JS
  -- |
  -- If-then-else statement
  --
  | JSIfElse JS JS (Maybe JS)
  -- |
  -- Return statement
  --
  | JSReturn JS
  -- |
  -- Throw statement
  --
  | JSThrow JS
  -- |
  -- Type-Of operator
  --
  | JSTypeOf JS
  -- |
  -- Labelled statement
  --
  | JSLabel String JS
  -- |
  -- Break statement
  --
  | JSBreak String
  -- |
  -- Continue statement
  --
  | JSContinue String
  -- |
  -- Raw Javascript (for an inline foreign import declarations)
  --
  | JSRaw String

instance showJS :: Show JS where
  show (JSNumericLiteral n) = "JSNumericLiteral (" ++ show n ++ ")"
  show (JSStringLiteral s) = "JSStringLiteral (" ++ show s ++ ")"
  show (JSBooleanLiteral b) = "JSBooleanLiteral (" ++ show b ++ ")"
  show (JSUnary op js) = "JSUnary (" ++ show op ++ ") (" ++ show js ++ ")"
  show (JSBinary op js1 js2) = "JSBinary (" ++ show op ++ ") (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSArrayLiteral js) = "JSArrayLiteral (" ++ show js ++ ")"
  show (JSIndexer js1 js2) = "JSIndexer (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSObjectLiteral ps) = "JSObjectLiteral (" ++ show ps ++ ")"
  show (JSAccessor prop js) = "JSAccessor (" ++ show prop ++ ") (" ++ show js ++ ")"
  show (JSFunction nm args js) = "JSFunction (" ++ show nm ++ ") (" ++ show args ++ ") (" ++ show js ++ ")"
  show (JSApp js args) = "JSApp (" ++ show js ++ ") (" ++ show args ++ ")"
  show (JSVar nm) = "JSVar (" ++ show nm ++ ")"
  show (JSConditional js1 js2 js3) = "JSConditional (" ++ show js1 ++ ") (" ++ show js2 ++ ") (" ++ show js3 ++ ")"
  show (JSBlock js) = "JSBlock (" ++ show js ++ ")"
  show (JSVariableIntroduction nm js) = "JSVariableIntroduction (" ++ show nm ++ ") (" ++ show js ++ ")"
  show (JSAssignment js1 js2) = "JSAssignment (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSWhile js1 js2) = "JSWhile (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSFor nm js1 js2 js3) = "JSFor (" ++ show nm ++ ") (" ++ show js1 ++ ") (" ++ show js2 ++ ") (" ++ show js3 ++ ")"
  show (JSForIn nm js1 js2) = "JSForIn String (" ++ show nm ++ ") (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSIfElse js1 js2 js3) = "JSIfElse (" ++ show js1 ++ ") (" ++ show js2 ++ ") (" ++ show js3 ++ ")"
  show (JSReturn js) = "JSReturn (" ++ show js ++ ")"
  show (JSThrow js) = "JSThrow (" ++ show js ++ ")"
  show (JSTypeOf js) = "JSTypeOf (" ++ show js ++ ")"
  show (JSLabel lbl js) = "JSLabel (" ++ show lbl ++ ") (" ++ show js ++ ")"
  show (JSBreak lbl) = "JSBreak (" ++ show lbl ++ ")"
  show (JSContinue lbl) = "JSContinue (" ++ show lbl ++ ")"
  show (JSRaw js) = "JSRaw (" ++ show js ++ ")"

instance eqJS :: Eq JS where
  (==) (JSNumericLiteral n1)            (JSNumericLiteral n2)            = n1 == n2
  (==) (JSStringLiteral s1)             (JSStringLiteral s2)             = s1 == s2
  (==) (JSBooleanLiteral b1)            (JSBooleanLiteral b2)            = b1 == b2
  (==) (JSUnary op1 js1)                (JSUnary op2 js2)                = op1 == op2 && js1 == js2
  (==) (JSBinary op1 js11 js21)         (JSBinary op2 js12 js22)         = op1 == op2 && js11 == js12 && js21 == js22
  (==) (JSArrayLiteral js1)             (JSArrayLiteral js2)             = js1 == js2
  (==) (JSIndexer js11 js21)            (JSIndexer js12 js22)            = js11 == js12 && js21 == js22
  (==) (JSObjectLiteral ps1)            (JSObjectLiteral ps2)            = ps1 == ps2
  (==) (JSAccessor prop1 js1)           (JSAccessor prop2 js2)           = prop1 == prop2 && js1 == js2
  (==) (JSFunction nm1 args1 js1)       (JSFunction nm2 args2 js2)       = nm1 == nm2 && args1 == args2 && js1 == js2
  (==) (JSApp js1 args1)                (JSApp js2 args2)                = js1 == js2 && args1 == args2
  (==) (JSVar nm1)                      (JSVar nm2)                      = nm1 == nm2
  (==) (JSConditional js11 js21 js31)   (JSConditional js12 js22 js32)   = js11 == js12 && js21 == js22 && js31 == js32
  (==) (JSBlock js1)                    (JSBlock js2)                    = js1 == js2
  (==) (JSVariableIntroduction nm1 js1) (JSVariableIntroduction nm2 js2) = nm1 == nm2 && js1 == js2
  (==) (JSAssignment js11 js21)         (JSAssignment js12 js22)         = js11 == js12 && js21 == js22
  (==) (JSWhile js11 js21)              (JSWhile js12 js22)              = js11 == js12 && js21 == js22
  (==) (JSFor nm1 js11 js21 js31)       (JSFor nm2 js12 js22 js32)       = nm1 == nm2 && js11 == js12 && js21 == js22 && js31 == js32
  (==) (JSForIn nm1 js11 js21)          (JSForIn nm2 js12 js22)          = nm1 == nm2 && js11 == js12 && js21 == js22
  (==) (JSIfElse js11 js21 js31)        (JSIfElse js12 js22 js32)        = js11 == js12 && js21 == js22 && js31 == js32
  (==) (JSReturn js1)                   (JSReturn js2)                   = js1 == js2
  (==) (JSThrow js1)                    (JSThrow js2)                    = js1 == js2
  (==) (JSTypeOf js1)                   (JSTypeOf js2)                   = js1 == js2
  (==) (JSLabel lbl1 js1)               (JSLabel lbl2 js2)               = lbl1 == lbl2 && js1 == js2
  (==) (JSBreak lbl1)                   (JSBreak lbl2)                   = lbl1 == lbl2
  (==) (JSContinue lbl1)                (JSContinue lbl2)                = lbl1 == lbl2
  (==) (JSRaw js1)                      (JSRaw js2)                      = js1 == js2
  (==) _ _ = false
  (/=) x y = not (x == y)

--
-- Traversals
--

everywhereOnJS :: (JS -> JS) -> JS -> JS
everywhereOnJS f = go
  where
  go :: JS -> JS
  go (JSUnary op j) = f (JSUnary op (go j))
  go (JSBinary op j1 j2) = f (JSBinary op (go j1) (go j2))
  go (JSArrayLiteral js) = f (JSArrayLiteral (map go js))
  go (JSIndexer j1 j2) = f (JSIndexer (go j1) (go j2))
  go (JSObjectLiteral js) = f (JSObjectLiteral (map ((<$>) go) js))
  go (JSAccessor prop j) = f (JSAccessor prop (go j))
  go (JSFunction name args j) = f (JSFunction name args (go j))
  go (JSApp j js) = f (JSApp (go j) (map go js))
  go (JSConditional j1 j2 j3) = f (JSConditional (go j1) (go j2) (go j3))
  go (JSBlock js) = f (JSBlock (map go js))
  go (JSVariableIntroduction name j) = f (JSVariableIntroduction name ((<$>) go j))
  go (JSAssignment j1 j2) = f (JSAssignment (go j1) (go j2))
  go (JSWhile j1 j2) = f (JSWhile (go j1) (go j2))
  go (JSFor name j1 j2 j3) = f (JSFor name (go j1) (go j2) (go j3))
  go (JSForIn name j1 j2) = f (JSForIn name (go j1) (go j2))
  go (JSIfElse j1 j2 j3) = f (JSIfElse (go j1) (go j2) ((<$>) go j3))
  go (JSReturn js) = f (JSReturn (go js))
  go (JSThrow js) = f (JSThrow (go js))
  go (JSTypeOf js) = f (JSTypeOf (go js))
  go (JSLabel name js) = f (JSLabel name (go js))
  go other = f other

everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
everywhereOnJSTopDown f = go <<< f
  where
  go :: JS -> JS
  go (JSUnary op j) = JSUnary op (go (f j))
  go (JSBinary op j1 j2) = JSBinary op (go (f j1)) (go (f j2))
  go (JSArrayLiteral js) = JSArrayLiteral (map (go <<< f) js)
  go (JSIndexer j1 j2) = JSIndexer (go (f j1)) (go (f j2))
  go (JSObjectLiteral js) = JSObjectLiteral (map ((<$>) (go <<< f)) js)
  go (JSAccessor prop j) = JSAccessor prop (go (f j))
  go (JSFunction name args j) = JSFunction name args (go (f j))
  go (JSApp j js) = JSApp (go (f j)) (map (go <<< f) js)
  go (JSConditional j1 j2 j3) = JSConditional (go (f j1)) (go (f j2)) (go (f j3))
  go (JSBlock js) = JSBlock (map (go <<< f) js)
  go (JSVariableIntroduction name j) = JSVariableIntroduction name ((go <<< f) <$> j)
  go (JSAssignment j1 j2) = JSAssignment (go (f j1)) (go (f j2))
  go (JSWhile j1 j2) = JSWhile (go (f j1)) (go (f j2))
  go (JSFor name j1 j2 j3) = JSFor name (go (f j1)) (go (f j2)) (go (f j3))
  go (JSForIn name j1 j2) = JSForIn name (go (f j1)) (go (f j2))
  go (JSIfElse j1 j2 j3) = JSIfElse (go (f j1)) (go (f j2)) ((go <<< f) <$> j3)
  go (JSReturn j) = JSReturn (go (f j))
  go (JSThrow j) = JSThrow (go (f j))
  go (JSTypeOf j) = JSTypeOf (go (f j))
  go (JSLabel name j) = JSLabel name (go (f j))
  go other = f other

everythingOnJS :: forall r. (r -> r -> r) -> (JS -> r) -> JS -> r
everythingOnJS (<>) f = go
  where
  go j@(JSUnary _ j1) = f j <> go j1
  go j@(JSBinary _ j1 j2) = f j <> go j1 <> go j2
  go j@(JSArrayLiteral js) = foldl (<>) (f j) (map go js)
  go j@(JSIndexer j1 j2) = f j <> go j1 <> go j2
  go j@(JSObjectLiteral js) = foldl (<>) (f j) (map (go <<< snd) js)
  go j@(JSAccessor _ j1) = f j <> go j1
  go j@(JSFunction _ _ j1) = f j <> go j1
  go j@(JSApp j1 js) = foldl (<>) (f j <> go j1) (map go js)
  go j@(JSConditional j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
  go j@(JSBlock js) = foldl (<>) (f j) (map go js)
  go j@(JSVariableIntroduction _ (Just j1)) = f j <> go j1
  go j@(JSAssignment j1 j2) = f j <> go j1 <> go j2
  go j@(JSWhile j1 j2) = f j <> go j1 <> go j2
  go j@(JSFor _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
  go j@(JSForIn _ j1 j2) = f j <> go j1 <> go j2
  go j@(JSIfElse j1 j2 Nothing) = f j <> go j1 <> go j2
  go j@(JSIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
  go j@(JSReturn j1) = f j <> go j1
  go j@(JSThrow j1) = f j <> go j1
  go j@(JSTypeOf j1) = f j <> go j1
  go j@(JSLabel _ j1) = f j <> go j1
  go other = f other

module Language.PureScript.CodeGen.JS.AST where

import Data.Array (map)
import Data.Either
import Data.Foldable (foldl)
import Data.Maybe
import Data.Tuple

-- |
-- Built-in unary operators
--
data UnaryOperator
  -- |
  -- Numeric negation
  --
  = Negate
  -- |
  -- Boolean negation
  --
  | Not
  -- |
  -- Bitwise negation
  --
  | BitwiseNot
  -- |
  -- Numeric unary \'plus\'
  --
  | Positive

instance showUnaryOperator :: Show UnaryOperator where
  show Negate = "Negate"
  show Not = "Not"
  show BitwiseNot = "BitwiseNot"
  show Positive = "Positive"

instance eqUnaryOperator :: Eq UnaryOperator where
  (==) Negate     Negate     = true
  (==) Not        Not        = true
  (==) BitwiseNot BitwiseNot = true
  (==) Positive   Positive   = true
  (==) _          _          = false
  (/=) u1         u2         = not (u1 == u2)

-- |
-- Built-in binary operators
--
data BinaryOperator
  -- |
  -- Numeric addition
  --
  = Add
  -- |
  -- Numeric subtraction
  --
  | Subtract
  -- |
  -- Numeric multiplication
  --
  | Multiply
  -- |
  -- Numeric division
  --
  | Divide
  -- |
  -- Remainder
  --
  | Modulus
  -- |
  -- Generic equality test
  --
  | EqualTo
  -- |
  -- Generic inequality test
  --
  | NotEqualTo
  -- |
  -- Numeric less-than
  --
  | LessThan
  -- |
  -- Numeric less-than-or-equal
  --
  | LessThanOrEqualTo
  -- |
  -- Numeric greater-than
  --
  | GreaterThan
  -- |
  -- Numeric greater-than-or-equal
  --
  | GreaterThanOrEqualTo
  -- |
  -- Boolean and
  --
  | And
  -- |
  -- Boolean or
  --
  | Or
  -- |
  -- Bitwise and
  --
  | BitwiseAnd
  -- |
  -- Bitwise or
  --
  | BitwiseOr
  -- |
  -- Bitwise xor
  --
  | BitwiseXor
  -- |
  -- Bitwise left shift
  --
  | ShiftLeft
  -- |
  -- Bitwise right shift
  --
  | ShiftRight
  -- |
  -- Bitwise right shift with zero-fill
  --
  | ZeroFillShiftRight

instance showBinaryOperator :: Show BinaryOperator where
  show Add                   = "Add"
  show Subtract              = "Subtract"
  show Multiply              = "Multiply"
  show Divide                = "Divide"
  show Modulus               = "Modulus"
  show EqualTo               = "EqualTo"
  show NotEqualTo            = "NotEqualTo"
  show LessThan              = "LessThan"
  show LessThanOrEqualTo     = "LessThanOrEqualTo"
  show GreaterThan           = "GreaterThan"
  show GreaterThanOrEqualTo  = "GreaterThanOrEqualTo"
  show And                   = "And"
  show Or                    = "Or"
  show BitwiseAnd            = "BitwiseAnd"
  show BitwiseOr             = "BitwiseOr"
  show BitwiseXor            = "BitwiseXor"
  show ShiftLeft             = "ShiftLeft"
  show ShiftRight            = "ShiftRight"
  show ZeroFillShiftRight    = "ZeroFillShiftRight"

instance eqBinaryOperator :: Eq BinaryOperator where
  (==) Add                  Add                  = true
  (==) Subtract             Subtract             = true
  (==) Multiply             Multiply             = true
  (==) Divide               Divide               = true
  (==) Modulus              Modulus              = true
  (==) EqualTo              EqualTo              = true
  (==) NotEqualTo           NotEqualTo           = true
  (==) LessThan             LessThan             = true
  (==) LessThanOrEqualTo    LessThanOrEqualTo    = true
  (==) GreaterThan          GreaterThan          = true
  (==) GreaterThanOrEqualTo GreaterThanOrEqualTo = true
  (==) And                  And                  = true
  (==) Or                   Or                   = true
  (==) BitwiseAnd           BitwiseAnd           = true
  (==) BitwiseOr            BitwiseOr            = true
  (==) BitwiseXor           BitwiseXor           = true
  (==) ShiftLeft            ShiftLeft            = true
  (==) ShiftRight           ShiftRight           = true
  (==) ZeroFillShiftRight   ZeroFillShiftRight   = true
  (==) _                    _                    = false
  (/=) b1                   b2                   = not (b1 == b2)

-- |
-- Data type for simplified Javascript expressions
--
data JS
  -- |
  -- A numeric literal
  --
  = JSNumericLiteral Number
  -- |
  -- A string literal
  --
  | JSStringLiteral String
  -- |
  -- A boolean literal
  --
  | JSBooleanLiteral Boolean
  -- |
  -- A unary operator application
  --
  | JSUnary UnaryOperator JS
  -- |
  -- A binary operator application
  --
  | JSBinary BinaryOperator JS JS
  -- |
  -- An array literal
  --
  | JSArrayLiteral [JS]
  -- |
  -- An array indexer expression
  --
  | JSIndexer JS JS
  -- |
  -- An object literal
  --
  | JSObjectLiteral [Tuple String JS]
  -- |
  -- An object property accessor expression
  --
  | JSAccessor String JS
  -- |
  -- A function introduction (optional name, arguments, body)
  --
  | JSFunction (Maybe String) [String] JS
  -- |
  -- Function application
  --
  | JSApp JS [JS]
  -- |
  -- Variable
  --
  | JSVar String
  -- |
  -- Conditional expression
  --
  | JSConditional JS JS JS
  -- |
  -- A block of expressions in braces
  --
  | JSBlock [JS]
  -- |
  -- A variable introduction and optional initialization
  --
  | JSVariableIntroduction String (Maybe JS)
  -- |
  -- A variable assignment
  --
  | JSAssignment JS JS
  -- |
  -- While loop
  --
  | JSWhile JS JS
  -- |
  -- For loop
  --
  | JSFor String JS JS JS
  -- |
  -- ForIn loop
  --
  | JSForIn String JS JS
  -- |
  -- If-then-else statement
  --
  | JSIfElse JS JS (Maybe JS)
  -- |
  -- Return statement
  --
  | JSReturn JS
  -- |
  -- Throw statement
  --
  | JSThrow JS
  -- |
  -- Type-Of operator
  --
  | JSTypeOf JS
  -- |
  -- Labelled statement
  --
  | JSLabel String JS
  -- |
  -- Break statement
  --
  | JSBreak String
  -- |
  -- Continue statement
  --
  | JSContinue String
  -- |
  -- Raw Javascript (for an inline foreign import declarations)
  --
  | JSRaw String

instance showJS :: Show JS where
  show (JSNumericLiteral n) = "JSNumericLiteral (" ++ show n ++ ")"
  show (JSStringLiteral s) = "JSStringLiteral (" ++ show s ++ ")"
  show (JSBooleanLiteral b) = "JSBooleanLiteral (" ++ show b ++ ")"
  show (JSUnary op js) = "JSUnary (" ++ show op ++ ") (" ++ show js ++ ")"
  show (JSBinary op js1 js2) = "JSBinary (" ++ show op ++ ") (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSArrayLiteral js) = "JSArrayLiteral (" ++ show js ++ ")"
  show (JSIndexer js1 js2) = "JSIndexer (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSObjectLiteral ps) = "JSObjectLiteral (" ++ show ps ++ ")"
  show (JSAccessor prop js) = "JSAccessor (" ++ show prop ++ ") (" ++ show js ++ ")"
  show (JSFunction nm args js) = "JSFunction (" ++ show nm ++ ") (" ++ show args ++ ") (" ++ show js ++ ")"
  show (JSApp js args) = "JSApp (" ++ show js ++ ") (" ++ show args ++ ")"
  show (JSVar nm) = "JSVar (" ++ show nm ++ ")"
  show (JSConditional js1 js2 js3) = "JSConditional (" ++ show js1 ++ ") (" ++ show js2 ++ ") (" ++ show js3 ++ ")"
  show (JSBlock js) = "JSBlock (" ++ show js ++ ")"
  show (JSVariableIntroduction nm js) = "JSVariableIntroduction (" ++ show nm ++ ") (" ++ show js ++ ")"
  show (JSAssignment js1 js2) = "JSAssignment (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSWhile js1 js2) = "JSWhile (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSFor nm js1 js2 js3) = "JSFor (" ++ show nm ++ ") (" ++ show js1 ++ ") (" ++ show js2 ++ ") (" ++ show js3 ++ ")"
  show (JSForIn nm js1 js2) = "JSForIn String (" ++ show nm ++ ") (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSIfElse js1 js2 js3) = "JSIfElse (" ++ show js1 ++ ") (" ++ show js2 ++ ") (" ++ show js3 ++ ")"
  show (JSReturn js) = "JSReturn (" ++ show js ++ ")"
  show (JSThrow js) = "JSThrow (" ++ show js ++ ")"
  show (JSTypeOf js) = "JSTypeOf (" ++ show js ++ ")"
  show (JSLabel lbl js) = "JSLabel (" ++ show lbl ++ ") (" ++ show js ++ ")"
  show (JSBreak lbl) = "JSBreak (" ++ show lbl ++ ")"
  show (JSContinue lbl) = "JSContinue (" ++ show lbl ++ ")"
  show (JSRaw js) = "JSRaw (" ++ show js ++ ")"

--
-- Traversals
--

everywhereOnJS :: (JS -> JS) -> JS -> JS
everywhereOnJS f = go
  where
  go :: JS -> JS
  go (JSUnary op j) = f (JSUnary op (go j))
  go (JSBinary op j1 j2) = f (JSBinary op (go j1) (go j2))
  go (JSArrayLiteral js) = f (JSArrayLiteral (map go js))
  go (JSIndexer j1 j2) = f (JSIndexer (go j1) (go j2))
  go (JSObjectLiteral js) = f (JSObjectLiteral (map ((<$>) go) js))
  go (JSAccessor prop j) = f (JSAccessor prop (go j))
  go (JSFunction name args j) = f (JSFunction name args (go j))
  go (JSApp j js) = f (JSApp (go j) (map go js))
  go (JSConditional j1 j2 j3) = f (JSConditional (go j1) (go j2) (go j3))
  go (JSBlock js) = f (JSBlock (map go js))
  go (JSVariableIntroduction name j) = f (JSVariableIntroduction name ((<$>) go j))
  go (JSAssignment j1 j2) = f (JSAssignment (go j1) (go j2))
  go (JSWhile j1 j2) = f (JSWhile (go j1) (go j2))
  go (JSFor name j1 j2 j3) = f (JSFor name (go j1) (go j2) (go j3))
  go (JSForIn name j1 j2) = f (JSForIn name (go j1) (go j2))
  go (JSIfElse j1 j2 j3) = f (JSIfElse (go j1) (go j2) ((<$>) go j3))
  go (JSReturn js) = f (JSReturn (go js))
  go (JSThrow js) = f (JSThrow (go js))
  go (JSTypeOf js) = f (JSTypeOf (go js))
  go (JSLabel name js) = f (JSLabel name (go js))
  go other = f other

everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
everywhereOnJSTopDown f = go <<< f
  where
  go :: JS -> JS
  go (JSUnary op j) = JSUnary op (go (f j))
  go (JSBinary op j1 j2) = JSBinary op (go (f j1)) (go (f j2))
  go (JSArrayLiteral js) = JSArrayLiteral (map (go <<< f) js)
  go (JSIndexer j1 j2) = JSIndexer (go (f j1)) (go (f j2))
  go (JSObjectLiteral js) = JSObjectLiteral (map ((<$>) (go <<< f)) js)
  go (JSAccessor prop j) = JSAccessor prop (go (f j))
  go (JSFunction name args j) = JSFunction name args (go (f j))
  go (JSApp j js) = JSApp (go (f j)) (map (go <<< f) js)
  go (JSConditional j1 j2 j3) = JSConditional (go (f j1)) (go (f j2)) (go (f j3))
  go (JSBlock js) = JSBlock (map (go <<< f) js)
  go (JSVariableIntroduction name j) = JSVariableIntroduction name ((go <<< f) <$> j)
  go (JSAssignment j1 j2) = JSAssignment (go (f j1)) (go (f j2))
  go (JSWhile j1 j2) = JSWhile (go (f j1)) (go (f j2))
  go (JSFor name j1 j2 j3) = JSFor name (go (f j1)) (go (f j2)) (go (f j3))
  go (JSForIn name j1 j2) = JSForIn name (go (f j1)) (go (f j2))
  go (JSIfElse j1 j2 j3) = JSIfElse (go (f j1)) (go (f j2)) ((go <<< f) <$> j3)
  go (JSReturn j) = JSReturn (go (f j))
  go (JSThrow j) = JSThrow (go (f j))
  go (JSTypeOf j) = JSTypeOf (go (f j))
  go (JSLabel name j) = JSLabel name (go (f j))
  go other = f other

everythingOnJS :: forall r. (r -> r -> r) -> (JS -> r) -> JS -> r
everythingOnJS (<>) f = go
  where
  go j@(JSUnary _ j1) = f j <> go j1
  go j@(JSBinary _ j1 j2) = f j <> go j1 <> go j2
  go j@(JSArrayLiteral js) = foldl (<>) (f j) (map go js)
  go j@(JSIndexer j1 j2) = f j <> go j1 <> go j2
  go j@(JSObjectLiteral js) = foldl (<>) (f j) (map (go <<< snd) js)
  go j@(JSAccessor _ j1) = f j <> go j1
  go j@(JSFunction _ _ j1) = f j <> go j1
  go j@(JSApp j1 js) = foldl (<>) (f j <> go j1) (map go js)
  go j@(JSConditional j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
  go j@(JSBlock js) = foldl (<>) (f j) (map go js)
  go j@(JSVariableIntroduction _ (Just j1)) = f j <> go j1
  go j@(JSAssignment j1 j2) = f j <> go j1 <> go j2
  go j@(JSWhile j1 j2) = f j <> go j1 <> go j2
  go j@(JSFor _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
  go j@(JSForIn _ j1 j2) = f j <> go j1 <> go j2
  go j@(JSIfElse j1 j2 Nothing) = f j <> go j1 <> go j2
  go j@(JSIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
  go j@(JSReturn j1) = f j <> go j1
  go j@(JSThrow j1) = f j <> go j1
  go j@(JSTypeOf j1) = f j <> go j1
  go j@(JSLabel _ j1) = f j <> go j1
  go other = f other


Support any row length in ToSQLRow

Support any row length in ToSQLRow


Formatting

Formatting

module Main where

import Debug.Trace
import Data.Array
import Control.Monad.Eff

-- Import the library's module(s)
import Data.Foreign.EasyFFI

-- Import Test.QuickCheck, which supports property-based testing
import Test.QuickCheck

ffi = unsafeForeignFunction

easyConst :: Number -> Number -> Number
easyConst = ffi ["n", ""] "n"

easyAdd :: Number -> Number -> Number
easyAdd = ffi ["x", "y"] "x + y"

easySort :: [Number] -> [Number]
easySort = ffi ["xs"] "xs.slice().sort()"

main = do
  trace "Constant"
  quickCheck $ \n m -> easyConst n m == const n m

  trace "Addition"
  quickCheck $ \n m -> easyAdd n m == n + m

  trace "Sorting"
  quickCheck $ \xs -> easySort xs == sort xs

module Main where

import Debug.Trace
import Data.Array
import Control.Monad.Eff

-- Import the library's module(s)
import Data.Foreign.EasyFFI

-- Import Test.QuickCheck, which supports property-based testing
import Test.QuickCheck

ffi = unsafeForeignFunction

easyAdd :: Number -> Number -> Number
easyAdd = ffi ["x", "y"] "x + y"

easySort :: [Number] -> [Number]
easySort = ffi ["xs"] "xs.slice().sort()"

easyConst :: Number -> Number -> Number
easyConst = ffi ["n", ""] "n"

main = do
  trace "Constant"
  quickCheck $ \n m -> easyConst n m == const n m
  trace "Addition"
  quickCheck $ \n m -> easyAdd n m == n + m
  trace "Sorting"
  quickCheck $ \xs -> easySort xs == sort xs


Fix unused import warnings

Fix unused import warnings

-- | This module contains various types and functions to allow you to spawn and
-- | interact with child processes.
-- |
-- | It is intended to be imported qualified, as follows:
-- |
-- | ```purescript
-- | import Node.ChildProcess (ChildProcess(), CHILD_PROCESS())
-- | import Node.ChildProcess as ChildProcess
-- | ```
-- |
-- | The [Node.js documentation](https://nodejs.org/api/child_process.html)
-- | will probably also be useful to read if you want to use this module.
module Node.ChildProcess
  ( Handle()
  , ChildProcess()
  , CHILD_PROCESS()
  , stderr
  , stdout
  , stdin
  , pid
  , connected
  , kill
  , send
  , disconnect
  , Error()
  , toStandardError
  , Exit(..)
  , onExit
  , onClose
  , onDisconnect
  , onMessage
  , onError
  , spawn
  , SpawnOptions()
  , defaultSpawnOptions
  , exec
  , ExecOptions()
  , ExecResult()
  , defaultExecOptions
  , fork
  , StdIOBehaviour(..)
  , pipe
  , inherit
  , ignore
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Bind ((>=>))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception as Exception
import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)

import Data.StrMap (StrMap())
import Data.Function (Fn2(), runFn2)
import Data.Nullable (Nullable(), toNullable, toMaybe)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Foreign (Foreign())
import Data.Posix (Pid(), Gid(), Uid())
import Data.Posix.Signal (Signal())
import Data.Posix.Signal as Signal
import Unsafe.Coerce (unsafeCoerce)

import Node.Buffer (Buffer())
import Node.FS as FS
import Node.Stream (Readable(), Writable(), Stream())

-- | A handle for inter-process communication (IPC).
foreign import data Handle :: *

-- | The effect for creating and interacting with child processes.
foreign import data CHILD_PROCESS :: !

newtype ChildProcess = ChildProcess ChildProcessRec

runChildProcess :: ChildProcess -> ChildProcessRec
runChildProcess (ChildProcess r) = r

-- | Note: some of these types are lies, and so it is unsafe to access some of
-- | these record fields directly.
type ChildProcessRec =
  { stdin      :: forall eff. Nullable (Writable () (cp :: CHILD_PROCESS | eff))
  , stdout     :: forall eff. Nullable (Readable () (cp :: CHILD_PROCESS | eff))
  , stderr     :: forall eff. Nullable (Readable () (cp :: CHILD_PROCESS | eff))
  , pid        :: Pid
  , connected  :: Boolean
  , kill       :: String -> Boolean
  , send       :: forall r. Fn2 { | r} Handle Boolean
  , disconnect :: forall eff. Eff eff Unit
  }

-- | The standard input stream of a child process. Note that this is only
-- | available if the process was spawned with the stdin option set to "pipe".
stdin :: forall eff. ChildProcess -> Writable () (cp :: CHILD_PROCESS | eff)
stdin = unsafeFromNullable (missingStream "stdin") <<< _.stdin <<< runChildProcess

-- | The standard output stream of a child process. Note that this is only
-- | available if the process was spawned with the stdout option set to "pipe".
stdout :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS | eff)
stdout = unsafeFromNullable (missingStream "stdout") <<< _.stdout <<< runChildProcess

-- | The standard error stream of a child process. Note that this is only
-- | available if the process was spawned with the stderr option set to "pipe".
stderr :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS| eff)
stderr = unsafeFromNullable (missingStream "stderr") <<< _.stderr <<< runChildProcess

missingStream :: String -> String
missingStream str =
  "Node.ChildProcess: stream not available: " <> str <> "\nThis is probably "
  <> "because you passed something other than Pipe to the stdio option when "
  <> "you spawned it."

foreign import unsafeFromNullable :: forall a. String -> Nullable a -> a

-- | The process ID of a child process. Note that if the process has already
-- | exited, another process may have taken the same ID, so be careful!
pid :: ChildProcess -> Pid
pid = _.pid <<< runChildProcess

connected :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
connected (ChildProcess cp) = mkEff \_ -> cp.connected

send :: forall eff props. { | props } -> Handle -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
send msg handle (ChildProcess cp) = mkEff \_ -> runFn2 cp.send msg handle

disconnect :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Unit
disconnect = _.disconnect <<< runChildProcess

-- | Send a signal to a child process. It's an unfortunate historical decision
-- | that this function is called "kill", as sending a signal to a child
-- | process won't necessarily kill it.
kill :: forall eff. Signal -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
kill sig (ChildProcess cp) = mkEff \_ -> cp.kill (Signal.toString sig)

mkEff :: forall eff a. (Unit -> a) -> Eff eff a
mkEff = unsafeCoerce

-- | Specifies how a child process exited; normally (with an exit code), or
-- | due to a signal.
data Exit
  = Normally Int
  | BySignal Signal

instance showExit :: Show Exit where
  show (Normally x) = "Normally " <> show x
  show (BySignal sig) = "BySignal " <> show sig

mkExit :: Nullable Int -> Nullable String -> Exit
mkExit code signal =
  case fromCode code <|> fromSignal signal of
    Just e -> e
    Nothing -> unsafeThrow "Node.ChildProcess.mkExit: Invalid arguments"
  where
  fromCode   = toMaybe >>> map Normally
  fromSignal = toMaybe >=> Signal.fromString >>> map BySignal

onExit :: forall eff. ChildProcess -> (Exit -> Eff eff Unit) -> Eff eff Unit
onExit = mkOnExit mkExit

foreign import mkOnExit :: forall eff.
          (Nullable Int -> Nullable String -> Exit)
          -> ChildProcess -> (Exit -> Eff eff Unit) -> Eff eff Unit

onClose :: forall eff. ChildProcess -> (Exit -> Eff eff Unit) -> Eff eff Unit
onClose = mkOnClose mkExit

foreign import mkOnClose :: forall eff.
          (Nullable Int -> Nullable String -> Exit)
          -> ChildProcess -> (Exit -> Eff eff Unit) -> Eff eff Unit

onMessage :: forall eff.  ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit
onMessage = mkOnMessage Nothing Just

foreign import mkOnMessage :: forall a eff.
          Maybe a -> (a -> Maybe a) ->
          ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit

foreign import onDisconnect :: forall eff. ChildProcess -> Eff eff Unit -> Eff eff Unit
foreign import onError :: forall eff. ChildProcess -> (Error -> Eff eff Unit) -> Eff eff Unit

-- | Spawn a child process. Note that, in the event that a child process could
-- | not be spawned (for example, if the executable was not found) this will
-- | not throw an error. Instead, the `ChildProcess` will be created anyway,
-- | but it will immediately emit an 'error' event.
spawn :: forall eff. String -> Array String -> SpawnOptions -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess
spawn cmd args opts = spawnImpl cmd args (convertOpts opts)
  where
  convertOpts opts =
    { cwd: fromMaybe undefined opts.cwd
    , stdio: toActualStdIOOptions opts.stdio
    , env: toNullable opts.env
    , detached: opts.detached
    , uid: fromMaybe undefined opts.uid
    , gid: fromMaybe undefined opts.gid
    }

foreign import spawnImpl :: forall opts eff. String -> Array String -> { | opts } -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

-- There's gotta be a better way.
foreign import undefined :: forall a. a

type SpawnOptions =
  { cwd       :: Maybe String
  , stdio     :: Array (Maybe StdIOBehaviour)
  , env       :: Maybe (StrMap String)
  , detached  :: Boolean
  , uid       :: Maybe Uid
  , gid       :: Maybe Gid
  }

defaultSpawnOptions :: SpawnOptions
defaultSpawnOptions =
  { cwd: Nothing
  , stdio: pipe
  , env: Nothing
  , detached: false
  , uid: Nothing
  , gid: Nothing
  }

-- | Similar to `spawn`, except that this variant will buffer output, and wait
-- | until the process has exited before calling the callback.
-- |
-- | Note that the child process will be killed if the amount of output exceeds
-- | a certain threshold (the default is defined by Node.js).
exec :: forall eff.
  String ->
  ExecOptions ->
  (ExecResult -> Eff (cp :: CHILD_PROCESS | eff) Unit) ->
  Eff (cp :: CHILD_PROCESS | eff) Unit
exec cmd opts callback =
  execImpl cmd (convert opts) \err stdout' stderr' ->
    callback { error: (toMaybe err)
             , stdout: stdout'
             , stderr: stderr'
             }
  where
  convert opts =
    { cwd: fromMaybe undefined opts.cwd
    , env: fromMaybe undefined opts.env
    , timeout: fromMaybe undefined opts.timeout
    , maxBuffer: fromMaybe undefined opts.maxBuffer
    , killSignal: fromMaybe undefined opts.killSignal
    , uid: fromMaybe undefined opts.uid
    , gid: fromMaybe undefined opts.gid
    }

foreign import execImpl :: forall eff opts.
  String ->
  { | opts } ->
  (Nullable Exception.Error -> Buffer -> Buffer -> Eff (cp :: CHILD_PROCESS | eff) Unit) ->
  Eff (cp :: CHILD_PROCESS | eff) Unit

type ExecOptions =
  { cwd        :: Maybe String
  , env        :: Maybe (StrMap String)
  , timeout    :: Maybe Number
  , maxBuffer  :: Maybe Int
  , killSignal :: Maybe Signal
  , uid        :: Maybe Uid
  , gid        :: Maybe Gid
  }

defaultExecOptions :: ExecOptions
defaultExecOptions =
  { cwd: Nothing
  , env: Nothing
  , timeout: Nothing
  , maxBuffer: Nothing
  , killSignal: Nothing
  , uid: Nothing
  , gid: Nothing
  }

type ExecResult =
  { stderr :: Buffer
  , stdout :: Buffer
  , error  :: Maybe Exception.Error
  }

-- | A special case of `spawn` for creating Node.js child processes. The first
-- | argument is the module to be run, and the second is the argv (command line
-- | arguments).
foreign import fork :: forall eff. String -> Array String -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

-- | An error which occurred inside a child process.
type Error =
  { code :: String
  , errno :: String
  , syscall :: String
  }

-- | Convert a ChildProcess.Error to a standard Error, which can then be thrown
-- | inside an Eff or Aff computation (for example).
toStandardError :: Error -> Exception.Error
toStandardError = unsafeCoerce

-- | Behaviour for standard IO streams (eg, standard input, standard output) of
-- | a child process.
-- |
-- | * `Pipe`: creates a pipe between the child and parent process, which can
-- |   then be accessed as a `Stream` via the `stdin`, `stdout`, or `stderr`
-- |   functions.
-- | * `Ignore`: ignore this stream. This will cause Node to open /dev/null and
-- |   connect it to the stream.
-- | * `ShareStream`: Connect the supplied stream to the corresponding file
-- |    descriptor in the child.
-- | * `ShareFD`: Connect the supplied file descriptor (which should be open
-- |   in the parent) to the corresponding file descriptor in the child.
data StdIOBehaviour
  = Pipe
  | Ignore
  | ShareStream (forall r eff. Stream r eff)
  | ShareFD FS.FileDescriptor

-- | Create pipes for each of the three standard IO streams.
pipe :: Array (Maybe StdIOBehaviour)
pipe = map Just [Pipe, Pipe, Pipe]

-- | Share stdin with stdin, stdout with stdout, and stderr with stderr.
inherit :: Array (Maybe StdIOBehaviour)
inherit = map Just
  [ ShareStream process.stdin
  , ShareStream process.stdout
  , ShareStream process.stderr
  ]

foreign import process :: forall props. { | props }

-- | Ignore all streams.
ignore :: Array (Maybe StdIOBehaviour)
ignore = map Just [Ignore, Ignore, Ignore]

foreign import data ActualStdIOBehaviour :: *

toActualStdIOBehaviour :: StdIOBehaviour -> ActualStdIOBehaviour
toActualStdIOBehaviour b = case b of
  Pipe               -> c "pipe"
  Ignore             -> c "ignore"
  ShareFD x          -> c x
  ShareStream stream -> c stream
  where
  c :: forall a. a -> ActualStdIOBehaviour
  c = unsafeCoerce

type ActualStdIOOptions = Array (Nullable ActualStdIOBehaviour)

toActualStdIOOptions :: Array (Maybe StdIOBehaviour) -> ActualStdIOOptions
toActualStdIOOptions = map (toNullable <<< map toActualStdIOBehaviour)

-- | This module contains various types and functions to allow you to spawn and
-- | interact with child processes.
-- |
-- | It is intended to be imported qualified, as follows:
-- |
-- | ```purescript
-- | import Node.ChildProcess (ChildProcess(), CHILD_PROCESS())
-- | import Node.ChildProcess as ChildProcess
-- | ```
-- |
-- | The [Node.js documentation](https://nodejs.org/api/child_process.html)
-- | will probably also be useful to read if you want to use this module.
module Node.ChildProcess
  ( Handle()
  , ChildProcess()
  , CHILD_PROCESS()
  , stderr
  , stdout
  , stdin
  , pid
  , connected
  , kill
  , send
  , disconnect
  , Error()
  , toStandardError
  , Exit(..)
  , onExit
  , onClose
  , onDisconnect
  , onMessage
  , onError
  , spawn
  , SpawnOptions()
  , defaultSpawnOptions
  , exec
  , ExecOptions()
  , ExecResult()
  , defaultExecOptions
  , fork
  , StdIOBehaviour(..)
  , pipe
  , inherit
  , ignore
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Bind ((>=>))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception as Exception
import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)

import Data.StrMap (StrMap())
import Data.Function (Fn2(), runFn2)
import Data.Nullable (Nullable(), toNullable, toMaybe)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Foreign (Foreign())
import Data.Posix (Pid(), Gid(), Uid())
import Data.Posix.Signal (Signal())
import Data.Posix.Signal as Signal
import Unsafe.Coerce (unsafeCoerce)

import Node.Buffer (Buffer())
import Node.Encoding (Encoding())
import Node.FS as FS
import Node.Stream (Readable(), Writable(), Stream())

-- | A handle for inter-process communication (IPC).
foreign import data Handle :: *

-- | The effect for creating and interacting with child processes.
foreign import data CHILD_PROCESS :: !

newtype ChildProcess = ChildProcess ChildProcessRec

runChildProcess :: ChildProcess -> ChildProcessRec
runChildProcess (ChildProcess r) = r

-- | Note: some of these types are lies, and so it is unsafe to access some of
-- | these record fields directly.
type ChildProcessRec =
  { stdin      :: forall eff. Nullable (Writable () (cp :: CHILD_PROCESS | eff))
  , stdout     :: forall eff. Nullable (Readable () (cp :: CHILD_PROCESS | eff))
  , stderr     :: forall eff. Nullable (Readable () (cp :: CHILD_PROCESS | eff))
  , pid        :: Pid
  , connected  :: Boolean
  , kill       :: String -> Boolean
  , send       :: forall r. Fn2 { | r} Handle Boolean
  , disconnect :: forall eff. Eff eff Unit
  }

-- | The standard input stream of a child process. Note that this is only
-- | available if the process was spawned with the stdin option set to "pipe".
stdin :: forall eff. ChildProcess -> Writable () (cp :: CHILD_PROCESS | eff)
stdin = unsafeFromNullable (missingStream "stdin") <<< _.stdin <<< runChildProcess

-- | The standard output stream of a child process. Note that this is only
-- | available if the process was spawned with the stdout option set to "pipe".
stdout :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS | eff)
stdout = unsafeFromNullable (missingStream "stdout") <<< _.stdout <<< runChildProcess

-- | The standard error stream of a child process. Note that this is only
-- | available if the process was spawned with the stderr option set to "pipe".
stderr :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS| eff)
stderr = unsafeFromNullable (missingStream "stderr") <<< _.stderr <<< runChildProcess

missingStream :: String -> String
missingStream str =
  "Node.ChildProcess: stream not available: " <> str <> "\nThis is probably "
  <> "because you passed something other than Pipe to the stdio option when "
  <> "you spawned it."

foreign import unsafeFromNullable :: forall a. String -> Nullable a -> a

-- | The process ID of a child process. Note that if the process has already
-- | exited, another process may have taken the same ID, so be careful!
pid :: ChildProcess -> Pid
pid = _.pid <<< runChildProcess

connected :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
connected (ChildProcess cp) = mkEff \_ -> cp.connected

send :: forall eff props. { | props } -> Handle -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
send msg handle (ChildProcess cp) = mkEff \_ -> runFn2 cp.send msg handle

disconnect :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Unit
disconnect = _.disconnect <<< runChildProcess

-- | Send a signal to a child process. It's an unfortunate historical decision
-- | that this function is called "kill", as sending a signal to a child
-- | process won't necessarily kill it.
kill :: forall eff. Signal -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
kill sig (ChildProcess cp) = mkEff \_ -> cp.kill (Signal.toString sig)

mkEff :: forall eff a. (Unit -> a) -> Eff eff a
mkEff = unsafeCoerce

-- | Specifies how a child process exited; normally (with an exit code), or
-- | due to a signal.
data Exit
  = Normally Int
  | BySignal Signal

instance showExit :: Show Exit where
  show (Normally x) = "Normally " <> show x
  show (BySignal sig) = "BySignal " <> show sig

mkExit :: Nullable Int -> Nullable String -> Exit
mkExit code signal =
  case fromCode code <|> fromSignal signal of
    Just e -> e
    Nothing -> unsafeThrow "Node.ChildProcess.mkExit: Invalid arguments"
  where
  fromCode   = toMaybe >>> map Normally
  fromSignal = toMaybe >=> Signal.fromString >>> map BySignal

onExit :: forall eff. ChildProcess -> (Exit -> Eff eff Unit) -> Eff eff Unit
onExit = mkOnExit mkExit

foreign import mkOnExit :: forall eff.
          (Nullable Int -> Nullable String -> Exit)
          -> ChildProcess -> (Exit -> Eff eff Unit) -> Eff eff Unit

onClose :: forall eff. ChildProcess -> (Exit -> Eff eff Unit) -> Eff eff Unit
onClose = mkOnClose mkExit

foreign import mkOnClose :: forall eff.
          (Nullable Int -> Nullable String -> Exit)
          -> ChildProcess -> (Exit -> Eff eff Unit) -> Eff eff Unit

onMessage :: forall eff.  ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit
onMessage = mkOnMessage Nothing Just

foreign import mkOnMessage :: forall a eff.
          Maybe a -> (a -> Maybe a) ->
          ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit

foreign import onDisconnect :: forall eff. ChildProcess -> Eff eff Unit -> Eff eff Unit
foreign import onError :: forall eff. ChildProcess -> (Error -> Eff eff Unit) -> Eff eff Unit

-- | Spawn a child process. Note that, in the event that a child process could
-- | not be spawned (for example, if the executable was not found) this will
-- | not throw an error. Instead, the `ChildProcess` will be created anyway,
-- | but it will immediately emit an 'error' event.
spawn :: forall eff. String -> Array String -> SpawnOptions -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess
spawn cmd args opts = spawnImpl cmd args (convertOpts opts)
  where
  convertOpts opts =
    { cwd: fromMaybe undefined opts.cwd
    , stdio: toActualStdIOOptions opts.stdio
    , env: toNullable opts.env
    , detached: opts.detached
    , uid: fromMaybe undefined opts.uid
    , gid: fromMaybe undefined opts.gid
    }

foreign import spawnImpl :: forall opts eff. String -> Array String -> { | opts } -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

-- There's gotta be a better way.
foreign import undefined :: forall a. a

type SpawnOptions =
  { cwd       :: Maybe String
  , stdio     :: Array (Maybe StdIOBehaviour)
  , env       :: Maybe (StrMap String)
  , detached  :: Boolean
  , uid       :: Maybe Uid
  , gid       :: Maybe Gid
  }

defaultSpawnOptions :: SpawnOptions
defaultSpawnOptions =
  { cwd: Nothing
  , stdio: pipe
  , env: Nothing
  , detached: false
  , uid: Nothing
  , gid: Nothing
  }

-- | Similar to `spawn`, except that this variant will buffer output, and wait
-- | until the process has exited before calling the callback.
-- |
-- | Note that the child process will be killed if the amount of output exceeds
-- | a certain threshold (the default is defined by Node.js).
exec :: forall eff.
  String ->
  ExecOptions ->
  (ExecResult -> Eff (cp :: CHILD_PROCESS | eff) Unit) ->
  Eff (cp :: CHILD_PROCESS | eff) Unit
exec cmd opts callback =
  execImpl cmd (convert opts) \err stdout' stderr' ->
    callback { error: (toMaybe err)
             , stdout: stdout'
             , stderr: stderr'
             }
  where
  convert opts =
    { cwd: fromMaybe undefined opts.cwd
    , env: fromMaybe undefined opts.env
    , timeout: fromMaybe undefined opts.timeout
    , maxBuffer: fromMaybe undefined opts.maxBuffer
    , killSignal: fromMaybe undefined opts.killSignal
    , uid: fromMaybe undefined opts.uid
    , gid: fromMaybe undefined opts.gid
    }

foreign import execImpl :: forall eff opts.
  String ->
  { | opts } ->
  (Nullable Exception.Error -> Buffer -> Buffer -> Eff (cp :: CHILD_PROCESS | eff) Unit) ->
  Eff (cp :: CHILD_PROCESS | eff) Unit

type ExecOptions =
  { cwd        :: Maybe String
  , env        :: Maybe (StrMap String)
  , timeout    :: Maybe Number
  , maxBuffer  :: Maybe Int
  , killSignal :: Maybe Signal
  , uid        :: Maybe Uid
  , gid        :: Maybe Gid
  }

defaultExecOptions :: ExecOptions
defaultExecOptions =
  { cwd: Nothing
  , env: Nothing
  , timeout: Nothing
  , maxBuffer: Nothing
  , killSignal: Nothing
  , uid: Nothing
  , gid: Nothing
  }

type ExecResult =
  { stderr :: Buffer
  , stdout :: Buffer
  , error  :: Maybe Exception.Error
  }

-- | A special case of `spawn` for creating Node.js child processes. The first
-- | argument is the module to be run, and the second is the argv (command line
-- | arguments).
foreign import fork :: forall eff. String -> Array String -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

-- | An error which occurred inside a child process.
type Error =
  { code :: String
  , errno :: String
  , syscall :: String
  }

-- | Convert a ChildProcess.Error to a standard Error, which can then be thrown
-- | inside an Eff or Aff computation (for example).
toStandardError :: Error -> Exception.Error
toStandardError = unsafeCoerce

-- | Behaviour for standard IO streams (eg, standard input, standard output) of
-- | a child process.
-- |
-- | * `Pipe`: creates a pipe between the child and parent process, which can
-- |   then be accessed as a `Stream` via the `stdin`, `stdout`, or `stderr`
-- |   functions.
-- | * `Ignore`: ignore this stream. This will cause Node to open /dev/null and
-- |   connect it to the stream.
-- | * `ShareStream`: Connect the supplied stream to the corresponding file
-- |    descriptor in the child.
-- | * `ShareFD`: Connect the supplied file descriptor (which should be open
-- |   in the parent) to the corresponding file descriptor in the child.
data StdIOBehaviour
  = Pipe
  | Ignore
  | ShareStream (forall r eff. Stream r eff)
  | ShareFD FS.FileDescriptor

-- | Create pipes for each of the three standard IO streams.
pipe :: Array (Maybe StdIOBehaviour)
pipe = map Just [Pipe, Pipe, Pipe]

-- | Share stdin with stdin, stdout with stdout, and stderr with stderr.
inherit :: Array (Maybe StdIOBehaviour)
inherit = map Just
  [ ShareStream process.stdin
  , ShareStream process.stdout
  , ShareStream process.stderr
  ]

foreign import process :: forall props. { | props }

-- | Ignore all streams.
ignore :: Array (Maybe StdIOBehaviour)
ignore = map Just [Ignore, Ignore, Ignore]

foreign import data ActualStdIOBehaviour :: *

toActualStdIOBehaviour :: StdIOBehaviour -> ActualStdIOBehaviour
toActualStdIOBehaviour b = case b of
  Pipe               -> c "pipe"
  Ignore             -> c "ignore"
  ShareFD x          -> c x
  ShareStream stream -> c stream
  where
  c :: forall a. a -> ActualStdIOBehaviour
  c = unsafeCoerce

type ActualStdIOOptions = Array (Nullable ActualStdIOBehaviour)

toActualStdIOOptions :: Array (Maybe StdIOBehaviour) -> ActualStdIOOptions
toActualStdIOOptions = map (toNullable <<< map toActualStdIOBehaviour)


Show download icon everywhere

Show download icon everywhere

module View.File.Toolbar (toolbar) where

import Controller.File
import Controller.File.Item
import Controller.File.Common (Event())
import Data.Path.Pathy
import Model.File
import Model.File.Item (Item(..))
import Model.Resource (Resource(..), root)
import View.File.Common (HTML(), toolItem)
import Optic.Core ((^.))

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as E
import qualified Halogen.Themes.Bootstrap3 as B
import qualified View.Css as Vc

toolbar :: forall e. State -> HTML e
toolbar state =
  H.div [ A.classes [B.colXs5, Vc.toolbarMenu] ]
        [ H.ul [ A.classes [B.listInline, B.pullRight] ]
               $ configure ++ [showHide, download, mount, folder, file, notebook]
        ]

  where

  configure :: [HTML e]
  configure =
    if state ^. _isMount
    then [toolItem [] (Database (state ^. _path)) handleConfigure "configure mount" B.glyphiconWrench]
    else []

  showHide :: HTML e
  showHide =
    if state ^. _showHiddenFiles
    then toolItem [] false handleHiddenFiles "hide hidden files" B.glyphiconEyeClose
    else toolItem [] true handleHiddenFiles "show hidden files" B.glyphiconEyeOpen

  download :: HTML e
  download = toolItem [] (Item root) handleDownloadItem "download" B.glyphiconDownloadAlt

  mount :: HTML e
  mount = toolItem' handleMountDatabase "mount database" B.glyphiconHdd

  folder :: HTML e
  folder = toolItem' handleCreateFolder "create folder" B.glyphiconFolderClose

  file :: HTML e
  file = H.li_ [ H.button [ E.onClick (\ev -> pure $ handleUploadFile ev.target) ]
                          [ H.i [ A.title "upload file"
                                , A.classes [B.glyphicon, B.glyphiconFile]
                                ]
                                [ H.input [ A.class_ B.hidden
                                          , A.type_ "file"
                                          , E.onChange (\ev -> pure $ handleFileListChanged ev.target state)
                                          ]
                                          []
                                ]
                          ]
               ]

  notebook :: HTML e
  notebook = toolItem' handleCreateNotebook "create notebook" B.glyphiconBook

  toolItem' :: (State -> Event e) -> String -> A.ClassName -> HTML e
  toolItem' f = toolItem [] state f

module View.File.Toolbar (toolbar) where

import Controller.File
import Controller.File.Item
import Controller.File.Common (Event())
import Data.Path.Pathy
import Model.File
import Model.File.Item (Item(..))
import Model.Resource (Resource(..), root)
import View.File.Common (HTML(), toolItem)
import Optic.Core ((^.))

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as E
import qualified Halogen.Themes.Bootstrap3 as B
import qualified View.Css as Vc

toolbar :: forall e. State -> HTML e
toolbar state =
  H.div [ A.classes [B.colXs5, Vc.toolbarMenu] ]
        [ H.ul [ A.classes [B.listInline, B.pullRight] ]
               $ [showHide] ++ download ++ mount ++ [folder, file, notebook]
        ]

  where

  showHide :: HTML e
  showHide =
    if state ^. _showHiddenFiles
    then toolItem [] false handleHiddenFiles "hide hidden files" B.glyphiconEyeClose
    else toolItem [] true handleHiddenFiles "show hidden files" B.glyphiconEyeOpen

  download :: [HTML e]
  download =
    if state ^. _path == rootDir
    then [toolItem [] (Item root) handleDownloadItem "download" B.glyphiconDownloadAlt]
    else []

  mount :: [HTML e]
  mount = (if state ^. _isMount
           then [toolItem [] (Database (state ^. _path)) handleConfigure "configure mount" B.glyphiconWrench]
           else [])
          ++ [toolItem' handleMountDatabase "mount database" B.glyphiconHdd]

  folder :: HTML e
  folder = toolItem' handleCreateFolder "create folder" B.glyphiconFolderClose

  file :: HTML e
  file = H.li_ [ H.button [ E.onClick (\ev -> pure $ handleUploadFile ev.target) ]
                          [ H.i [ A.title "upload file"
                                , A.classes [B.glyphicon, B.glyphiconFile]
                                ]
                                [ H.input [ A.class_ B.hidden
                                          , A.type_ "file"
                                          , E.onChange (\ev -> pure $ handleFileListChanged ev.target state)
                                          ]
                                          []
                                ]
                          ]
               ]

  notebook :: HTML e
  notebook = toolItem' handleCreateNotebook "create notebook" B.glyphiconBook

  toolItem' :: (State -> Event e) -> String -> A.ClassName -> HTML e
  toolItem' f = toolItem [] state f


reword documentation

reword documentation

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  ) where

import Prelude
import React as R
import Redox as Redox
import Control.Monad.Free (Free)
import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Data.Lens (Lens', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis)
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox (ReadRedox, SubscribeRedox, ReadWriteSubscribeRedox, Store, SubscriptionId)
import Type.Proxy (Proxy(..))

type DispatchFn state dsl eff = Free dsl (state -> state) -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff))

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

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

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

_connect
  :: forall state state' dsl props props' eff
   . (ReactThis props' (ConnectState state')
      -> Eff (context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff) (RedoxContext state dsl eff))
  -> Lens' state state'
  -> ((DispatchFn state dsl eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentWillMount = componentWillMount
    , componentWillUnmount = componentWillUnmount
    }
  where

    update this state = R.transformState this (_ { state = view _lns state })

    getInitialState this = do
      ctx <- addReactDisallowedEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    componentWillMount this = do
      ctx <- addReactEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      R.transformState this (_ { sid = Just sid })

    componentWillUnmount this = do
      ctx <- addReactReadOnlyEff $ ctxEff this
      msid <- (R.readState this) >>= pure <<< _.sid
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    renderFn this = do
      props' <- R.getProps this
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- unsafeCoerceEff $ R.readState this >>= pure <<< _.state
      pure $ R.createElement cls (_iso ctx.dispatch state props') []

    addReactEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.ReadWrite, refs :: R.ReactRefs (() :: # Effect) | e ) a
    addReactEff = unsafeCoerceEff

    addReactDisallowedEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.Disallowed, refs :: R.ReactRefs R.Disallowed | e ) a
    addReactDisallowedEff = unsafeCoerceEff

    addReactReadOnlyEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.ReadOnly, refs :: R.ReactRefs R.ReadOnly | e) a
    addReactReadOnlyEff = unsafeCoerceEff

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | 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)
-- | ```
connect'
  :: forall state state' dsl props props' eff
   . Lens' state state'
  -> (DispatchFn state dsl eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connect' _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = readContext (Proxy :: Proxy (RedoxContext state dsl eff)) this

connect
  :: forall state state' dsl props props' eff'
   . Lens' state state'
  -> (DispatchFn state dsl eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect _lns _iso cls = accessContext $ R.createClass $ connect' _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' eff
   . Store state
  -> DispatchFn state dsl eff
  -> Lens' state state'
  -> (DispatchFn state dsl eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connectStore store dispatch _lns _iso cls = _connect (const $ pure {store, dispatch}) _lns _iso cls

dispatch
  :: forall dsl props state eff
   . ReactThis props state
  -> Free dsl (state -> state)
  -> Eff (ReadWriteSubscribeRedox (context :: CONTEXT | eff)) (Canceler (ReadWriteSubscribeRedox (context :: CONTEXT | eff)))
dispatch this dsl = do
  _dispatch <- readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (context :: CONTEXT | eff) }) ) this >>= pure <<< _.redox.dispatch
  _dispatch dsl

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  ) where

import Prelude
import React as R
import Redox as Redox
import Control.Monad.Free (Free)
import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Data.Lens (Lens', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis)
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox (ReadRedox, SubscribeRedox, ReadWriteSubscribeRedox, Store, SubscriptionId)
import Type.Proxy (Proxy(..))

type DispatchFn state dsl eff = Free dsl (state -> state) -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff))

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

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

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

_connect
  :: forall state state' dsl props props' eff
   . (ReactThis props' (ConnectState state')
      -> Eff (context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff) (RedoxContext state dsl eff))
  -> Lens' state state'
  -> ((DispatchFn state dsl eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentWillMount = componentWillMount
    , componentWillUnmount = componentWillUnmount
    }
  where

    update this state = R.transformState this (_ { state = view _lns state })

    getInitialState this = do
      ctx <- addReactDisallowedEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    componentWillMount this = do
      ctx <- addReactEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      R.transformState this (_ { sid = Just sid })

    componentWillUnmount this = do
      ctx <- addReactReadOnlyEff $ ctxEff this
      msid <- (R.readState this) >>= pure <<< _.sid
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    renderFn this = do
      props' <- R.getProps this
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- unsafeCoerceEff $ R.readState this >>= pure <<< _.state
      pure $ R.createElement cls (_iso ctx.dispatch state props') []

    addReactEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.ReadWrite, refs :: R.ReactRefs (() :: # Effect) | e ) a
    addReactEff = unsafeCoerceEff

    addReactDisallowedEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.Disallowed, refs :: R.ReactRefs R.Disallowed | e ) a
    addReactDisallowedEff = unsafeCoerceEff

    addReactReadOnlyEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.ReadOnly, refs :: R.ReactRefs R.ReadOnly | e) a
    addReactReadOnlyEff = unsafeCoerceEff

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | 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)
-- | ```
connect'
  :: forall state state' dsl props props' eff
   . Lens' state state'
  -> (DispatchFn state dsl eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connect' _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = readContext (Proxy :: Proxy (RedoxContext state dsl eff)) this

connect
  :: forall state state' dsl props props' eff'
   . Lens' state state'
  -> (DispatchFn state dsl eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect _lns _iso cls = accessContext $ R.createClass $ connect' _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to use it together with server side rendering, since it
-- | relies on a global reference to the store.
connectStore
  :: forall state state' dsl props props' eff
   . Store state
  -> DispatchFn state dsl eff
  -> Lens' state state'
  -> (DispatchFn state dsl eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connectStore store dispatch _lns _iso cls = _connect (const $ pure {store, dispatch}) _lns _iso cls

dispatch
  :: forall dsl props state eff
   . ReactThis props state
  -> Free dsl (state -> state)
  -> Eff (ReadWriteSubscribeRedox (context :: CONTEXT | eff)) (Canceler (ReadWriteSubscribeRedox (context :: CONTEXT | eff)))
dispatch this dsl = do
  _dispatch <- readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (context :: CONTEXT | eff) }) ) this >>= pure <<< _.redox.dispatch
  _dispatch dsl