Added bit-level operations

Added bit-level operations

module Ops where

import Prelude
import Data.Int.Bits

import Types
import MainMem

--NOTE: consider moving the timings to 2D arrays.
--separate from the opcode's logic

-- Additions
-- =========

--ADD A,R
addRegToA :: GetReg -> Regs -> Regs
addRegToA getReg regs = addXToA (getReg regs) regs

--ADD A,(HL)
addHLMemToA :: Mem -> Regs
addHLMemToA { mainMem, regs } = (addXToA hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--ADD A,n
addImmToA :: Mem -> Regs
addImmToA { mainMem, regs } =
  (addXToA imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

addXToA :: I8 -> Regs -> Regs
addXToA x regs =
  regs {a = sum.res, f = sum.flags, m = 1}
 where sum = addI8s regs.a x

--ADC A,R
addRegCarryToA :: GetReg -> Regs -> Regs
addRegCarryToA getReg regs = addXCarryToA (getReg regs) regs

--ADC A,(HL)
addHLMemCarryToA :: Mem -> Regs
addHLMemCarryToA { mainMem, regs } = (addXCarryToA hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--ADC A,n
addImmCarryToA :: Mem -> Regs
addImmCarryToA { mainMem, regs } =
  (addXCarryToA imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

--NOTE: Test edge case of carry flag of 1 that causes a half-carry,
--Is the half-carry flag set correctly?
addXCarryToA :: I8 -> Regs -> Regs
addXCarryToA x regs =
  regs {a = sum.res, f = f', m = 1}
 where
  --Overriding addI8's half-carry flag because it used regs.a+carry
  --Which is essential for the other flags, but not for this one.
  f' = setHalfCarryFlag x regs.a sum.res sum.flags
  sum = addI8s (regs.a + carry) x
  carry = if regs.f .&. carryFlag /= 0 then 1 else 0

--ADD SP,|n|
addImmToSP :: Mem -> Regs
addImmToSP { regs, mainMem } =
  regs {sp = sp', pc = regs.pc + 1, m = 4}
 where
  sp' = (absI8 imm + regs.sp) .&. 0xFFFF
  imm = rd8 regs.pc mainMem

addI8s :: I8 -> I8 -> { res :: I8, flags :: I8 }
addI8s x1 x2 = { res , flags }
 where
  flags =  testZeroFlag res
       .|. testCarryFlag8 sum
       .|. testHalfCarryFlag x1 x2 res
  res = sum .&. 255
  sum = x1 + x2

--ADD HL,RR
add2RegsToHL :: GetReg -> GetReg -> Regs -> Regs
add2RegsToHL msByteReg lsByteReg regs =
  regs { h = split.ms, l = split.ls, f = sum.flags, m = 3 }
 where
  split = splitI16 sum.res
  sum = addI16s hl joinedRegs regs.f
  joinedRegs = joinRegs msByteReg lsByteReg regs
  hl = joinRegs h l regs

--ADD HL,SP
addSPToHL :: Regs -> Regs
addSPToHL regs =
  regs { h = split.ms, l = split.ls, f = sum.flags, m = 3 }
 where
  split = splitI16 sum.res
  sum = addI16s hl regs.sp regs.f
  hl = joinRegs h l regs

addI16s :: I8 -> I16 -> I16 -> { res :: I16, flags :: I8 }
addI16s oldFlags x1 x2 = { res, flags }
 where
  flags =  setCarryFlag16 sum
        $  oldFlags
       .|. testZeroFlag res
  res = sum .&. 0xFFFF
  sum = x1 + x2

-- Subtractions
-- ============

--SUB A,R
subRegFromA :: GetReg -> Regs -> Regs
subRegFromA getReg regs = subXFromA (getReg regs) regs

--SUB A,(HL)
subHLMemFromA :: Mem -> Regs
subHLMemFromA { mainMem, regs } = (subXFromA hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--SUB A,n
subImmFromA :: Mem -> Regs
subImmFromA { mainMem, regs } = (subXFromA imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

--NOTE: Subtractions and additions are relatively similar. Consider
--Using same functions for both, if it doesn't obfuscate much.
subXFromA :: I8 -> Regs -> Regs
subXFromA x regs =
  regs {a = diff.res, f = diff.flags, m = 1}
 where diff = subI8s regs.a x

--SBC A,R
subRegCarryFromA :: GetReg -> Regs -> Regs
subRegCarryFromA getReg regs = subXCarryFromA (getReg regs) regs

--SBC A,(HL)
subHLMemCarryFromA :: Mem -> Regs
subHLMemCarryFromA { mainMem, regs } = (subXCarryFromA hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--SBC A,n
subImmCarryToA :: Mem -> Regs
subImmCarryToA { mainMem, regs } = (subXCarryFromA imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

--NOTE: Test edge case of carry flag of 1 that causes a half-carry,
--Is the half-carry flag set correctly?
subXCarryFromA :: I8 -> Regs -> Regs
subXCarryFromA x regs =
  regs {a = diff.res, f = f', m = 1}
 where
  f' = setHalfCarryFlag x regs.a diff.res diff.flags
  diff = subI8s (regs.a - carry) x
  carry = if regs.f .&. carryFlag /= 0 then 1 else 0

subI8s :: I8 -> I8 -> { res :: I8, flags :: I8 }
subI8s x1 x2 = { res , flags }
 where
  flags =  testZeroFlag res
       .|. testNegCarryFlag diff
       .|. subtractionFlag
       .|. testHalfCarryFlag x1 x2 res
  res = diff .&. 255
  diff = x1 - x2

-- Boolean operations
-- ==================

--AND A,R
andOpRegIntoA :: GetReg -> Regs -> Regs
andOpRegIntoA = boolOpRegIntoA (.&.)

--OR A,R
orOpRegIntoA :: GetReg -> Regs -> Regs
orOpRegIntoA = boolOpRegIntoA (.|.)

--XOR A,R
xorOpRegIntoA :: GetReg -> Regs -> Regs
xorOpRegIntoA = boolOpRegIntoA (.^.)

boolOpRegIntoA :: (I8 -> I8 -> I8) -> GetReg -> Regs -> Regs
boolOpRegIntoA op getReg regs = boolOpXIntoA op (getReg regs) regs

--AND A,(HL)
andOpHLMemIntoA :: Mem -> Regs
andOpHLMemIntoA = boolOpHlMemIntoA (.&.)

--OR A,(HL)
orOpHLMemIntoA :: Mem -> Regs
orOpHLMemIntoA = boolOpHlMemIntoA (.|.)

--XOR A,(HL)
xorOpHLMemIntoA :: Mem -> Regs
xorOpHLMemIntoA = boolOpHlMemIntoA (.^.)

boolOpHlMemIntoA  :: (I8 -> I8 -> I8) -> Mem -> Regs
boolOpHlMemIntoA op { mainMem, regs } =
  (boolOpXIntoA op hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--AND A,Imm
andOpImmIntoA :: Mem -> Regs
andOpImmIntoA  = boolOpImmIntoA (.&.)

--OR A,Imm
orOpImmIntoA :: Mem -> Regs
orOpImmIntoA = boolOpImmIntoA (.|.)

--XOR A,Imm
xorOpImmIntoA :: Mem -> Regs
xorOpImmIntoA = boolOpImmIntoA (.^.)

boolOpImmIntoA :: (I8 -> I8 -> I8) -> Mem -> Regs
boolOpImmIntoA op { mainMem, regs } =
  (boolOpXIntoA op imm regs) {pc = regs.pc + 1, m = 2}
 where imm = rd8 regs.pc mainMem

boolOpXIntoA :: (I8 -> I8 -> I8) -> I8 -> Regs -> Regs
boolOpXIntoA op x regs =
  regs { a = a', f = testZeroFlag a', m = 1 }
 where a' = (regs.a `op` x) .&. 255

-- Bit operations
-- ==============

--CPL
cmplA :: Regs -> Regs
cmplA regs = regs { a = a', f = testZeroFlag a' ,m = 1 }
 where a' = 255 .^. regs.a

--BIT N,R
testBitNOfReg :: I8 -> GetReg -> Regs -> Regs
testBitNOfReg n getReg regs = testBitNOfX n (getReg regs) regs

--BIT N,(HL)
testBitNOfHLMem :: I8 -> GetReg -> Mem -> Regs
testBitNOfHLMem n getReg { mainMem, regs } =
  (testBitNOfX n hlMem regs) { m = 3 }
 where
  hlMem = rd8 (joinRegs h l regs) mainMem

testBitNOfX :: Int -> I8 -> Regs -> Regs
testBitNOfX n x regs = regs { f = f', m = 2 }
 where
  f' =  setZeroFlag bitTest
     $  halfCarryFlag
    .|. (regs.f .&. carryFlag) -- NOTE: should it be 0x1F instead?
  bitTest = x .&. (1 `shl` n)

--SET N,R
set1BitNOfReg :: Int -> GetReg -> SetReg
               -> Regs -> Regs
set1BitNOfReg = setBitNOfReg true

--RES N,R
set0BitNOfReg :: Int -> GetReg -> SetReg
               -> Regs -> Regs
set0BitNOfReg = setBitNOfReg false

setBitNOfReg :: Boolean -> Int -> GetReg -> SetReg
               -> Regs -> Regs
setBitNOfReg setVal n getReg setReg regs = setReg reg' regs { m = 2 }
 where reg' = setBitNOfX setVal n (getReg regs)

--SET N,(HL)
set1BitNOfHLMem :: Int -> Mem -> Mem
set1BitNOfHLMem = setBitNOfHLMem true

--RES N,(HL)
set0BitNOfHLMem :: Int -> Mem -> Mem
set0BitNOfHLMem = setBitNOfHLMem false

setBitNOfHLMem :: Boolean -> Int -> Mem -> Mem
setBitNOfHLMem setVal n mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs { m = 4 } }
 where
  mainMem' = wr8 hl' addr mainMem
  hl' = setBitNOfX setVal n $ rd8 addr mainMem
  addr = joinRegs h l regs

setBitNOfX :: Boolean -> Int -> I8 -> I8
setBitNOfX setVal n x = if setVal
  then x .|. bitShift
  else x .&. complement bitShift
 where bitShift = 1 `shl` n

-- Helpers
-- =======

saveRegs :: Regs -> SavedRegs -> SavedRegs
saveRegs regs svdRegs =
  svdRegs { a = regs.a, b = regs.b, c = regs.c, d = regs.d
          , e = regs.e, f = regs.f, h = regs.h, l = regs.l
          }

restoreRegs :: SavedRegs -> Regs -> Regs
restoreRegs svdRegs regs =
  regs { a = svdRegs.a, b = svdRegs.b, c = svdRegs.c, d = svdRegs.d
       , e = svdRegs.e, f = svdRegs.f, h = svdRegs.h, l = svdRegs.l
       }

joinRegs :: (Regs -> I8) -> (Regs -> I8) -> Regs -> I16
joinRegs msByteReg lsByteReg regs = (msByteReg regs `shl` 8) + lsByteReg regs

absI8 :: I8 -> I8
absI8 i8 = if i8 > 127 then negI8 i8 else i8

negI8 :: I8 -> I8
negI8 i8 = (complement i8 + 1) .&. 255

splitI16 :: I16 -> { ms :: I8, ls :: I8 }
splitI16 x = { ms : (x `zshr` 8) .&. 255
             , ls : x .&. 255
             }

isSetFlag :: I8 -> I8 -> Boolean
isSetFlag f fs = f .&. fs /= 0

setFlag :: I8 -> I8 -> I8
setFlag  f = (f .|. _)

unsetFlag :: I8 -> I8 -> I8
unsetFlag f = ((complement f) .&. _)

flipFlag :: I8 -> I8 -> I8
flipFlag f = (f .^. _)

testZeroFlag :: Int -> Int
testZeroFlag x = if x == 0 then 0x80 else 0

setZeroFlag :: Int -> I8 -> I8
setZeroFlag x = if x == 0
  then (_ .|. zeroFlag)
  else (_ .&. cmplZeroFlag)

testCarryFlag8 :: Int -> I8
testCarryFlag8 x = if x > 255 then carryFlag else 0

setCarryFlag16 :: Int -> I8 -> I8
setCarryFlag16 x = if x > 0xFFFF
  then (_ .|. carryFlag)
  else (_ .&. cmplCarryFlag)

testNegCarryFlag :: Int -> I8
testNegCarryFlag reg = if reg < 0 then carryFlag else 0

testHalfCarryFlag :: I8 -> I8 -> I8 -> I8
testHalfCarryFlag reg1 reg2 sum = if res /= 0 then halfCarryFlag else 0
 where res = 0x10 .&. (reg1 .^. reg2 .^. sum)

setHalfCarryFlag :: I8 -> I8 -> I8 -> I8 -> I8
setHalfCarryFlag reg1 reg2 sum =
  if res /= 0 then (_ .|. halfCarryFlag) else (_ .&. cmplHalfCarryFlag)
 where res = 0x10 .&. (reg1 .^. reg2 .^. sum)

xor :: Boolean -> Boolean -> Boolean
xor true x = not x
xor false x = x

zeroFlag :: I8
zeroFlag = 0x80
cmplZeroFlag :: I8
cmplZeroFlag = 0x7F
carryFlag :: I8
carryFlag = 0x10
cmplCarryFlag :: I8
cmplCarryFlag = 0xEF
halfCarryFlag :: I8
halfCarryFlag = 0x20
cmplHalfCarryFlag :: I8
cmplHalfCarryFlag = 0xD0
subtractionFlag :: I8
subtractionFlag = 0x40

type GetReg = Regs -> I8
type SetReg = I8 -> Regs -> Regs

module Ops where

import Prelude
import Data.Int.Bits

import Types
import MainMem

--NOTE: consider moving the timings to 2D arrays.
--separate from the opcode's logic

-- Additions
-- =========

--ADD A,R
addRegToA :: GetReg -> Regs -> Regs
addRegToA getReg regs = addXToA (getReg regs) regs

--ADD A,(HL)
addHLMemToA :: Mem -> Regs
addHLMemToA { mainMem, regs } = (addXToA hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--ADD A,n
addImmToA :: Mem -> Regs
addImmToA { mainMem, regs } =
  (addXToA imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

addXToA :: I8 -> Regs -> Regs
addXToA x regs =
  regs {a = sum.res, f = sum.flags, m = 1}
 where sum = addI8s regs.a x

--ADC A,R
addRegCarryToA :: GetReg -> Regs -> Regs
addRegCarryToA getReg regs = addXCarryToA (getReg regs) regs

--ADC A,(HL)
addHLMemCarryToA :: Mem -> Regs
addHLMemCarryToA { mainMem, regs } = (addXCarryToA hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--ADC A,n
addImmCarryToA :: Mem -> Regs
addImmCarryToA { mainMem, regs } =
  (addXCarryToA imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

--NOTE: Test edge case of carry flag of 1 that causes a half-carry,
--Is the half-carry flag set correctly?
addXCarryToA :: I8 -> Regs -> Regs
addXCarryToA x regs =
  regs {a = sum.res, f = f', m = 1}
 where
  --Overriding addI8's half-carry flag because it used regs.a+carry
  --Which is essential for the other flags, but not for this one.
  f' = setHalfCarryFlag x regs.a sum.res sum.flags
  sum = addI8s (regs.a + carry) x
  carry = if regs.f .&. carryFlag /= 0 then 1 else 0

--ADD SP,|n|
addImmToSP :: Mem -> Regs
addImmToSP { regs, mainMem } =
  regs {sp = sp', pc = regs.pc + 1, m = 4}
 where
  sp' = (absI8 imm + regs.sp) .&. 0xFFFF
  imm = rd8 regs.pc mainMem

addI8s :: I8 -> I8 -> { res :: I8, flags :: I8 }
addI8s x1 x2 = { res , flags }
 where
  flags =  testZeroFlag res
       .|. testCarryFlag8 sum
       .|. testHalfCarryFlag x1 x2 res
  res = sum .&. 255
  sum = x1 + x2

--ADD HL,RR
add2RegsToHL :: GetReg -> GetReg -> Regs -> Regs
add2RegsToHL getReg1 getReg2 regs =
  regs { h = split.ms, l = split.ls, f = sum.flags, m = 3 }
 where
  split = splitI16 sum.res
  sum = addI16s hl joinedRegs regs.f
  joinedRegs = joinRegs getReg1 getReg2 regs
  hl = joinRegs h l regs

--ADD HL,SP
addSPToHL :: Regs -> Regs
addSPToHL regs =
  regs { h = split.ms, l = split.ls, f = sum.flags, m = 3 }
 where
  split = splitI16 sum.res
  sum = addI16s hl regs.sp regs.f
  hl = joinRegs h l regs

addI16s :: I8 -> I16 -> I16 -> { res :: I16, flags :: I8 }
addI16s oldFlags x1 x2 = { res, flags }
 where
  flags =  setCarryFlag16 sum
        $  oldFlags
       .|. testZeroFlag res
  res = sum .&. 0xFFFF
  sum = x1 + x2

-- Subtractions
-- ============

--SUB A,R
subRegFromA :: GetReg -> Regs -> Regs
subRegFromA getReg regs = subXFromA (getReg regs) regs

--SUB A,(HL)
subHLMemFromA :: Mem -> Regs
subHLMemFromA { mainMem, regs } = (subXFromA hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--SUB A,n
subImmFromA :: Mem -> Regs
subImmFromA { mainMem, regs } = (subXFromA imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

--NOTE: Subtractions and additions are relatively similar. Consider
--Using same functions for both, if it doesn't obfuscate much.
subXFromA :: I8 -> Regs -> Regs
subXFromA x regs =
  regs {a = diff.res, f = diff.flags, m = 1}
 where diff = subI8s regs.a x

--SBC A,R
subRegCarryFromA :: GetReg -> Regs -> Regs
subRegCarryFromA getReg regs = subXCarryFromA (getReg regs) regs

--SBC A,(HL)
subHLMemCarryFromA :: Mem -> Regs
subHLMemCarryFromA { mainMem, regs } = (subXCarryFromA hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--SBC A,n
subImmCarryToA :: Mem -> Regs
subImmCarryToA { mainMem, regs } = (subXCarryFromA imm regs) { pc = regs.pc + 1, m = 2 }
 where imm = rd8 regs.pc mainMem

--NOTE: Test edge case of carry flag of 1 that causes a half-carry,
--Is the half-carry flag set correctly?
subXCarryFromA :: I8 -> Regs -> Regs
subXCarryFromA x regs =
  regs {a = diff.res, f = f', m = 1}
 where
  f' = setHalfCarryFlag x regs.a diff.res diff.flags
  diff = subI8s (regs.a - carry) x
  carry = if regs.f .&. carryFlag /= 0 then 1 else 0

subI8s :: I8 -> I8 -> { res :: I8, flags :: I8 }
subI8s x1 x2 = { res , flags }
 where
  flags =  testZeroFlag res
       .|. testNegCarryFlag diff
       .|. subtractionFlag
       .|. testHalfCarryFlag x1 x2 res
  res = diff .&. 255
  diff = x1 - x2

-- Boolean operations
-- ==================

--AND A,R
andOpRegIntoA :: GetReg -> Regs -> Regs
andOpRegIntoA = boolOpRegIntoA (.&.)

--OR A,R
orOpRegIntoA :: GetReg -> Regs -> Regs
orOpRegIntoA = boolOpRegIntoA (.|.)

--XOR A,R
xorOpRegIntoA :: GetReg -> Regs -> Regs
xorOpRegIntoA = boolOpRegIntoA (.^.)

boolOpRegIntoA :: (I8 -> I8 -> I8) -> GetReg -> Regs -> Regs
boolOpRegIntoA op getReg regs = boolOpXIntoA op (getReg regs) regs

--AND A,(HL)
andOpHLMemIntoA :: Mem -> Regs
andOpHLMemIntoA = boolOpHlMemIntoA (.&.)

--OR A,(HL)
orOpHLMemIntoA :: Mem -> Regs
orOpHLMemIntoA = boolOpHlMemIntoA (.|.)

--XOR A,(HL)
xorOpHLMemIntoA :: Mem -> Regs
xorOpHLMemIntoA = boolOpHlMemIntoA (.^.)

boolOpHlMemIntoA  :: (I8 -> I8 -> I8) -> Mem -> Regs
boolOpHlMemIntoA op { mainMem, regs } =
  (boolOpXIntoA op hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

--AND A,Imm
andOpImmIntoA :: Mem -> Regs
andOpImmIntoA  = boolOpImmIntoA (.&.)

--OR A,Imm
orOpImmIntoA :: Mem -> Regs
orOpImmIntoA = boolOpImmIntoA (.|.)

--XOR A,Imm
xorOpImmIntoA :: Mem -> Regs
xorOpImmIntoA = boolOpImmIntoA (.^.)

boolOpImmIntoA :: (I8 -> I8 -> I8) -> Mem -> Regs
boolOpImmIntoA op { mainMem, regs } =
  (boolOpXIntoA op imm regs) {pc = regs.pc + 1, m = 2}
 where imm = rd8 regs.pc mainMem

boolOpXIntoA :: (I8 -> I8 -> I8) -> I8 -> Regs -> Regs
boolOpXIntoA op x regs =
  regs { a = a', f = testZeroFlag a', m = 1 }
 where a' = (regs.a `op` x) .&. 255

-- Helpers
-- =======

saveRegs :: Regs -> SavedRegs -> SavedRegs
saveRegs regs svdRegs =
  svdRegs { a = regs.a, b = regs.b, c = regs.c, d = regs.d
          , e = regs.e, f = regs.f, h = regs.h, l = regs.l
          }

restoreRegs :: SavedRegs -> Regs -> Regs
restoreRegs svdRegs regs =
  regs { a = svdRegs.a, b = svdRegs.b, c = svdRegs.c, d = svdRegs.d
       , e = svdRegs.e, f = svdRegs.f, h = svdRegs.h, l = svdRegs.l
       }

joinRegs :: (Regs -> I8) -> (Regs -> I8) -> Regs -> I16
joinRegs msByteReg lsByteReg regs = (msByteReg regs `shl` 8) + lsByteReg regs

absI8 :: I8 -> I8
absI8 i8 = if i8 > 127 then negI8 i8 else i8

negI8 :: I8 -> I8
negI8 i8 = (complement i8 + 1) .&. 255

splitI16 :: I16 -> { ms :: I8, ls :: I8 }
splitI16 x = { ms : (x `zshr` 8) .&. 255
             , ls : x .&. 255
             }

isSetFlag :: I8 -> I8 -> Boolean
isSetFlag f fs = f .&. fs /= 0

setFlag :: I8 -> I8 -> I8
setFlag  f = (f .|. _)

unsetFlag :: I8 -> I8 -> I8
unsetFlag f = ((complement f) .&. _)

flipFlag :: I8 -> I8 -> I8
flipFlag f = (f .^. _)

testZeroFlag :: Int -> Int
testZeroFlag x = if x == 0 then 0x80 else 0

setZeroFlag :: Int -> I8 -> I8
setZeroFlag x = if x == 0
  then (_ .|. zeroFlag)
  else (_ .&. cmplZeroFlag)

testCarryFlag8 :: Int -> I8
testCarryFlag8 x = if x > 255 then carryFlag else 0

setCarryFlag16 :: Int -> I8 -> I8
setCarryFlag16 x = if x > 0xFFFF
  then (_ .|. carryFlag)
  else (_ .&. cmplCarryFlag)

testNegCarryFlag :: Int -> I8
testNegCarryFlag reg = if reg < 0 then carryFlag else 0

testHalfCarryFlag :: I8 -> I8 -> I8 -> I8
testHalfCarryFlag reg1 reg2 sum = if res /= 0 then halfCarryFlag else 0
 where res = 0x10 .&. (reg1 .^. reg2 .^. sum)

setHalfCarryFlag :: I8 -> I8 -> I8 -> I8 -> I8
setHalfCarryFlag reg1 reg2 sum =
  if res /= 0 then (_ .|. halfCarryFlag) else (_ .&. cmplHalfCarryFlag)
 where res = 0x10 .&. (reg1 .^. reg2 .^. sum)

xor :: Boolean -> Boolean -> Boolean
xor true x = not x
xor false x = x

zeroFlag :: I8
zeroFlag = 0x80
cmplZeroFlag :: I8
cmplZeroFlag = 0x7F
carryFlag :: I8
carryFlag = 0x10
cmplCarryFlag :: I8
cmplCarryFlag = 0xEF
halfCarryFlag :: I8
halfCarryFlag = 0x20
cmplHalfCarryFlag :: I8
cmplHalfCarryFlag = 0xD0
subtractionFlag :: I8
subtractionFlag = 0x40

type GetReg = Regs -> I8
type SetReg = I8 -> Regs -> Regs


available expedition list

available expedition list

module KanColle.Expedition
  ( Fleet(..)
  , FleetRequirement(..)
  , RawShip(..)
  , Ship(..)
  , ShipRequirement(..)
  , checkExpedition
  , validExpeditionId
  , unsatisfiedRequirements
  , explainRequirements
  , getAvailableExpeditions
  , fromRawShip
  , fromRawFleet
  ) where

import Prelude
import Data.Array
import Data.Foldable
import Data.Maybe
import Data.Monoid
import qualified Data.String as Str

import KanColle.SType

data ShipRequirement
  = ShipLevel Int
  | ShipTypeOneOf (Array SType)
  | ShipDrum Int

data FleetRequirement
  = Flagship ShipRequirement
  | FleetLevel Int
  | FleetDrum Int
  | FleetShipWithDrum Int
  | FleetSTypeCount Int (Array SType)
  | FleetShipCount Int

type ExpeditionRequirement = Array FleetRequirement

explainShipRequirement :: ShipRequirement -> String
explainShipRequirement v = case v of
    ShipLevel lvl -> "ship level should be at least " <> show lvl
    ShipTypeOneOf stypes ->
      "ship should have one of the following type: " <> Str.joinWith "," (map showSType stypes)
    ShipDrum n -> "ship should have at least " <> show n <> " drum(s)"

explainFleetRequirement :: FleetRequirement -> String
explainFleetRequirement v = case v of
    Flagship fs -> "flagship: " <> explainShipRequirement fs
    FleetLevel lvl -> "fleet level sum should be at least " <> show lvl
    FleetDrum drum -> "fleet should have at least " <> show drum <> " drum(s)"
    FleetShipWithDrum n -> "at least " <> show n <> " ship(s) should have drum(s)"
    FleetSTypeCount n stypes -> "require at least "
      <> show n <> " ship(s) of the following type: " <> Str.joinWith "," (map showSType stypes)
    FleetShipCount n -> "fleet should have at least " <> show n <> " ship(s)"

type Ship a =
  { ammo :: Int
  , morale :: Int
  , stype :: SType
  , level :: Int
  , drumCount :: Int
  | a}

type RawShip a =
  { ammo :: Int
  , morale :: Int
  , stype :: String
  , level :: Int
  , drumCount :: Int
  | a}

type Fleet a = Array (Ship a)

fromRawShip :: forall a. RawShip a -> Ship a
fromRawShip s = s {stype = readSType s.stype}

fromRawFleet :: forall a. Array (RawShip a) -> Fleet a
fromRawFleet = map fromRawShip

checkShip :: forall a. ShipRequirement -> Ship a -> Boolean
checkShip req s = case req of
  ShipLevel n -> s.level >= n
  ShipTypeOneOf stype -> any ((==) s.stype) stype
  ShipDrum n -> s.drumCount >= n

checkFleet :: forall a. FleetRequirement -> Fleet a -> Boolean
checkFleet req fleet = case uncons fleet of
    Just { head: hd, tail: tl } -> case req of
        Flagship req -> checkShip req hd
        FleetLevel n -> sum (map (\x -> x.level) fleet) >= n
        FleetDrum n -> sum (map (\x -> x.drumCount) fleet) >= n
        FleetShipWithDrum n -> count (\x -> x.drumCount > 0) fleet >= n
        FleetSTypeCount n stypes -> count (checkShip (ShipTypeOneOf stypes)) fleet >= n
        FleetShipCount n -> length fleet >= n
    Nothing -> false
  where
    count pred = length <<< filter pred

getExpeditionRequirement :: Int -> ExpeditionRequirement
getExpeditionRequirement v = case v of
    1 -> fslAndSc 1 2
    2 -> fslAndSc 2 4
    3 -> fslAndSc 3 3
    4 -> fslAndSc 3 3 <> sty 1 CL <> sty 2 DD
    5 -> fslAndSc 3 4 <> sty 1 CL <> sty 2 DD
    6 -> fslAndSc 4 4
    7 -> fslAndSc 5 6
    8 -> fslAndSc 6 6

    9 -> fslAndSc 3 4 <> sty 1 CL <> sty 2 DD
    10 -> fslAndSc 3 3 <> sty 2 CL
    11 -> fslAndSc 6 4 <> sty 2 DD
    12 -> fslAndSc 4 4 <> sty 2 DD
    13 -> fslAndSc 5 6 <> sty 1 CL <> sty 4 DD
    14 -> fslAndSc 6 6 <> sty 1 CL <> sty 3 DD
    15 -> fslAndSc 9 6 <> carrier 2 <> sty 2 DD
    16 -> fslAndSc 11 6 <> sty 1 CL <> sty 2 DD

    17 -> fslAndSc 20 6 <> sty 1 CL <> sty 3 DD
    18 -> fslAndSc 15 6 <> carrier 3 <> sty 2 DD
    19 -> fslAndSc 20 6 <> sty 2 BBV <> sty 2 DD
    20 -> fslAndSc 1 2 <> submarine 1 <> sty 1 CL
    21 -> fslAndSc 15 5 <> lvlCnt 30 <> sty 1 CL <> sty 4 DD
       <> [FleetShipWithDrum 3]
    22 -> fslAndSc 30 6 <> lvlCnt 45 <> sty 1 CA <> sty 1 CL <> sty 2 DD
    23 -> fslAndSc 50 6 <> lvlCnt 200 <> sty 2 BBV <> sty 2 DD
    24 -> fslAndSc 50 6 <> lvlCnt 200 <> sty 1 CL <> sty 4 DD
       <> [Flagship (ShipTypeOneOf [CL])]

    25 -> fslAndSc 25 4 <> sty 2 CA <> sty 2 DD
    26 -> fslAndSc 30 4 <> carrier 1 <> sty 1 CL <> sty 2 DD
    27 -> fslAndSc 1 2 <> submarine 2
    28 -> fslAndSc 30 3 <> submarine 3
    29 -> fslAndSc 50 3 <> submarine 3
    30 -> fslAndSc 55 4 <> submarine 4
    31 -> fslAndSc 60 4 <> lvlCnt 200 <> submarine 4
    32 -> fslAndSc 5 4 <> sty 1 CT <> sty 2 DD
       <> [Flagship (ShipTypeOneOf [CT])]

    35 -> fslAndSc 40 6 <> carrier 2 <> sty 1 CA <> sty 1 CL
    36 -> fslAndSc 30 6 <> sty 2 AV <> sty 1 CL <> sty 1 DD
    37 -> fslAndSc 50 6 <> lvlCnt 200 <> sty 1 CL <> sty 5 DD
       <> [FleetShipWithDrum 4]
    38 -> fslAndSc 65 6 <> lvlCnt 240 <> sty 5 DD
       <> [FleetShipWithDrum 4, FleetDrum 8]
    39 -> fslAndSc 3 5 <> lvlCnt 180 <> sty 1 AS <> submarine 4
    40 -> fslAndSc 25 6 <> lvlCnt 150 <> sty 1 CL <> sty 2 AV <> sty 2 DD
       <> [Flagship (ShipTypeOneOf [CL])]
    _ -> []
  where
    lvlCnt n = [FleetLevel n]
    carrier n = [FleetSTypeCount n [CV,CVL,AV]]
    submarine n = [FleetSTypeCount n [SS,SSV]]
    sty n stype = [FleetSTypeCount n [stype]]
    fslAndSc fsl sc =
      [Flagship (ShipLevel fsl), FleetShipCount sc]

unsatisfiedRequirements :: forall a. Int -> Fleet a -> Array FleetRequirement
unsatisfiedRequirements eId fleet =
    filter (\fr -> not (checkFleet fr fleet)) fleetReqs
  where
    fleetReqs = getExpeditionRequirement eId

explainRequirements :: Array FleetRequirement -> Array String
explainRequirements = map explainFleetRequirement

checkExpedition :: forall a. Int -> Fleet a -> Boolean
checkExpedition eId fleet = validExpeditionId eId
                         && null (unsatisfiedRequirements eId fleet)

validExpeditionId :: Int -> Boolean
validExpeditionId = getExpeditionRequirement >>> null >>> not

expeditionIds :: Array Int
expeditionIds = (1..32) <> (35..40)

getAvailableExpeditions :: forall a. Fleet a -> Array Int
getAvailableExpeditions fleet =
  filter (\eId -> checkExpedition eId fleet) expeditionIds

module KanColle.Expedition
  ( Fleet(..)
  , FleetRequirement(..)
  , RawShip(..)
  , Ship(..)
  , ShipRequirement(..)
  , checkExpedition
  , validExpeditionId
  , unsatisfiedRequirements
  , explainRequirements
  , fromRawShip
  , fromRawFleet
  ) where

import Prelude
import Data.Array
import Data.Foldable
import Data.Maybe
import Data.Monoid
import qualified Data.String as Str

import KanColle.SType

data ShipRequirement
  = ShipLevel Int
  | ShipTypeOneOf (Array SType)
  | ShipDrum Int

data FleetRequirement
  = Flagship ShipRequirement
  | FleetLevel Int
  | FleetDrum Int
  | FleetShipWithDrum Int
  | FleetSTypeCount Int (Array SType)
  | FleetShipCount Int

type ExpeditionRequirement = Array FleetRequirement

explainShipRequirement :: ShipRequirement -> String
explainShipRequirement v = case v of
    ShipLevel lvl -> "ship level should be at least " <> show lvl
    ShipTypeOneOf stypes ->
      "ship should have one of the following type: " <> Str.joinWith "," (map showSType stypes)
    ShipDrum n -> "ship should have at least " <> show n <> " drum(s)"

explainFleetRequirement :: FleetRequirement -> String
explainFleetRequirement v = case v of
    Flagship fs -> "flagship: " <> explainShipRequirement fs
    FleetLevel lvl -> "fleet level sum should be at least " <> show lvl
    FleetDrum drum -> "fleet should have at least " <> show drum <> " drum(s)"
    FleetShipWithDrum n -> "at least " <> show n <> " ship(s) should have drum(s)"
    FleetSTypeCount n stypes -> "require at least "
      <> show n <> " ship(s) of the following type: " <> Str.joinWith "," (map showSType stypes)
    FleetShipCount n -> "fleet should have at least " <> show n <> " ship(s)"

type Ship a =
  { ammo :: Int
  , morale :: Int
  , stype :: SType
  , level :: Int
  , drumCount :: Int
  | a}

type RawShip a =
  { ammo :: Int
  , morale :: Int
  , stype :: String
  , level :: Int
  , drumCount :: Int
  | a}

type Fleet a = Array (Ship a)

fromRawShip :: forall a. RawShip a -> Ship a
fromRawShip s = s {stype = readSType s.stype}

fromRawFleet :: forall a. Array (RawShip a) -> Fleet a
fromRawFleet = map fromRawShip

checkShip :: forall a. ShipRequirement -> Ship a -> Boolean
checkShip req s = case req of
  ShipLevel n -> s.level >= n
  ShipTypeOneOf stype -> any ((==) s.stype) stype
  ShipDrum n -> s.drumCount >= n

checkFleet :: forall a. FleetRequirement -> Fleet a -> Boolean
checkFleet req fleet = case uncons fleet of
    Just { head: hd, tail: tl } -> case req of
        Flagship req -> checkShip req hd
        FleetLevel n -> sum (map (\x -> x.level) fleet) >= n
        FleetDrum n -> sum (map (\x -> x.drumCount) fleet) >= n
        FleetShipWithDrum n -> count (\x -> x.drumCount > 0) fleet >= n
        FleetSTypeCount n stypes -> count (checkShip (ShipTypeOneOf stypes)) fleet >= n
        FleetShipCount n -> length fleet >= n
    Nothing -> false
  where
    count pred = length <<< filter pred

getExpeditionRequirement :: Int -> ExpeditionRequirement
getExpeditionRequirement v = case v of
    1 -> fslAndSc 1 2
    2 -> fslAndSc 2 4
    3 -> fslAndSc 3 3
    4 -> fslAndSc 3 3 <> sty 1 CL <> sty 2 DD
    5 -> fslAndSc 3 4 <> sty 1 CL <> sty 2 DD
    6 -> fslAndSc 4 4
    7 -> fslAndSc 5 6
    8 -> fslAndSc 6 6

    9 -> fslAndSc 3 4 <> sty 1 CL <> sty 2 DD
    10 -> fslAndSc 3 3 <> sty 2 CL
    11 -> fslAndSc 6 4 <> sty 2 DD
    12 -> fslAndSc 4 4 <> sty 2 DD
    13 -> fslAndSc 5 6 <> sty 1 CL <> sty 4 DD
    14 -> fslAndSc 6 6 <> sty 1 CL <> sty 3 DD
    15 -> fslAndSc 9 6 <> carrier 2 <> sty 2 DD
    16 -> fslAndSc 11 6 <> sty 1 CL <> sty 2 DD

    17 -> fslAndSc 20 6 <> sty 1 CL <> sty 3 DD
    18 -> fslAndSc 15 6 <> carrier 3 <> sty 2 DD
    19 -> fslAndSc 20 6 <> sty 2 BBV <> sty 2 DD
    20 -> fslAndSc 1 2 <> submarine 1 <> sty 1 CL
    21 -> fslAndSc 15 5 <> lvlCnt 30 <> sty 1 CL <> sty 4 DD
       <> [FleetShipWithDrum 3]
    22 -> fslAndSc 30 6 <> lvlCnt 45 <> sty 1 CA <> sty 1 CL <> sty 2 DD
    23 -> fslAndSc 50 6 <> lvlCnt 200 <> sty 2 BBV <> sty 2 DD
    24 -> fslAndSc 50 6 <> lvlCnt 200 <> sty 1 CL <> sty 4 DD
       <> [Flagship (ShipTypeOneOf [CL])]

    25 -> fslAndSc 25 4 <> sty 2 CA <> sty 2 DD
    26 -> fslAndSc 30 4 <> carrier 1 <> sty 1 CL <> sty 2 DD
    27 -> fslAndSc 1 2 <> submarine 2
    28 -> fslAndSc 30 3 <> submarine 3
    29 -> fslAndSc 50 3 <> submarine 3
    30 -> fslAndSc 55 4 <> submarine 4
    31 -> fslAndSc 60 4 <> lvlCnt 200 <> submarine 4
    32 -> fslAndSc 5 4 <> sty 1 CT <> sty 2 DD
       <> [Flagship (ShipTypeOneOf [CT])]

    35 -> fslAndSc 40 6 <> carrier 2 <> sty 1 CA <> sty 1 CL
    36 -> fslAndSc 30 6 <> sty 2 AV <> sty 1 CL <> sty 1 DD
    37 -> fslAndSc 50 6 <> lvlCnt 200 <> sty 1 CL <> sty 5 DD
       <> [FleetShipWithDrum 4]
    38 -> fslAndSc 65 6 <> lvlCnt 240 <> sty 5 DD
       <> [FleetShipWithDrum 4, FleetDrum 8]
    39 -> fslAndSc 3 5 <> lvlCnt 180 <> sty 1 AS <> submarine 4
    40 -> fslAndSc 25 6 <> lvlCnt 150 <> sty 1 CL <> sty 2 AV <> sty 2 DD
       <> [Flagship (ShipTypeOneOf [CL])]
    _ -> []
  where
    lvlCnt n = [FleetLevel n]
    carrier n = [FleetSTypeCount n [CV,CVL,AV]]
    submarine n = [FleetSTypeCount n [SS,SSV]]
    sty n stype = [FleetSTypeCount n [stype]]
    fslAndSc fsl sc =
      [Flagship (ShipLevel fsl), FleetShipCount sc]

unsatisfiedRequirements :: forall a. Int -> Fleet a -> Array FleetRequirement
unsatisfiedRequirements eId fleet =
    filter (\fr -> not (checkFleet fr fleet)) fleetReqs
  where
    fleetReqs = getExpeditionRequirement eId

explainRequirements :: Array FleetRequirement -> Array String
explainRequirements = map explainFleetRequirement

checkExpedition :: forall a. Int -> Fleet a -> Boolean
checkExpedition eId fleet = validExpeditionId eId
                         && null (unsatisfiedRequirements eId fleet)

validExpeditionId :: Int -> Boolean
validExpeditionId = getExpeditionRequirement >>> null >>> not

expeditionIds :: Array Int
expeditionIds = (1..32) <> (35..40)


Add function for piping sources to sinks, TrackManager data type

module Genetics.Browser.Events.TrackManager where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Aff.Bus as Bus
import Data.Argonaut (Json)
import Data.Array (catMaybes)
import Data.Maybe (Maybe)
import Data.Record.Unsafe (unsafeGet)
import Data.StrMap (StrMap)
import Data.Tuple (Tuple(..))
import Data.Variant (Variant, expand)
import Genetics.Browser.Events.TrackSink (TrackSink(..), runTrackSink)
import Genetics.Browser.Events.TrackSource (TrackSource(..), runTrackSource)
import Genetics.Browser.Events.Types (Event)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

-- | Takes a source and a sink and returns a function that parses raw events
-- | with the TrackSource, and, if applicable, runs them through the TrackSink.
sourceToSink :: forall a.
                TrackSource Event
             -> TrackSink a
             -> Json
             -> Array a
sourceToSink tProd tCons rawEv = catMaybes $ runTrackSink tCons <$> runTrackSource tProd rawEv

-- | A TrackManager connects sources to sinks.
-- | It keeps track of the various events registered,
-- | to ensure that two events with the same name have the same structure.
data TrackManager t b c = TrackManager (StrMap t) (TrackSource b) (TrackSink c)

module Genetics.Browser.Events.TrackManager where

import Prelude
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Data.Record.Unsafe (unsafeGet)
import Data.Tuple (Tuple(..))
import Data.Variant (Variant, expand)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)


Unintroducing `selectThis`

Unintroducing `selectThis`

module JQueryUI where

import Control.Monad.Eff
import Control.Monad.JQuery(DOM(..), JQuery(..))

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

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

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

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

-- .click(f)
foreign import click
  """
  function click(f) {
    return function(ob) {
      return function() {
        ob.click(function () { return f(jQuery(this))(); });
      };
    };
  }
  """ :: forall eff a. (JQuery -> Eff (dom :: DOM | eff) JQuery) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .each(f)
foreign import each
  """
  function each(f) {
    return function(ob) {
      return function() {
        ob.each(function() { return f(jQuery(this))(); });
      };
    };
  }
  """ :: forall eff a. (JQuery -> Eff (dom :: DOM | eff) JQuery) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- x[0].checked = !x[0].checked
foreign import flipChecked
  """
  function flipChecked(ob) {
    return function () {
      ob[0].checked = !ob[0].checked;
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

-- .button('refresh')
foreign import refreshButton
  """
  function refreshButton(ob) {
    return function() {
      ob.button('refresh');
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

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

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

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

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

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

module JQueryUI where

import Control.Monad.Eff
import Control.Monad.JQuery(DOM(..), JQuery(..))

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

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

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

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

-- .click(f)
foreign import click
  """
  function click(f) {
    return function(ob) {
      return function() {
        ob.click(function () { return f(jQuery(this))(); });
      };
    };
  }
  """ :: forall eff a. (JQuery -> Eff (dom :: DOM | eff) JQuery) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- .each(f)
foreign import each
  """
  function each(f) {
    return function(ob) {
      return function() {
        ob.each(function() { return f(jQuery(this))(); });
      };
    };
  }
  """ :: forall eff a. (JQuery -> Eff (dom :: DOM | eff) JQuery) -> JQuery -> Eff (dom :: DOM | eff) JQuery

-- x[0].checked = !x[0].checked
foreign import flipChecked
  """
  function flipChecked(ob) {
    return function () {
      ob[0].checked = !ob[0].checked;
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

-- .button('refresh')
foreign import refreshButton
  """
  function refreshButton(ob) {
    return function() {
      ob.button('refresh');
    };
  }
  """ :: forall eff. JQuery -> Eff (dom :: DOM | eff) Unit

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

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

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

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

-- $(this)
foreign import selectThis
  """
  function selectThis() {
    return jQuery(this);
  }
  """ :: forall eff. Eff (dom :: DOM | eff) JQuery

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


Copy the rest of the comment over

Copy the rest of the comment over

-- | These functions allow PureScript strings to be treated as if they were
-- | sequences of Unicode code points instead of their true underlying
-- | implementation (sequences of UTF-16 code units). For nearly all uses of
-- | strings, these functions should be preferred over the ones in Data.String.
module Data.String.CodePoints
  ( module StringReExports
  , CodePoint()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  , count
  , drop
  , dropWhile
  , fromCodePointArray
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , length
  , singleton
  , splitAt
  , take
  , takeWhile
  , toCodePointArray
  , uncons
  ) where

import Prelude

import Data.Array as Array
import Data.Char as Char
import Data.Maybe (Maybe(Just, Nothing))
import Data.String as String
import Data.String.Unsafe as Unsafe
-- WARN: If a new function is added to Data.String, a version of that function
-- should be exported from this module, which should be the same except that it
-- should operate on the code point level rather than the code unit level. If
-- the function's behaviour does not change based on whether we consider
-- strings as sequences of code points or code units, it can simply be
-- re-exported from Data.String.
import Data.String (Pattern(..), Replacement(..), charAt, charCodeAt, contains, fromCharArray, joinWith, localeCompare, null, replace, replaceAll, split, stripPrefix, stripSuffix, toChar, toCharArray, toLower, toUpper, trim) as StringReExports
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (unfoldr)

-- | CodePoint is an Int bounded between 0 and 0x10FFFF, corresponding to
-- | Unicode code points.
newtype CodePoint = CodePoint Int

derive instance eqCodePoint :: Eq CodePoint
derive instance ordCodePoint :: Ord CodePoint

-- I would prefer that this smart constructor not need to exist and instead
-- CodePoint just implements Enum, but the Enum module already depends on this
-- one. To avoid the circular dependency, we just expose these two functions.
codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

unsurrogate :: Int -> Int -> CodePoint
unsurrogate lead trail = CodePoint ((lead - 0xD800) * 0x400 + (trail - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

fromCharCode :: Int -> String
fromCharCode = String.singleton <<< Char.fromCharCode

-- WARN: this function expects the String parameter to be non-empty
unsafeCodePointAt0 :: String -> CodePoint
unsafeCodePointAt0 = _unsafeCodePointAt0 unsafeCodePointAt0Fallback

foreign import _unsafeCodePointAt0
  :: (String -> CodePoint)
  -> String
  -> CodePoint

unsafeCodePointAt0Fallback :: String -> CodePoint
unsafeCodePointAt0Fallback s =
  let cu0 = Unsafe.charCodeAt 0 s in
  let cu1 = Unsafe.charCodeAt 1 s in
  if isLead cu0 && isTrail cu1
     then unsurrogate cu0 cu1
     else CodePoint cu0

-- | Returns the first code point of the string after dropping the given number
-- | of code points from the beginning, if there is such a code point. Operates
-- | in constant space and in time linear to the given index.
codePointAt :: Int -> String -> Maybe CodePoint
codePointAt n _ | n < 0 = Nothing
codePointAt 0 "" = Nothing
codePointAt 0 s = Just (unsafeCodePointAt0 s)
codePointAt n s = _codePointAt codePointAtFallback Just Nothing unsafeCodePointAt0 n s

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> (String -> CodePoint)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = case uncons s of
  Just { head, tail } -> if n == 0 then Just head else codePointAtFallback (n - 1) tail
  _ -> Nothing

-- | Returns the number of code points in the leading sequence of code points
-- | which all match the given predicate. Operates in constant space and in
-- | time linear to the length of the string.
count :: (CodePoint -> Boolean) -> String -> Int
count = _count countFallback unsafeCodePointAt0

foreign import _count
  :: ((CodePoint -> Boolean) -> String -> Int)
  -> (String -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

countFallback :: (CodePoint -> Boolean) -> String -> Int
countFallback p s = countTail p s 0

countTail :: (CodePoint -> Boolean) -> String -> Int -> Int
countTail p s accum = case uncons s of
  Just { head, tail } -> if p head then countTail p tail (accum + 1) else accum
  _ -> accum

-- | Drops the given number of code points from the beginning of the string. If
-- | the string does not have that many code points, returns the empty string.
-- | Operates in constant space and in time linear to the given number.
drop :: Int -> String -> String
drop n s = String.drop (String.length (take n s)) s

-- | Drops the leading sequence of code points which all match the given
-- | predicate from the string. Operates in constant space and in time linear
-- | to the length of the string.
dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | Creates a string from an array of code points. Operates in space and time
-- | linear to the length of the array.
fromCodePointArray :: Array CodePoint -> String
fromCodePointArray = _fromCodePointArray singletonFallback

foreign import _fromCodePointArray
  :: (CodePoint -> String)
  -> Array CodePoint
  -> String

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
indexOf :: String.Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (String.take i s)) <$> String.indexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches preceding the given index will be
-- | ignored. Returns Nothing when no matches are found.
indexOf' :: String.Pattern -> Int -> String -> Maybe Int
indexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (String.take k s')) <$> String.indexOf p s'

-- | Returns the number of code points preceding the last match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
lastIndexOf :: String.Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (String.take i s)) <$> String.lastIndexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches following the given index will be
-- | ignored. Returns Nothing when no matches are found.
lastIndexOf' :: String.Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s =
  let i' = String.length (take i s) in
  (\k -> length (String.take k s)) <$> String.lastIndexOf' p i' s

-- | Returns the number of code points in the string. Operates in constant
-- | space and in time linear to the length of the string.
length :: String -> Int
length = Array.length <<< toCodePointArray

-- | Creates a string containing just the given code point. Operates in
-- | constant space and time.
singleton :: CodePoint -> String
singleton = _singleton singletonFallback

foreign import _singleton
  :: (CodePoint -> String)
  -> CodePoint
  -> String

singletonFallback :: CodePoint -> String
singletonFallback (CodePoint cp) | cp <= 0xFFFF = fromCharCode cp
singletonFallback (CodePoint cp) =
  let lead = ((cp - 0x10000) / 0x400) + 0xD800 in
  let trail = (cp - 0x10000) `mod` 0x400 + 0xDC00 in
  fromCharCode lead <> fromCharCode trail

-- | Splits a string into two substrings, where `before` contains the code
-- | points up to (but not including) the given index, and `after` contains the
-- | rest of the string, from that index on.
-- |
-- | Thus the length of `(splitAt i s).before` will equal either `i` or
-- | `length s`, if that is shorter. (Or if `i` is negative the length will be
-- | 0.)
-- |
-- | In code:
-- | ```purescript
-- | length (splitAt i s).before == min (max i 0) (length s)
-- | (splitAt i s).before <> (splitAt i s).after == s
-- | splitAt i s == {before: take i s, after: drop i s}
-- | ```
splitAt :: Int -> String -> { before :: String, after :: String }
splitAt i s =
  let before = take i s in
  { before
  -- inline drop i s to reuse the result of take i s
  , after: String.drop (String.length before) s
  }

-- | Returns a string containing the given number of code points from the
-- | beginning of the given string. If the string does not have that many code
-- | points, returns the empty string. Operates in constant space and in time
-- | linear to the given number.
take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n _ | n < 1 = ""
takeFallback n s = case uncons s of
  Just { head, tail } -> singleton head <> takeFallback (n - 1) tail
  _ -> s

-- | Returns a string containing the leading sequence of code points which all
-- | match the given predicate from the string. Operates in constant space and
-- | in time linear to the length of the string.
takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Creates an array of code points from a string. Operates in space and time
-- | linear to the length of the string.
toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback unsafeCodePointAt0

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> (String -> CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr unconsButWithTuple s

unconsButWithTuple :: String -> Maybe (Tuple CodePoint String)
unconsButWithTuple s = (\{ head, tail } -> Tuple head tail) <$> uncons s

-- | Returns a record with the first code point and the remaining code points
-- | of the string. Returns Nothing if the string is empty. Operates in
-- | constant space and time.
uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s = case String.length s of
  0 -> Nothing
  1 -> Just { head: CodePoint (Unsafe.charCodeAt 0 s), tail: "" }
  _ ->
    let cu0 = Unsafe.charCodeAt 0 s in
    let cu1 = Unsafe.charCodeAt 1 s in
    if isLead cu0 && isTrail cu1
      then Just { head: unsurrogate cu0 cu1, tail: String.drop 2 s }
      else Just { head: CodePoint cu0, tail: String.drop 1 s }

-- | These functions allow PureScript strings to be treated as if they were
-- | sequences of Unicode code points instead of their true underlying
-- | implementation (sequences of UTF-16 code units). For nearly all uses of
-- | strings, these functions should be preferred over the ones in Data.String.
module Data.String.CodePoints
  ( module StringReExports
  , CodePoint()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  , count
  , drop
  , dropWhile
  , fromCodePointArray
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , length
  , singleton
  , splitAt
  , take
  , takeWhile
  , toCodePointArray
  , uncons
  ) where

import Prelude

import Data.Array as Array
import Data.Char as Char
import Data.Maybe (Maybe(Just, Nothing))
import Data.String as String
import Data.String.Unsafe as Unsafe
-- WARN: If a new function is added to Data.String, a version of that function
-- should be exported from this module, which should be the same except that it
-- should operate on the code point level rather than the code unit level. If
-- the function's behaviour does not change based on whether we consider
-- strings as sequences of code points or code units, it can simply be
-- re-exported from Data.String.
import Data.String (Pattern(..), Replacement(..), charAt, charCodeAt, contains, fromCharArray, joinWith, localeCompare, null, replace, replaceAll, split, stripPrefix, stripSuffix, toChar, toCharArray, toLower, toUpper, trim) as StringReExports
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (unfoldr)

-- | CodePoint is an Int bounded between 0 and 0x10FFFF, corresponding to
-- | Unicode code points.
newtype CodePoint = CodePoint Int

derive instance eqCodePoint :: Eq CodePoint
derive instance ordCodePoint :: Ord CodePoint

-- I would prefer that this smart constructor not need to exist and instead
-- CodePoint just implements Enum, but the Enum module already depends on this
-- one. To avoid the circular dependency, we just expose these two functions.
codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

unsurrogate :: Int -> Int -> CodePoint
unsurrogate lead trail = CodePoint ((lead - 0xD800) * 0x400 + (trail - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

fromCharCode :: Int -> String
fromCharCode = String.singleton <<< Char.fromCharCode

-- WARN: this function expects the String parameter to be non-empty
unsafeCodePointAt0 :: String -> CodePoint
unsafeCodePointAt0 = _unsafeCodePointAt0 unsafeCodePointAt0Fallback

foreign import _unsafeCodePointAt0
  :: (String -> CodePoint)
  -> String
  -> CodePoint

unsafeCodePointAt0Fallback :: String -> CodePoint
unsafeCodePointAt0Fallback s =
  let cu0 = Unsafe.charCodeAt 0 s in
  let cu1 = Unsafe.charCodeAt 1 s in
  if isLead cu0 && isTrail cu1
     then unsurrogate cu0 cu1
     else CodePoint cu0

-- | Returns the first code point of the string after dropping the given number
-- | of code points from the beginning, if there is such a code point. Operates
-- | in constant space and in time linear to the given index.
codePointAt :: Int -> String -> Maybe CodePoint
codePointAt n _ | n < 0 = Nothing
codePointAt 0 "" = Nothing
codePointAt 0 s = Just (unsafeCodePointAt0 s)
codePointAt n s = _codePointAt codePointAtFallback Just Nothing unsafeCodePointAt0 n s

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> (String -> CodePoint)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = case uncons s of
  Just { head, tail } -> if n == 0 then Just head else codePointAtFallback (n - 1) tail
  _ -> Nothing

-- | Returns the number of code points in the leading sequence of code points
-- | which all match the given predicate. Operates in constant space and in
-- | time linear to the length of the string.
count :: (CodePoint -> Boolean) -> String -> Int
count = _count countFallback unsafeCodePointAt0

foreign import _count
  :: ((CodePoint -> Boolean) -> String -> Int)
  -> (String -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

countFallback :: (CodePoint -> Boolean) -> String -> Int
countFallback p s = countTail p s 0

countTail :: (CodePoint -> Boolean) -> String -> Int -> Int
countTail p s accum = case uncons s of
  Just { head, tail } -> if p head then countTail p tail (accum + 1) else accum
  _ -> accum

-- | Drops the given number of code points from the beginning of the string. If
-- | the string does not have that many code points, returns the empty string.
-- | Operates in constant space and in time linear to the given number.
drop :: Int -> String -> String
drop n s = String.drop (String.length (take n s)) s

-- | Drops the leading sequence of code points which all match the given
-- | predicate from the string. Operates in constant space and in time linear
-- | to the length of the string.
dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | Creates a string from an array of code points. Operates in space and time
-- | linear to the length of the array.
fromCodePointArray :: Array CodePoint -> String
fromCodePointArray = _fromCodePointArray singletonFallback

foreign import _fromCodePointArray
  :: (CodePoint -> String)
  -> Array CodePoint
  -> String

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
indexOf :: String.Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (String.take i s)) <$> String.indexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches preceding the given index will be
-- | ignored. Returns Nothing when no matches are found.
indexOf' :: String.Pattern -> Int -> String -> Maybe Int
indexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (String.take k s')) <$> String.indexOf p s'

-- | Returns the number of code points preceding the last match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
lastIndexOf :: String.Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (String.take i s)) <$> String.lastIndexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches following the given index will be
-- | ignored. Returns Nothing when no matches are found.
lastIndexOf' :: String.Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s =
  let i' = String.length (take i s) in
  (\k -> length (String.take k s)) <$> String.lastIndexOf' p i' s

-- | Returns the number of code points in the string. Operates in constant
-- | space and in time linear to the length of the string.
length :: String -> Int
length = Array.length <<< toCodePointArray

-- | Creates a string containing just the given code point. Operates in
-- | constant space and time.
singleton :: CodePoint -> String
singleton = _singleton singletonFallback

foreign import _singleton
  :: (CodePoint -> String)
  -> CodePoint
  -> String

singletonFallback :: CodePoint -> String
singletonFallback (CodePoint cp) | cp <= 0xFFFF = fromCharCode cp
singletonFallback (CodePoint cp) =
  let lead = ((cp - 0x10000) / 0x400) + 0xD800 in
  let trail = (cp - 0x10000) `mod` 0x400 + 0xDC00 in
  fromCharCode lead <> fromCharCode trail

-- | Splits a string into two substrings, where `before` contains the code
-- | points up to (but not including) the given index, and `after` contains the
-- | rest of the string, from that index on.
splitAt :: Int -> String -> { before :: String, after :: String }
splitAt i s =
  let before = take i s in
  { before
  -- inline drop i s to reuse the result of take i s
  , after: String.drop (String.length before) s
  }

-- | Returns a string containing the given number of code points from the
-- | beginning of the given string. If the string does not have that many code
-- | points, returns the empty string. Operates in constant space and in time
-- | linear to the given number.
take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n _ | n < 1 = ""
takeFallback n s = case uncons s of
  Just { head, tail } -> singleton head <> takeFallback (n - 1) tail
  _ -> s

-- | Returns a string containing the leading sequence of code points which all
-- | match the given predicate from the string. Operates in constant space and
-- | in time linear to the length of the string.
takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Creates an array of code points from a string. Operates in space and time
-- | linear to the length of the string.
toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback unsafeCodePointAt0

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> (String -> CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr unconsButWithTuple s

unconsButWithTuple :: String -> Maybe (Tuple CodePoint String)
unconsButWithTuple s = (\{ head, tail } -> Tuple head tail) <$> uncons s

-- | Returns a record with the first code point and the remaining code points
-- | of the string. Returns Nothing if the string is empty. Operates in
-- | constant space and time.
uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s = case String.length s of
  0 -> Nothing
  1 -> Just { head: CodePoint (Unsafe.charCodeAt 0 s), tail: "" }
  _ ->
    let cu0 = Unsafe.charCodeAt 0 s in
    let cu1 = Unsafe.charCodeAt 1 s in
    if isLead cu0 && isTrail cu1
      then Just { head: unsurrogate cu0 cu1, tail: String.drop 2 s }
      else Just { head: CodePoint cu0, tail: String.drop 1 s }


clean imports

clean imports

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
   . 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'
   . Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) 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' 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, ReactProps, ReactRefs, ReactSpec, ReactState, ReactThis, Read, getProps, readState, writeState)
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId, WriteRedox)
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
   . 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'
   . Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) 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' 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