Updated the frontend test file to use ADTs.

I changed the status of the SpeakerQueue to a new Algebraic DataType
called SpeakerQueueStatus a while ago, this wasn't reflected in the
tests, so the tests failed. This commit makes the tests pass again.

module Test.Main where

import Data.Array as A
import Data.Either (Either(..))
import Data.Lens (over)
import Data.Maybe (Maybe(Nothing, Just), fromJust)
import Effect (Effect)
import Partial.Unsafe (unsafePartial)
import Prelude (Unit, discard, identity, otherwise, show, unit, ($), (&&), (<), (<=), (<>), (==), (||))
import Simple.JSON (readJSON)
import Test.QuickCheck (Result(Success, Failed))
import Test.Spec (describe, it)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.QuickCheck (quickCheck)
import Test.Spec.Reporter (consoleReporter)
import Test.Spec.Runner (run)
import Types.Agenda (empty, getCurrentAI, jumpToFirstActive)
import Types.Speaker as S
import Types.SpeakerQueue (SpeakerQueueState(..))
import Types.SpeakerQueue as SQ

isSuccessful :: Result -> Boolean
isSuccessful Success = true
isSuccessful _       = false

eitherToResult :: Either String Unit -> Result
eitherToResult
  = case _ of
      Left e  -> Failed e
      Right _ -> Success

resultAsEither :: Result -> (Either String Unit -> Either String Unit) -> Result
resultAsEither Success    f = eitherToResult $ f $ Right unit
resultAsEither (Failed e) f = eitherToResult $ f $ Left  e

speakersAreSortedCorrectly :: Array S.Speaker -> Result
speakersAreSortedCorrectly [] = Success
speakersAreSortedCorrectly ss
  = case A.head $ A.dropWhile isSuccessful $ A.zipWith checkPair ss' $ unsafePartial $ fromJust $ A.tail ss' of
      Nothing -> Success  -- No errors in the array.
      Just e  -> e        -- The first error in the array.
  where
    ss' = A.sort ss

    checkState :: S.SpeakerState -> S.SpeakerState -> Boolean
    checkState S.Active _        = true
    checkState _        S.Active = false
    checkState _        _        = true

    checkPair :: S.Speaker -> S.Speaker -> Result
    checkPair (S.Speaker s1) (S.Speaker s2)
      | checkState s1.state s2.state                       = Success
      | s1.timesSpoken <  s2.timesSpoken                   = Success
      | s1.timesSpoken == s2.timesSpoken && s1.id <= s2.id = Success
      | otherwise                                          = Failed ("Speakers are not correctly sorted for: \n\t" <> show (S.Speaker s1) <> "\n\t" <> show (S.Speaker s2))

theSpeakersLensRespectsInvariants :: SQ.SpeakerQueue -> Result
theSpeakersLensRespectsInvariants sq@(SQ.SpeakerQueue sqr)
  = let sq'@(SQ.SpeakerQueue sqr') = over SQ._Speakers identity sq
     in case A.head sqr.speakers of
          Just s@(S.Speaker sr) ->
            let ss' = A.filter (\(S.Speaker s1) -> s1.state == S.Deleted || s1.state == S.Done) sqr'.speakers
             in if A.null ss'
                  then Success
                  else Failed ("The final array contains speakers that are either Deleted or Done: " <> show ss')

          Nothing -> Success

main :: Effect Unit
main = run [consoleReporter] do
  describe "getCurrentAI" do
    it "doesn't crash if the Agenda is empty" $ do
      shouldEqual
        (getCurrentAI empty)
        (Left "ERROR: There is no current agenda item.")
  describe "jumpToFirstActive" do
    it "does nothing if the Agenda is empty" $ do
      shouldEqual
        (jumpToFirstActive empty)
        empty
  describe "Speakers" do
    they "are sorted correctly" $ quickCheck speakersAreSortedCorrectly
  describe "SpeakerQueue" do
    it "has a _Speaking lens that will not let people sneak past the speaking speaker" $ do
      let sq = SQ.SpeakerQueue { id :1, state: Active, speakers: [ firstSpeaker ]}
          firstSpeaker  = S.Speaker { id: 1, attendeeId: 1, state: S.Active, timesSpoken: 2 }
          secondSpeaker = S.Speaker { id: 2, attendeeId: 2, state: S.Init, timesSpoken: 1 }
      shouldEqual
        ((over SQ._Speakers $ A.insert secondSpeaker) sq)
        (SQ.SpeakerQueue { id :1, state: Active, speakers: [ firstSpeaker, secondSpeaker ]})

    it "has a _Speakers lens that respects the invariants" $ quickCheck theSpeakersLensRespectsInvariants
    it "has a ReadForeign that behaves well on no speakers." $ do
      shouldEqual
        (readJSON  """{"id":1,"state":"init","speakers":[]}""")
        (Right $ SQ.SpeakerQueue {id: 1, state: Init, speakers: []})

  where
    they = it

module Test.Main where

import Data.Array as A
import Data.Either (Either(..))
import Data.Lens (over)
import Data.Maybe (Maybe(Nothing, Just), fromJust)
import Effect (Effect)
import Partial.Unsafe (unsafePartial)
import Prelude (Unit, discard, identity, otherwise, show, unit, ($), (&&), (<), (<=), (<>), (==), (||))
import Simple.JSON (readJSON)
import Test.QuickCheck (Result(Success, Failed))
import Test.Spec (describe, it)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.QuickCheck (quickCheck)
import Test.Spec.Reporter (consoleReporter)
import Test.Spec.Runner (run)
import Types.Agenda (empty, getCurrentAI, jumpToFirstActive)
import Types.Speaker as S
import Types.SpeakerQueue as SQ

isSuccessful :: Result -> Boolean
isSuccessful Success = true
isSuccessful _       = false

eitherToResult :: Either String Unit -> Result
eitherToResult
  = case _ of
      Left e  -> Failed e
      Right _ -> Success

resultAsEither :: Result -> (Either String Unit -> Either String Unit) -> Result
resultAsEither Success    f = eitherToResult $ f $ Right unit
resultAsEither (Failed e) f = eitherToResult $ f $ Left  e

speakersAreSortedCorrectly :: Array S.Speaker -> Result
speakersAreSortedCorrectly [] = Success
speakersAreSortedCorrectly ss
  = case A.head $ A.dropWhile isSuccessful $ A.zipWith checkPair ss' $ unsafePartial $ fromJust $ A.tail ss' of
      Nothing -> Success  -- No errors in the array.
      Just e  -> e        -- The first error in the array.
  where
    ss' = A.sort ss

    checkState :: S.SpeakerState -> S.SpeakerState -> Boolean
    checkState S.Active _        = true
    checkState _        S.Active = false
    checkState _        _        = true

    checkPair :: S.Speaker -> S.Speaker -> Result
    checkPair (S.Speaker s1) (S.Speaker s2)
      | checkState s1.state s2.state                       = Success
      | s1.timesSpoken <  s2.timesSpoken                   = Success
      | s1.timesSpoken == s2.timesSpoken && s1.id <= s2.id = Success
      | otherwise                                          = Failed ("Speakers are not correctly sorted for: \n\t" <> show (S.Speaker s1) <> "\n\t" <> show (S.Speaker s2))

theSpeakersLensRespectsInvariants :: SQ.SpeakerQueue -> Result
theSpeakersLensRespectsInvariants sq@(SQ.SpeakerQueue sqr)
  = let sq'@(SQ.SpeakerQueue sqr') = over SQ._Speakers identity sq
     in case A.head sqr.speakers of
          Just s@(S.Speaker sr) ->
            let ss' = A.filter (\(S.Speaker s1) -> s1.state == S.Deleted || s1.state == S.Done) sqr'.speakers
             in if A.null ss'
                  then Success
                  else Failed ("The final array contains speakers that are either Deleted or Done: " <> show ss')

          Nothing -> Success

main :: Effect Unit
main = run [consoleReporter] do
  describe "getCurrentAI" do
    it "doesn't crash if the Agenda is empty" $ do
      shouldEqual
        (getCurrentAI empty)
        (Left "ERROR: There is no current agenda item.")
  describe "jumpToFirstActive" do
    it "does nothing if the Agenda is empty" $ do
      shouldEqual
        (jumpToFirstActive empty)
        empty
  describe "Speakers" do
    they "are sorted correctly" $ quickCheck speakersAreSortedCorrectly
  describe "SpeakerQueue" do
    it "has a _Speaking lens that will not let people sneak past the speaking speaker" $ do
      let sq = SQ.SpeakerQueue { id :1, state: "active", speakers: [ firstSpeaker ]}
          firstSpeaker  = S.Speaker { id: 1, attendeeId: 1, state: S.Active, timesSpoken: 2 }
          secondSpeaker = S.Speaker { id: 2, attendeeId: 2, state: S.Init, timesSpoken: 1 }
      shouldEqual
        ((over SQ._Speakers $ A.insert secondSpeaker) sq)
        (SQ.SpeakerQueue { id :1, state: "active", speakers: [ firstSpeaker, secondSpeaker ]})

    it "has a _Speakers lens that respects the invariants" $ quickCheck theSpeakersLensRespectsInvariants
    it "has a ReadForeign that behaves well on no speakers." $ do
      shouldEqual
        (readJSON  """{"id":1,"state":"init","speakers":[]}""")
        (Right $ SQ.SpeakerQueue {id: 1, state: "init", speakers: []})

  where
    they = it


Update JSON.purs

Update JSON.purs

module Simple.JSON
( E
, readJSON
, readJSON'
, writeJSON
, write
, read
, read'
, parseJSON
, undefined

, class ReadForeign
, readImpl
, class ReadForeignFields
, getFields
, class ReadForeignVariant
, readVariantImpl

, class WriteForeign
, writeImpl
, class WriteForeignFields
, writeImplFields
, class WriteForeignVariant
, writeVariantImpl

) where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Except (ExceptT(..), runExcept, withExcept)
import Data.Bifunctor (lmap)
import Data.Either (Either)
import Data.Identity (Identity(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Nullable (Nullable, toMaybe, toNullable)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (sequence, traverse)
import Data.Variant (Variant, inj, on)
import Effect.Exception (message, try)
import Effect.Uncurried as EU
import Effect.Unsafe (unsafePerformEffect)
import Foreign (F, Foreign, ForeignError(..), MultipleErrors, fail, isNull, isUndefined, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString, tagOf, unsafeFromForeign, unsafeToForeign)
import Foreign.Index (readProp)
import Foreign.Object (Object)
import Foreign.Object as Object
import Global.Unsafe (unsafeStringify)
import Partial.Unsafe (unsafeCrashWith)
import Prim.Row as Row
import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
import Record (get)
import Record.Builder (Builder)
import Record.Builder as Builder
import Type.Prelude (RLProxy(..))

-- | An alias for the Either result of decoding
type E a = Either MultipleErrors a

-- | Read a JSON string to a type `a` while returning a `MultipleErrors` if the
-- | parsing failed.
readJSON :: forall a
  .  ReadForeign a
  => String
  -> E a
readJSON = runExcept <<< (readImpl <=< parseJSON)

-- | Read a JSON string to a type `a` using `F a`. Useful with record types.
readJSON' :: forall a
  .  ReadForeign a
  => String
  -> F a
readJSON' = readImpl <=< parseJSON

-- | Write a JSON string from a type `a`.
writeJSON :: forall a
  .  WriteForeign a
  => a
  -> String
writeJSON = unsafeStringify <<< writeImpl

write :: forall a
  .  WriteForeign a
  => a
  -> Foreign
write = writeImpl

read :: forall a
   . ReadForeign a
  => Foreign
  -> E a
read = runExcept <<< readImpl

readAsForeign :: forall a b
   . ReadForeign a
  => b
  -> E a
readAsForeign = read <<< unsafeToForeign

read' :: forall a
  .  ReadForeign a
  => Foreign
  -> F a
read' = readImpl

foreign import _parseJSON :: EU.EffectFn1 String Foreign

parseJSON :: String -> F Foreign
parseJSON
    = ExceptT
  <<< Identity
  <<< lmap (pure <<< ForeignError <<< message)
  <<< runPure
  <<< try
  <<< EU.runEffectFn1 _parseJSON
  where
    -- Nate Faubion: "It uses unsafePerformEffect because that’s the only way to catch exceptions and still use the builtin json decoder"
    runPure = unsafePerformEffect

foreign import _undefined :: Foreign

undefined :: Foreign
undefined = _undefined

-- | A class for reading foreign values to a type
class ReadForeign a where
  readImpl :: Foreign -> F a

instance readForeign :: ReadForeign Foreign where
  readImpl = pure

instance readChar :: ReadForeign Char where
  readImpl = readChar

instance readNumber :: ReadForeign Number where
  readImpl = readNumber

instance readInt :: ReadForeign Int where
  readImpl = readInt

instance readString :: ReadForeign String where
  readImpl = readString

instance readBoolean :: ReadForeign Boolean where
  readImpl = readBoolean

instance readArray :: ReadForeign a => ReadForeign (Array a) where
  readImpl = traverse readImpl <=< readArray

instance readMaybe :: ReadForeign a => ReadForeign (Maybe a) where
  readImpl = readNullOrUndefined readImpl
    where
      readNullOrUndefined _ value | isNull value || isUndefined value = pure Nothing
      readNullOrUndefined f value = Just <$> f value

instance readNullable :: ReadForeign a => ReadForeign (Nullable a) where
  readImpl o = withExcept (map reformat) $
    map toNullable <$> traverse readImpl =<< readNull o
    where
      reformat error = case error of
        TypeMismatch inner other -> TypeMismatch ("Nullable " <> inner) other
        _ -> error

instance readObject :: ReadForeign a => ReadForeign (Object.Object a) where
  readImpl = sequence <<< Object.mapWithKey (const readImpl) <=< readObject'
    where
      readObject' :: Foreign -> F (Object Foreign)
      readObject' value
        | tagOf value == "Object" = pure $ unsafeFromForeign value
        | otherwise = fail $ TypeMismatch "Object" (tagOf value)

instance readRecord ::
  ( RowToList fields fieldList
  , ReadForeignFields fieldList () fields
  ) => ReadForeign (Record fields) where
  readImpl o = flip Builder.build {} <$> getFields fieldListP o
    where
      fieldListP = RLProxy :: RLProxy fieldList

-- | A class for reading foreign values from properties
class ReadForeignFields (xs :: RowList) (from :: # Type) (to :: # Type)
  | xs -> from to where
  getFields :: RLProxy xs
    -> Foreign
    -> F (Builder (Record from) (Record to))

instance readFieldsCons ::
  ( IsSymbol name
  , ReadForeign ty
  , ReadForeignFields tail from from'
  , Row.Lacks name from'
  , Row.Cons name ty from' to
  ) => ReadForeignFields (Cons name ty tail) from to where
  getFields _ obj = ado
    value <- withExcept' (readImpl =<< readProp name obj)
    let first = Builder.insert nameP value
    rest <- getFields tailP obj
    in first <<< rest
    where
      nameP = SProxy :: SProxy name
      tailP = RLProxy :: RLProxy tail
      name = reflectSymbol nameP
      withExcept' = withExcept <<< map $ ErrorAtProperty name

instance readFieldsNil ::
  ReadForeignFields Nil () () where
  getFields _ _ =
    pure identity

instance readForeignVariant ::
  ( RowToList variants rl
  , ReadForeignVariant rl variants
  ) => ReadForeign (Variant variants) where
  readImpl o = readVariantImpl (RLProxy :: RLProxy rl) o

class ReadForeignVariant (xs :: RowList) (row :: # Type)
  | xs -> row where
  readVariantImpl :: RLProxy xs
    -> Foreign
    -> F (Variant row)

instance readVariantNil ::
  ReadForeignVariant Nil trash where
  readVariantImpl _ _ = fail $ ForeignError "Unable to match any variant member."

instance readVariantCons ::
  ( IsSymbol name
  , ReadForeign ty
  , Row.Cons name ty trash row
  , ReadForeignVariant tail row
  ) => ReadForeignVariant (Cons name ty tail) row where
  readVariantImpl _ o = do
    obj :: { type :: String, value :: Foreign } <- readImpl o
    if obj.type == name
      then do
        value :: ty <- readImpl obj.value
        pure $ inj namep value
      else
        (fail <<< ForeignError $ "Did not match variant tag " <> name)
    <|> readVariantImpl (RLProxy :: RLProxy tail) o
    where
      namep = SProxy :: SProxy name
      name = reflectSymbol namep

-- -- | A class for writing a value into JSON
-- -- | need to do this intelligently using Foreign probably, because of null and undefined whatever
class WriteForeign a where
  writeImpl :: a -> Foreign

instance writeForeignForeign :: WriteForeign Foreign where
  writeImpl = identity

instance writeForeignString :: WriteForeign String where
  writeImpl = unsafeToForeign

instance writeForeignInt :: WriteForeign Int where
  writeImpl = unsafeToForeign

instance writeForeignChar :: WriteForeign Char where
  writeImpl = unsafeToForeign

instance writeForeignNumber :: WriteForeign Number where
  writeImpl = unsafeToForeign

instance writeForeignBoolean :: WriteForeign Boolean where
  writeImpl = unsafeToForeign

instance writeForeignArray :: WriteForeign a => WriteForeign (Array a) where
  writeImpl xs = unsafeToForeign $ writeImpl <$> xs

instance writeForeignMaybe :: WriteForeign a => WriteForeign (Maybe a) where
  writeImpl = maybe undefined writeImpl

instance writeForeignNullable :: WriteForeign a => WriteForeign (Nullable a) where
  writeImpl = maybe (unsafeToForeign $ toNullable Nothing) writeImpl <<< toMaybe

instance writeForeignObject :: WriteForeign a => WriteForeign (Object.Object a) where
  writeImpl = unsafeToForeign <<< Object.mapWithKey (const writeImpl)

instance recordWriteForeign ::
  ( RowToList row rl
  , WriteForeignFields rl row () to
  ) => WriteForeign (Record row) where
  writeImpl rec = unsafeToForeign $ Builder.build steps {}
    where
      rlp = RLProxy :: RLProxy rl
      steps = writeImplFields rlp rec

class WriteForeignFields (rl :: RowList) row (from :: # Type) (to :: # Type)
  | rl -> row from to where
  writeImplFields :: forall g. g rl -> Record row -> Builder (Record from) (Record to)

instance consWriteForeignFields ::
  ( IsSymbol name
  , WriteForeign ty
  , WriteForeignFields tail row from from'
  , Row.Cons name ty whatever row
  , Row.Lacks name from'
  , Row.Cons name Foreign from' to
  ) => WriteForeignFields (Cons name ty tail) row from to where
  writeImplFields _ rec = result
    where
      namep = SProxy :: SProxy name
      value = writeImpl $ get namep rec
      tailp = RLProxy :: RLProxy tail
      rest = writeImplFields tailp rec
      result = Builder.insert namep value <<< rest
instance nilWriteForeignFields ::
  WriteForeignFields Nil row () () where
  writeImplFields _ _ = identity

instance writeForeignVariant ::
  ( RowToList row rl
  , WriteForeignVariant rl row
  ) => WriteForeign (Variant row) where
  writeImpl variant = writeVariantImpl (RLProxy :: RLProxy rl) variant

class WriteForeignVariant (rl :: RowList) (row :: # Type)
  | rl -> row where
  writeVariantImpl :: forall g. g rl -> Variant row -> Foreign

instance nilWriteForeignVariant ::
  WriteForeignVariant Nil () where
  writeVariantImpl _ _ =
    -- a PureScript-defined variant cannot reach this path, but a JavaScript FFI one could.
    unsafeCrashWith "Variant was not able to be writen row WriteForeign."

instance consWriteForeignVariant ::
  ( IsSymbol name
  , WriteForeign ty
  , Row.Cons name ty subRow row
  , WriteForeignVariant tail subRow
  ) => WriteForeignVariant (Cons name ty tail) row where
  writeVariantImpl _ variant =
    on
      namep
      writeVariant
      (writeVariantImpl (RLProxy :: RLProxy tail))
      variant
    where
    namep = SProxy :: SProxy name
    writeVariant value = unsafeToForeign
      { type: reflectSymbol namep
      , value: writeImpl value
      }

module Simple.JSON
( E
, readJSON
, readJSON'
, writeJSON
, write
, read
, read'
, parseJSON
, undefined

, class ReadForeign
, readImpl
, class ReadForeignFields
, getFields
, class ReadForeignVariant
, readVariantImpl

, class WriteForeign
, writeImpl
, class WriteForeignFields
, writeImplFields
, class WriteForeignVariant
, writeVariantImpl

) where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Except (ExceptT(..), runExcept, withExcept)
import Data.Bifunctor (lmap)
import Data.Either (Either)
import Data.Identity (Identity(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Nullable (Nullable, toMaybe, toNullable)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (sequence, traverse)
import Data.Variant (Variant, inj, on)
import Effect.Exception (message, try)
import Effect.Uncurried as EU
import Effect.Unsafe (unsafePerformEffect)
import Foreign (F, Foreign, ForeignError(..), MultipleErrors, fail, isNull, isUndefined, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString, tagOf, unsafeFromForeign, unsafeToForeign)
import Foreign.Index (readProp)
import Foreign.Object (Object)
import Foreign.Object as Object
import Global.Unsafe (unsafeStringify)
import Partial.Unsafe (unsafeCrashWith)
import Prim.Row as Row
import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
import Record (get)
import Record.Builder (Builder)
import Record.Builder as Builder
import Type.Prelude (RLProxy(..))

-- | An alias for the Either result of decoding
type E a = Either MultipleErrors a

-- | Read a JSON string to a type `a` while returning a `MultipleErrors` if the
-- | parsing failed.
readJSON :: forall a
  .  ReadForeign a
  => String
  -> E a
readJSON = runExcept <<< (readImpl <=< parseJSON)

-- | Read a JSON string to a type `a` using `F a`. Useful with record types.
readJSON' :: forall a
  .  ReadForeign a
  => String
  -> F a
readJSON' = readImpl <=< parseJSON

-- | Write a JSON string from a type `a`.
writeJSON :: forall a
  .  WriteForeign a
  => a
  -> String
writeJSON = unsafeStringify <<< writeImpl

write :: forall a
  .  WriteForeign a
  => a
  -> Foreign
write = writeImpl

read :: forall a
   . ReadForeign a
  => Foreign
  -> E a
read = runExcept <<< readImpl

readAsForeign :: forall a b
   . ReadForeign a
  => b
  -> E a
readAsForeign = read <<< unsafeToForeign

read' :: forall a
  .  ReadForeign a
  => Foreign
  -> F a
read' = readImpl

foreign import _parseJSON :: EU.EffectFn1 String Foreign

parseJSON :: String -> F Foreign
parseJSON
    = ExceptT
  <<< Identity
  <<< lmap (pure <<< ForeignError <<< message)
  <<< runPure
  <<< try
  <<< EU.runEffectFn1 _parseJSON
  where
    runPure = unsafePerformEffect

foreign import _undefined :: Foreign

undefined :: Foreign
undefined = _undefined

-- | A class for reading foreign values to a type
class ReadForeign a where
  readImpl :: Foreign -> F a

instance readForeign :: ReadForeign Foreign where
  readImpl = pure

instance readChar :: ReadForeign Char where
  readImpl = readChar

instance readNumber :: ReadForeign Number where
  readImpl = readNumber

instance readInt :: ReadForeign Int where
  readImpl = readInt

instance readString :: ReadForeign String where
  readImpl = readString

instance readBoolean :: ReadForeign Boolean where
  readImpl = readBoolean

instance readArray :: ReadForeign a => ReadForeign (Array a) where
  readImpl = traverse readImpl <=< readArray

instance readMaybe :: ReadForeign a => ReadForeign (Maybe a) where
  readImpl = readNullOrUndefined readImpl
    where
      readNullOrUndefined _ value | isNull value || isUndefined value = pure Nothing
      readNullOrUndefined f value = Just <$> f value

instance readNullable :: ReadForeign a => ReadForeign (Nullable a) where
  readImpl o = withExcept (map reformat) $
    map toNullable <$> traverse readImpl =<< readNull o
    where
      reformat error = case error of
        TypeMismatch inner other -> TypeMismatch ("Nullable " <> inner) other
        _ -> error

instance readObject :: ReadForeign a => ReadForeign (Object.Object a) where
  readImpl = sequence <<< Object.mapWithKey (const readImpl) <=< readObject'
    where
      readObject' :: Foreign -> F (Object Foreign)
      readObject' value
        | tagOf value == "Object" = pure $ unsafeFromForeign value
        | otherwise = fail $ TypeMismatch "Object" (tagOf value)

instance readRecord ::
  ( RowToList fields fieldList
  , ReadForeignFields fieldList () fields
  ) => ReadForeign (Record fields) where
  readImpl o = flip Builder.build {} <$> getFields fieldListP o
    where
      fieldListP = RLProxy :: RLProxy fieldList

-- | A class for reading foreign values from properties
class ReadForeignFields (xs :: RowList) (from :: # Type) (to :: # Type)
  | xs -> from to where
  getFields :: RLProxy xs
    -> Foreign
    -> F (Builder (Record from) (Record to))

instance readFieldsCons ::
  ( IsSymbol name
  , ReadForeign ty
  , ReadForeignFields tail from from'
  , Row.Lacks name from'
  , Row.Cons name ty from' to
  ) => ReadForeignFields (Cons name ty tail) from to where
  getFields _ obj = ado
    value <- withExcept' (readImpl =<< readProp name obj)
    let first = Builder.insert nameP value
    rest <- getFields tailP obj
    in first <<< rest
    where
      nameP = SProxy :: SProxy name
      tailP = RLProxy :: RLProxy tail
      name = reflectSymbol nameP
      withExcept' = withExcept <<< map $ ErrorAtProperty name

instance readFieldsNil ::
  ReadForeignFields Nil () () where
  getFields _ _ =
    pure identity

instance readForeignVariant ::
  ( RowToList variants rl
  , ReadForeignVariant rl variants
  ) => ReadForeign (Variant variants) where
  readImpl o = readVariantImpl (RLProxy :: RLProxy rl) o

class ReadForeignVariant (xs :: RowList) (row :: # Type)
  | xs -> row where
  readVariantImpl :: RLProxy xs
    -> Foreign
    -> F (Variant row)

instance readVariantNil ::
  ReadForeignVariant Nil trash where
  readVariantImpl _ _ = fail $ ForeignError "Unable to match any variant member."

instance readVariantCons ::
  ( IsSymbol name
  , ReadForeign ty
  , Row.Cons name ty trash row
  , ReadForeignVariant tail row
  ) => ReadForeignVariant (Cons name ty tail) row where
  readVariantImpl _ o = do
    obj :: { type :: String, value :: Foreign } <- readImpl o
    if obj.type == name
      then do
        value :: ty <- readImpl obj.value
        pure $ inj namep value
      else
        (fail <<< ForeignError $ "Did not match variant tag " <> name)
    <|> readVariantImpl (RLProxy :: RLProxy tail) o
    where
      namep = SProxy :: SProxy name
      name = reflectSymbol namep

-- -- | A class for writing a value into JSON
-- -- | need to do this intelligently using Foreign probably, because of null and undefined whatever
class WriteForeign a where
  writeImpl :: a -> Foreign

instance writeForeignForeign :: WriteForeign Foreign where
  writeImpl = identity

instance writeForeignString :: WriteForeign String where
  writeImpl = unsafeToForeign

instance writeForeignInt :: WriteForeign Int where
  writeImpl = unsafeToForeign

instance writeForeignChar :: WriteForeign Char where
  writeImpl = unsafeToForeign

instance writeForeignNumber :: WriteForeign Number where
  writeImpl = unsafeToForeign

instance writeForeignBoolean :: WriteForeign Boolean where
  writeImpl = unsafeToForeign

instance writeForeignArray :: WriteForeign a => WriteForeign (Array a) where
  writeImpl xs = unsafeToForeign $ writeImpl <$> xs

instance writeForeignMaybe :: WriteForeign a => WriteForeign (Maybe a) where
  writeImpl = maybe undefined writeImpl

instance writeForeignNullable :: WriteForeign a => WriteForeign (Nullable a) where
  writeImpl = maybe (unsafeToForeign $ toNullable Nothing) writeImpl <<< toMaybe

instance writeForeignObject :: WriteForeign a => WriteForeign (Object.Object a) where
  writeImpl = unsafeToForeign <<< Object.mapWithKey (const writeImpl)

instance recordWriteForeign ::
  ( RowToList row rl
  , WriteForeignFields rl row () to
  ) => WriteForeign (Record row) where
  writeImpl rec = unsafeToForeign $ Builder.build steps {}
    where
      rlp = RLProxy :: RLProxy rl
      steps = writeImplFields rlp rec

class WriteForeignFields (rl :: RowList) row (from :: # Type) (to :: # Type)
  | rl -> row from to where
  writeImplFields :: forall g. g rl -> Record row -> Builder (Record from) (Record to)

instance consWriteForeignFields ::
  ( IsSymbol name
  , WriteForeign ty
  , WriteForeignFields tail row from from'
  , Row.Cons name ty whatever row
  , Row.Lacks name from'
  , Row.Cons name Foreign from' to
  ) => WriteForeignFields (Cons name ty tail) row from to where
  writeImplFields _ rec = result
    where
      namep = SProxy :: SProxy name
      value = writeImpl $ get namep rec
      tailp = RLProxy :: RLProxy tail
      rest = writeImplFields tailp rec
      result = Builder.insert namep value <<< rest
instance nilWriteForeignFields ::
  WriteForeignFields Nil row () () where
  writeImplFields _ _ = identity

instance writeForeignVariant ::
  ( RowToList row rl
  , WriteForeignVariant rl row
  ) => WriteForeign (Variant row) where
  writeImpl variant = writeVariantImpl (RLProxy :: RLProxy rl) variant

class WriteForeignVariant (rl :: RowList) (row :: # Type)
  | rl -> row where
  writeVariantImpl :: forall g. g rl -> Variant row -> Foreign

instance nilWriteForeignVariant ::
  WriteForeignVariant Nil () where
  writeVariantImpl _ _ =
    -- a PureScript-defined variant cannot reach this path, but a JavaScript FFI one could.
    unsafeCrashWith "Variant was not able to be writen row WriteForeign."

instance consWriteForeignVariant ::
  ( IsSymbol name
  , WriteForeign ty
  , Row.Cons name ty subRow row
  , WriteForeignVariant tail subRow
  ) => WriteForeignVariant (Cons name ty tail) row where
  writeVariantImpl _ variant =
    on
      namep
      writeVariant
      (writeVariantImpl (RLProxy :: RLProxy tail))
      variant
    where
    namep = SProxy :: SProxy name
    writeVariant value = unsafeToForeign
      { type: reflectSymbol namep
      , value: writeImpl value
      }


_connect: add children

_connect: add children

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

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

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

foreign import unsafeShallowEqual :: forall a. Fn2 a a Boolean

foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

-- | 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 reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

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

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

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

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      void $ writeState this (st { state = view _lns state })

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to ctxEff
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    componentWillMount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      st <- readState this
      void $ writeState this (st { sid = Just sid })

    componentWillUnmount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      { sid: msid } <- R.readState this
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    shouldComponentUpdate this nPr nSt = do
      pr <- getProps this
      st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn2 unsafeShallowEqual pr nPr)

    renderFn this = do
      props' <- R.getProps this
      children <- R.getChildren this
      ctx <- unsafeCoerceEff $ ctxEff this
      { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') children

-- | 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' reff eff
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = _.redox <$> ctx
      where
        ctx = readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })) this

connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p _lns _iso cls = accessContext $ R.createClass $ connect' p _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' reff eff
   . Store state
  -> DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure {store, dispatch: dispatch_}) _lns _iso cls

dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Canceler (context :: CONTEXT, redox :: RedoxStore reff | eff))
dispatch this dsl = do
  { dispatch: disp } <- _.redox <$> readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) }) ) this
  disp dsl

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

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

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

foreign import unsafeShallowEqual :: forall a. Fn2 a a Boolean

foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

-- | 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 reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

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

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

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

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      void $ writeState this (st { state = view _lns state })

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to ctxEff
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    componentWillMount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      st <- readState this
      void $ writeState this (st { sid = Just sid })

    componentWillUnmount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      { sid: msid } <- R.readState this
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    shouldComponentUpdate this nPr nSt = do
      pr <- getProps this
      st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn2 unsafeShallowEqual pr nPr)

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

-- | 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' reff eff
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = _.redox <$> ctx
      where
        ctx = readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })) this

connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p _lns _iso cls = accessContext $ R.createClass $ connect' p _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' reff eff
   . Store state
  -> DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure {store, dispatch: dispatch_}) _lns _iso cls

dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Canceler (context :: CONTEXT, redox :: RedoxStore reff | eff))
dispatch this dsl = do
  { dispatch: disp } <- _.redox <$> readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) }) ) this
  disp dsl


use Getter' type instead of Lens'

use Getter' type instead of Lens'

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

import Prelude
import React as R
import Redox as Redox
import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, runFn2)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis, getProps, readState)
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))

foreign import unsafeShallowEqual :: forall a. Fn2 a a Boolean

foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

-- | 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))
  -> Getter' 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
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    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

    shouldComponentUpdate this nPr nSt = do
      pr <- getProps this
      st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn2 unsafeShallowEqual pr nPr)

    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
   . Getter' 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 = _.redox <$> ctx
      where
        ctx = readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl eff })) this

connect
  :: forall state state' dsl props props' eff'
   . Getter' 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
  -> Getter' 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: dispatch_}) _lns _iso cls

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

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

import Prelude
import React as R
import Redox as Redox
import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, runFn2)
import Data.Lens (Lens', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis, getProps, readState)
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))

foreign import unsafeShallowEqual :: forall a. Fn2 a a Boolean

foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

-- | 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
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    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

    shouldComponentUpdate this nPr nSt = do
      pr <- getProps this
      st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn2 unsafeShallowEqual pr nPr)

    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 = _.redox <$> ctx
      where
        ctx = readContext (Proxy :: Proxy ({ redox :: 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: dispatch_}) _lns _iso cls

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


redundant parens

redundant parens

module Test.Data.Map where

import Prelude
import Data.List.NonEmpty as NEL
import Data.Map as M
import Control.Alt ((<|>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Data.Foldable (foldl, for_, all)
import Data.Function (on)
import Data.List (List(Cons), groupBy, length, nubBy, singleton, sort, sortBy)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Test.QuickCheck ((<?>), (===), quickCheck, quickCheck')
import Test.QuickCheck.Gen (elements, oneOf)
import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary)

newtype TestMap k v = TestMap (M.Map k v)

instance arbTestMap :: (Eq k, Ord k, Arbitrary k, Arbitrary v) => Arbitrary (TestMap k v) where
  arbitrary = TestMap <<< (M.fromFoldable :: List (Tuple k v) -> M.Map k v) <$> arbitrary

data SmallKey = A | B | C | D | E | F | G | H | I | J
derive instance eqSmallKey :: Eq SmallKey
derive instance ordSmallKey :: Ord SmallKey

instance showSmallKey :: Show SmallKey where
  show A = "A"
  show B = "B"
  show C = "C"
  show D = "D"
  show E = "E"
  show F = "F"
  show G = "G"
  show H = "H"
  show I = "I"
  show J = "J"

instance arbSmallKey :: Arbitrary SmallKey where
  arbitrary = elements A [B, C, D, E, F, G, H, I, J]

data Instruction k v = Insert k v | Delete k

instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where
  show (Insert k v) = "Insert (" <> show k <> ") (" <> show v <> ")"
  show (Delete k) = "Delete (" <> show k <> ")"

instance arbInstruction :: (Arbitrary k, Arbitrary v) => Arbitrary (Instruction k v) where
  arbitrary = oneOf (Insert <$> arbitrary <*> arbitrary) [Delete <$> arbitrary]

runInstructions :: forall k v. Ord k => List (Instruction k v) -> M.Map k v -> M.Map k v
runInstructions instrs t0 = foldl step t0 instrs
  where
  step tree (Insert k v) = M.insert k v tree
  step tree (Delete k) = M.delete k tree

smallKey :: SmallKey -> SmallKey
smallKey k = k

number :: Int -> Int
number n = n

smallKeyToNumberMap :: M.Map SmallKey Int -> M.Map SmallKey Int
smallKeyToNumberMap m = m

mapTests :: forall eff. Eff (console :: CONSOLE, random :: RANDOM, exception :: EXCEPTION | eff) Unit
mapTests = do

  -- Data.Map

  log "Test inserting into empty tree"
  quickCheck $ \k v -> M.lookup (smallKey k) (M.insert k v M.empty) == Just (number v)
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Test inserting two values with same key"
  quickCheck $ \k v1 v2 ->
    M.lookup (smallKey k) (M.insert k v2 (M.insert k v1 M.empty)) == Just (number v2)

  log "Test delete after inserting"
  quickCheck $ \k v -> M.isEmpty (M.delete (smallKey k) (M.insert k (number v) M.empty))
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Test pop after inserting"
  quickCheck $ \k v -> M.pop (smallKey k) (M.insert k (number v) M.empty) == Just (Tuple v M.empty)
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Pop non-existent key"
  quickCheck $ \k1 k2 v -> k1 == k2 || M.pop (smallKey k2) (M.insert k1 (number v) M.empty) == Nothing
    <?> ("k1: " <> show k1 <> ", k2: " <> show k2 <> ", v: " <> show v)

  log "Insert two, lookup first"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v1
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, lookup second"
  quickCheck $ \k1 v1 k2 v2 -> M.lookup k2 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, delete one"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k2 (M.delete k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty))) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Check balance property"
  quickCheck' 1000 $ \instrs ->
    let
      tree :: M.Map SmallKey Int
      tree = runInstructions instrs M.empty
    in M.checkValid tree <?> ("Map not balanced:\n  " <> show tree <> "\nGenerated by:\n  " <> show instrs)

  log "Lookup from empty"
  quickCheck $ \k -> M.lookup k (M.empty :: M.Map SmallKey Int) == Nothing

  log "Lookup from singleton"
  quickCheck $ \k v -> M.lookup (k :: SmallKey) (M.singleton k (v :: Int)) == Just v

  log "Random lookup"
  quickCheck' 1000 $ \instrs k v ->
    let
      tree :: M.Map SmallKey Int
      tree = M.insert k v (runInstructions instrs M.empty)
    in M.lookup k tree == Just v <?> ("instrs:\n  " <> show instrs <> "\nk:\n  " <> show k <> "\nv:\n  " <> show v)

  log "Singleton to list"
  quickCheck $ \k v -> M.toUnfoldable (M.singleton k v :: M.Map SmallKey Int) == singleton (Tuple k v)

  log "fromFoldable [] = empty"
  quickCheck (M.fromFoldable [] == (M.empty :: M.Map Unit Unit)
    <?> "was not empty")

  log "fromFoldable & key collision"
  do
    let nums = M.fromFoldable [Tuple 0 "zero", Tuple 1 "what", Tuple 1 "one"]
    quickCheck (M.lookup 0 nums == Just "zero" <?> "invalid lookup - 0")
    quickCheck (M.lookup 1 nums == Just "one"  <?> "invalid lookup - 1")
    quickCheck (M.lookup 2 nums == Nothing     <?> "invalid lookup - 2")

  log "fromFoldableWith const [] = empty"
  quickCheck (M.fromFoldableWith const [] == (M.empty :: M.Map Unit Unit)
    <?> "was not empty")

  log "fromFoldableWith (+) & key collision"
  do
    let nums = M.fromFoldableWith (+) [Tuple 0 1, Tuple 1 1, Tuple 1 1]
    quickCheck (M.lookup 0 nums == Just 1  <?> "invalid lookup - 0")
    quickCheck (M.lookup 1 nums == Just 2  <?> "invalid lookup - 1")
    quickCheck (M.lookup 2 nums == Nothing <?> "invalid lookup - 2")

  log "sort . toUnfoldable . fromFoldable = sort (on lists without key-duplicates)"
  quickCheck $ \(list :: List (Tuple SmallKey Int)) ->
    let nubbedList = nubBy ((==) `on` fst) list
        f x = M.toUnfoldable (M.fromFoldable x)
    in sort (f nubbedList) == sort nubbedList <?> show nubbedList

  log "fromFoldable . toUnfoldable = id"
  quickCheck $ \(TestMap (m :: M.Map SmallKey Int)) ->
    let f m' = M.fromFoldable (M.toUnfoldable m' :: List (Tuple SmallKey Int))
    in f m == m <?> show m

  log "fromFoldableWith const = fromFoldable"
  quickCheck $ \arr ->
    M.fromFoldableWith const arr ==
    M.fromFoldable (arr :: List (Tuple SmallKey Int)) <?> show arr

  log "fromFoldableWith (<>) = fromFoldable . collapse with (<>) . group on fst"
  quickCheck $ \arr ->
    let combine (Tuple s a) (Tuple t b) = (Tuple s $ b <> a)
        foldl1 g = unsafePartial \(Cons x xs) -> foldl g x xs
        f = M.fromFoldable <<< map (foldl1 combine <<< NEL.toList) <<<
            groupBy ((==) `on` fst) <<< sortBy (compare `on` fst) in
    M.fromFoldableWith (<>) arr === f (arr :: List (Tuple String String))

  log "toAscUnfoldable is sorted version of toUnfoldable"
  quickCheck $ \(TestMap m) ->
    let list = M.toUnfoldable (m :: M.Map SmallKey Int)
        ascList = M.toAscUnfoldable m
    in ascList === sortBy (compare `on` fst) list

  log "Lookup from union"
  quickCheck $ \(TestMap m1) (TestMap m2) k ->
    M.lookup (smallKey k) (M.union m1 m2) == (case M.lookup k m1 of
      Nothing -> M.lookup k m2
      Just v -> Just (number v)) <?> ("m1: " <> show m1 <> ", m2: " <> show m2 <> ", k: " <> show k <> ", v1: " <> show (M.lookup k m1) <> ", v2: " <> show (M.lookup k m2) <> ", union: " <> show (M.union m1 m2))

  log "Union is idempotent"
  quickCheck $ \(TestMap m1) (TestMap m2) -> (m1 `M.union` m2) == ((m1 `M.union` m2) `M.union` (m2 :: M.Map SmallKey Int))

  log "Union prefers left"
  quickCheck $ \(TestMap m1) (TestMap m2) k -> M.lookup k (M.union m1 (m2 :: M.Map SmallKey Int)) == (M.lookup k m1 <|> M.lookup k m2)

  log "unionWith"
  for_ [Tuple (+) 0, Tuple (*) 1] $ \(Tuple op ident) ->
    quickCheck $ \(TestMap m1) (TestMap m2) k ->
      let u = M.unionWith op m1 m2 :: M.Map SmallKey Int
      in case M.lookup k u of
           Nothing -> not (M.member k m1 || M.member k m2)
           Just v -> v == op (fromMaybe ident (M.lookup k m1)) (fromMaybe ident (M.lookup k m2))

  log "unionWith argument order"
  quickCheck $ \(TestMap m1) (TestMap m2) k ->
    let u   = M.unionWith (-) m1 m2 :: M.Map SmallKey Int
        in1 = M.member k m1
        v1  = M.lookup k m1
        in2 = M.member k m2
        v2  = M.lookup k m2
    in case M.lookup k u of
          Just v | in1 && in2 -> Just v == ((-) <$> v1 <*> v2)
          Just v | in1        -> Just v == v1
          Just v              -> Just v == v2
          Nothing             -> not (in1 || in2)

  log "size"
  quickCheck $ \xs ->
    let xs' = nubBy ((==) `on` fst) xs
    in  M.size (M.fromFoldable xs') == length (xs' :: List (Tuple SmallKey Int))

  log "lookupLE result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupLE k (smallKeyToNumberMap m) of
    Nothing -> all (_ > k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k1 < k2 && k2 < k
      isLTwhenEQexists = k1 < k && M.member k m
      in   k1 <= k
        && all (not <<< isCloserKey) (M.keys m)
        && not isLTwhenEQexists
        && M.lookup k1 m == Just v

  log "lookupGE result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupGE k (smallKeyToNumberMap m) of
    Nothing -> all (_ < k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k < k2 && k2 < k1
      isGTwhenEQexists = k < k1 && M.member k m
      in   k1 >= k
        && all (not <<< isCloserKey) (M.keys m)
        && not isGTwhenEQexists
        && M.lookup k1 m == Just v

  log "lookupLT result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupLT k (smallKeyToNumberMap m) of
    Nothing -> all (_ >= k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k1 < k2 && k2 < k
      in   k1 < k
        && all (not <<< isCloserKey) (M.keys m)
        && M.lookup k1 m == Just v

  log "lookupGT result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupGT k (smallKeyToNumberMap m) of
    Nothing -> all (_ <= k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k < k2 && k2 < k1
      in   k1 > k
        && all (not <<< isCloserKey) (M.keys m)
        && M.lookup k1 m == Just v

  log "findMin result is correct"
  quickCheck $ \(TestMap m) -> case M.findMin (smallKeyToNumberMap m) of
    Nothing -> M.isEmpty m
    Just { key: k, value: v } -> M.lookup k m == Just v && all (_ >= k) (M.keys m)

  log "findMax result is correct"
  quickCheck $ \(TestMap m) -> case M.findMax (smallKeyToNumberMap m) of
    Nothing -> M.isEmpty m
    Just { key: k, value: v } -> M.lookup k m == Just v && all (_ <= k) (M.keys m)

  log "mapWithKey is correct"
  quickCheck $ \(TestMap m :: TestMap String Int) -> let
    f k v = k <> show v
    resultViaMapWithKey = m # M.mapWithKey f
    toList = M.toUnfoldable :: forall k v. M.Map k v -> List (Tuple k v)
    resultViaLists = m # toList # map (\(Tuple k v) → Tuple k (f k v)) # M.fromFoldable
    in resultViaMapWithKey === resultViaLists

module Test.Data.Map where

import Prelude
import Data.List.NonEmpty as NEL
import Data.Map as M
import Control.Alt ((<|>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Data.Foldable (foldl, for_, all)
import Data.Function (on)
import Data.List (List(Cons), groupBy, length, nubBy, singleton, sort, sortBy)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Test.QuickCheck ((<?>), (===), quickCheck, quickCheck')
import Test.QuickCheck.Gen (elements, oneOf)
import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary)

newtype TestMap k v = TestMap (M.Map k v)

instance arbTestMap :: (Eq k, Ord k, Arbitrary k, Arbitrary v) => Arbitrary (TestMap k v) where
  arbitrary = TestMap <<< (M.fromFoldable :: List (Tuple k v) -> M.Map k v) <$> arbitrary

data SmallKey = A | B | C | D | E | F | G | H | I | J
derive instance eqSmallKey :: Eq SmallKey
derive instance ordSmallKey :: Ord SmallKey

instance showSmallKey :: Show SmallKey where
  show A = "A"
  show B = "B"
  show C = "C"
  show D = "D"
  show E = "E"
  show F = "F"
  show G = "G"
  show H = "H"
  show I = "I"
  show J = "J"

instance arbSmallKey :: Arbitrary SmallKey where
  arbitrary = elements A [B, C, D, E, F, G, H, I, J]

data Instruction k v = Insert k v | Delete k

instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where
  show (Insert k v) = "Insert (" <> show k <> ") (" <> show v <> ")"
  show (Delete k) = "Delete (" <> show k <> ")"

instance arbInstruction :: (Arbitrary k, Arbitrary v) => Arbitrary (Instruction k v) where
  arbitrary = oneOf (Insert <$> arbitrary <*> arbitrary) [(Delete <$> arbitrary)]

runInstructions :: forall k v. Ord k => List (Instruction k v) -> M.Map k v -> M.Map k v
runInstructions instrs t0 = foldl step t0 instrs
  where
  step tree (Insert k v) = M.insert k v tree
  step tree (Delete k) = M.delete k tree

smallKey :: SmallKey -> SmallKey
smallKey k = k

number :: Int -> Int
number n = n

smallKeyToNumberMap :: M.Map SmallKey Int -> M.Map SmallKey Int
smallKeyToNumberMap m = m

mapTests :: forall eff. Eff (console :: CONSOLE, random :: RANDOM, exception :: EXCEPTION | eff) Unit
mapTests = do

  -- Data.Map

  log "Test inserting into empty tree"
  quickCheck $ \k v -> M.lookup (smallKey k) (M.insert k v M.empty) == Just (number v)
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Test inserting two values with same key"
  quickCheck $ \k v1 v2 ->
    M.lookup (smallKey k) (M.insert k v2 (M.insert k v1 M.empty)) == Just (number v2)

  log "Test delete after inserting"
  quickCheck $ \k v -> M.isEmpty (M.delete (smallKey k) (M.insert k (number v) M.empty))
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Test pop after inserting"
  quickCheck $ \k v -> M.pop (smallKey k) (M.insert k (number v) M.empty) == Just (Tuple v M.empty)
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Pop non-existent key"
  quickCheck $ \k1 k2 v -> k1 == k2 || M.pop (smallKey k2) (M.insert k1 (number v) M.empty) == Nothing
    <?> ("k1: " <> show k1 <> ", k2: " <> show k2 <> ", v: " <> show v)

  log "Insert two, lookup first"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v1
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, lookup second"
  quickCheck $ \k1 v1 k2 v2 -> M.lookup k2 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, delete one"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k2 (M.delete k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty))) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Check balance property"
  quickCheck' 1000 $ \instrs ->
    let
      tree :: M.Map SmallKey Int
      tree = runInstructions instrs M.empty
    in M.checkValid tree <?> ("Map not balanced:\n  " <> show tree <> "\nGenerated by:\n  " <> show instrs)

  log "Lookup from empty"
  quickCheck $ \k -> M.lookup k (M.empty :: M.Map SmallKey Int) == Nothing

  log "Lookup from singleton"
  quickCheck $ \k v -> M.lookup (k :: SmallKey) (M.singleton k (v :: Int)) == Just v

  log "Random lookup"
  quickCheck' 1000 $ \instrs k v ->
    let
      tree :: M.Map SmallKey Int
      tree = M.insert k v (runInstructions instrs M.empty)
    in M.lookup k tree == Just v <?> ("instrs:\n  " <> show instrs <> "\nk:\n  " <> show k <> "\nv:\n  " <> show v)

  log "Singleton to list"
  quickCheck $ \k v -> M.toUnfoldable (M.singleton k v :: M.Map SmallKey Int) == singleton (Tuple k v)

  log "fromFoldable [] = empty"
  quickCheck (M.fromFoldable [] == (M.empty :: M.Map Unit Unit)
    <?> "was not empty")

  log "fromFoldable & key collision"
  do
    let nums = M.fromFoldable [Tuple 0 "zero", Tuple 1 "what", Tuple 1 "one"]
    quickCheck (M.lookup 0 nums == Just "zero" <?> "invalid lookup - 0")
    quickCheck (M.lookup 1 nums == Just "one"  <?> "invalid lookup - 1")
    quickCheck (M.lookup 2 nums == Nothing     <?> "invalid lookup - 2")

  log "fromFoldableWith const [] = empty"
  quickCheck (M.fromFoldableWith const [] == (M.empty :: M.Map Unit Unit)
    <?> "was not empty")

  log "fromFoldableWith (+) & key collision"
  do
    let nums = M.fromFoldableWith (+) [Tuple 0 1, Tuple 1 1, Tuple 1 1]
    quickCheck (M.lookup 0 nums == Just 1  <?> "invalid lookup - 0")
    quickCheck (M.lookup 1 nums == Just 2  <?> "invalid lookup - 1")
    quickCheck (M.lookup 2 nums == Nothing <?> "invalid lookup - 2")

  log "sort . toUnfoldable . fromFoldable = sort (on lists without key-duplicates)"
  quickCheck $ \(list :: List (Tuple SmallKey Int)) ->
    let nubbedList = nubBy ((==) `on` fst) list
        f x = M.toUnfoldable (M.fromFoldable x)
    in sort (f nubbedList) == sort nubbedList <?> show nubbedList

  log "fromFoldable . toUnfoldable = id"
  quickCheck $ \(TestMap (m :: M.Map SmallKey Int)) ->
    let f m' = M.fromFoldable (M.toUnfoldable m' :: List (Tuple SmallKey Int))
    in f m == m <?> show m

  log "fromFoldableWith const = fromFoldable"
  quickCheck $ \arr ->
    M.fromFoldableWith const arr ==
    M.fromFoldable (arr :: List (Tuple SmallKey Int)) <?> show arr

  log "fromFoldableWith (<>) = fromFoldable . collapse with (<>) . group on fst"
  quickCheck $ \arr ->
    let combine (Tuple s a) (Tuple t b) = (Tuple s $ b <> a)
        foldl1 g = unsafePartial \(Cons x xs) -> foldl g x xs
        f = M.fromFoldable <<< map (foldl1 combine <<< NEL.toList) <<<
            groupBy ((==) `on` fst) <<< sortBy (compare `on` fst) in
    M.fromFoldableWith (<>) arr === f (arr :: List (Tuple String String))

  log "toAscUnfoldable is sorted version of toUnfoldable"
  quickCheck $ \(TestMap m) ->
    let list = M.toUnfoldable (m :: M.Map SmallKey Int)
        ascList = M.toAscUnfoldable m
    in ascList === sortBy (compare `on` fst) list

  log "Lookup from union"
  quickCheck $ \(TestMap m1) (TestMap m2) k ->
    M.lookup (smallKey k) (M.union m1 m2) == (case M.lookup k m1 of
      Nothing -> M.lookup k m2
      Just v -> Just (number v)) <?> ("m1: " <> show m1 <> ", m2: " <> show m2 <> ", k: " <> show k <> ", v1: " <> show (M.lookup k m1) <> ", v2: " <> show (M.lookup k m2) <> ", union: " <> show (M.union m1 m2))

  log "Union is idempotent"
  quickCheck $ \(TestMap m1) (TestMap m2) -> (m1 `M.union` m2) == ((m1 `M.union` m2) `M.union` (m2 :: M.Map SmallKey Int))

  log "Union prefers left"
  quickCheck $ \(TestMap m1) (TestMap m2) k -> M.lookup k (M.union m1 (m2 :: M.Map SmallKey Int)) == (M.lookup k m1 <|> M.lookup k m2)

  log "unionWith"
  for_ [Tuple (+) 0, Tuple (*) 1] $ \(Tuple op ident) ->
    quickCheck $ \(TestMap m1) (TestMap m2) k ->
      let u = M.unionWith op m1 m2 :: M.Map SmallKey Int
      in case M.lookup k u of
           Nothing -> not (M.member k m1 || M.member k m2)
           Just v -> v == op (fromMaybe ident (M.lookup k m1)) (fromMaybe ident (M.lookup k m2))

  log "unionWith argument order"
  quickCheck $ \(TestMap m1) (TestMap m2) k ->
    let u   = M.unionWith (-) m1 m2 :: M.Map SmallKey Int
        in1 = M.member k m1
        v1  = M.lookup k m1
        in2 = M.member k m2
        v2  = M.lookup k m2
    in case M.lookup k u of
          Just v | in1 && in2 -> Just v == ((-) <$> v1 <*> v2)
          Just v | in1        -> Just v == v1
          Just v              -> Just v == v2
          Nothing             -> not (in1 || in2)

  log "size"
  quickCheck $ \xs ->
    let xs' = nubBy ((==) `on` fst) xs
    in  M.size (M.fromFoldable xs') == length (xs' :: List (Tuple SmallKey Int))

  log "lookupLE result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupLE k (smallKeyToNumberMap m) of
    Nothing -> all (_ > k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k1 < k2 && k2 < k
      isLTwhenEQexists = k1 < k && M.member k m
      in   k1 <= k
        && all (not <<< isCloserKey) (M.keys m)
        && not isLTwhenEQexists
        && M.lookup k1 m == Just v

  log "lookupGE result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupGE k (smallKeyToNumberMap m) of
    Nothing -> all (_ < k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k < k2 && k2 < k1
      isGTwhenEQexists = k < k1 && M.member k m
      in   k1 >= k
        && all (not <<< isCloserKey) (M.keys m)
        && not isGTwhenEQexists
        && M.lookup k1 m == Just v

  log "lookupLT result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupLT k (smallKeyToNumberMap m) of
    Nothing -> all (_ >= k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k1 < k2 && k2 < k
      in   k1 < k
        && all (not <<< isCloserKey) (M.keys m)
        && M.lookup k1 m == Just v

  log "lookupGT result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupGT k (smallKeyToNumberMap m) of
    Nothing -> all (_ <= k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k < k2 && k2 < k1
      in   k1 > k
        && all (not <<< isCloserKey) (M.keys m)
        && M.lookup k1 m == Just v

  log "findMin result is correct"
  quickCheck $ \(TestMap m) -> case M.findMin (smallKeyToNumberMap m) of
    Nothing -> M.isEmpty m
    Just { key: k, value: v } -> M.lookup k m == Just v && all (_ >= k) (M.keys m)

  log "findMax result is correct"
  quickCheck $ \(TestMap m) -> case M.findMax (smallKeyToNumberMap m) of
    Nothing -> M.isEmpty m
    Just { key: k, value: v } -> M.lookup k m == Just v && all (_ <= k) (M.keys m)

  log "mapWithKey is correct"
  quickCheck $ \(TestMap m :: TestMap String Int) -> let
    f k v = k <> show v
    resultViaMapWithKey = m # M.mapWithKey f
    toList = M.toUnfoldable :: forall k v. M.Map k v -> List (Tuple k v)
    resultViaLists = m # toList # map (\(Tuple k v) → Tuple k (f k v)) # M.fromFoldable
    in resultViaMapWithKey === resultViaLists


remove JSON

remove JSON

module Data.DOM.Simple.JSON where

import Control.Monad.Eff
import Data.Dom.Simple.Element

foreign import data JSONObject :: *

foreign import stringify
  "function stringify(obj) {        \
  \  return function () {           \
  \    return JSON.stringify(obj);  \
  \  };                             \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) String)

foreign import parse
  "function parse(str) { \
  \  return function () {      \
  \    return JSON.parse(str); \
  \  };                        \
  \}" :: forall eff. String -> (Eff (dom :: DOM | eff) JSONObject)