Bug fix. Extended operations caller handled the pc reg incorrectly

module Ops where

import Prelude
import Data.Int.Bits
import Data.Maybe
import Data.Array ((!!)) as A

import Types
import MainMem
import Utils

--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 + 2, m = 2 }
 where imm = rd8 (regs.pc+1) 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 + 2, m = 2 }
 where imm = rd8 (regs.pc+1) 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 + 2, m = 4}
 where
  sp' = (absI8 imm + regs.sp) .&. 0xFFFF
  imm = rd8 (regs.pc+1) 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 + 2, m = 2 }
 where imm = rd8 (regs.pc+1) 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 + 2, m = 2 }
 where imm = rd8 (regs.pc+1) 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 = adjFlag halfCarryFlag `cmp2` 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 = adjFlag halfCarryFlag <<< 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 = adjFlag halfCarryFlag <<< 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 + 2, m = 2}
 where imm = rd8 (regs.pc+1) 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 -> Mem -> Regs
testBitNOfHLMem n { 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
--RES N,R
setBitNOfReg :: Boolean -> Int -> SetReg -> GetReg
               -> Regs -> Regs
setBitNOfReg setVal n setReg getReg regs = setReg reg' regs { m = 2 }
 where reg' = setBitNOfX setVal n (getReg regs)

--SET N,(HL)
--RES N,(HL)
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

-- Rotations
-- =========

data Dir = LeftD | RightD
derive instance eqDir :: Eq Dir

-- RL[C] A, base-opcode
-- RR[C] A, base-opcode
rotA :: Dir -> Boolean -> Regs -> Regs
rotA dir isCarryRot regs = regs { a = rotated.res, f = rotated.flags, m = 1 }
 where rotated = rotX {dir,isCarryRot,isCB:false} regs.a regs.f

-- RL[C] R, CB-prefix instruction
-- RR[C] R, CB-prefix instruction
rotReg :: Dir -> Boolean -> SetReg -> GetReg -> Regs -> Regs
rotReg dir isCarryRot setReg getReg regs =
  setReg rotated.res regs { f = rotated.flags, m = 2 }
 where rotated = rotX {dir,isCarryRot,isCB:true} (getReg regs) regs.f

-- RL[C] (HL)
-- RR[C] (HL)
rotHLMem :: Dir -> Boolean -> Mem -> Mem
rotHLMem dir isCarryRot mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs { f = rotated.flags, m = 4 } }
 where
  mainMem' = wr8 rotated.res addr mainMem
  addr = joinRegs h l regs
  rotated = rotX {dir,isCarryRot,isCB:true} (rd8 addr mainMem) regs.f

rotX :: {dir::Dir,isCarryRot::Boolean,isCB::Boolean}
      -> I8 -> I8 -> { res :: I8, flags :: I8 }
rotX { dir, isCarryRot, isCB } x oldFlags = { res, flags }
 where
  res = 255 .&. (currCarry + (x `shiftFunc` 1))
  -- RotA basic, use old flags, RotR CB, start fresh with zeroFlag
  flags = setNewCarry
    $ if isCB then testZeroFlag res else oldFlags
  currCarry = if   (not isCarryRot) && (oldFlags .&. carryFlag /= 0)
                || (isCarryRot      && isNewCarry)
    then case dir of
      LeftD -> 1
      RightD -> 0x80
    else 0
  setNewCarry = if isNewCarry
    then (carryFlag .|. _)
    else (cmplCarryFlag .&. _)
  isNewCarry = x .&. edgeBit /= 0
  edgeBit = case dir of
    LeftD -> 0x80
    RightD -> 1
  shiftFunc = case dir of
    LeftD -> shl
    RightD -> zshr

-- Shifts
-- ======

--SLA R
--SRA R preserve sign
--SRL R
shiftReg :: Dir -> Boolean -> SetReg -> GetReg
         -> Regs -> Regs
shiftReg dir sign setReg getReg regs =
  setReg shifted.res regs { f = shifted.flags, m = 2 }
 where
  shifted = shiftX dir sign $ getReg regs

shiftMemHL :: Dir -> Boolean -> Mem -> Mem
shiftMemHL dir sign mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs { f = shifted.flags, m = 4 } }
 where
  mainMem' = wr8 shifted.res addr mainMem
  shifted = shiftX dir sign $ rd8 addr mainMem
  addr = joinRegs h l regs

shiftX :: Dir -> Boolean -> I8
       -> { res::I8, flags::I8 }
shiftX dir sign x = { res, flags }
 where
  res =  (255 .&. _)
     <<< (if sign && dir == RightD then (currCarry + _) else id)
      $  x `shiftFunc` 1
  shiftFunc = case dir of
    LeftD -> shl
    RightD -> zshr
  flags = newCarry .|. testZeroFlag res
  newCarry = if x .&. edgeBit /= 0 then carryFlag else 0
  currCarry = x .&. 0x80 --sign is only relevant for right shifts
  edgeBit = case dir of
    LeftD -> 0x80
    RightD -> 1

-- Increments / Decrements
-- =======================

--INC R
incReg :: GetReg -> SetReg -> Regs -> Regs
incReg = incDecReg incI8

--DEC R
decReg :: GetReg -> SetReg -> Regs -> Regs
decReg getReg setReg regs = regs' { f = setFlag subtractionFlag regs'.f }
  where regs' = (incDecReg decI8 getReg setReg regs)

incDecReg :: (I8 -> { res :: I8, carry :: Boolean })
          -> GetReg -> SetReg -> Regs -> Regs
incDecReg op getReg setReg regs =
  setReg inced .res regs {f = testZeroFlag inced.res, m = 1}
 where
  inced  = op $ getReg regs

--INC RR
incRegWithCarry :: GetReg -> GetReg -> SetReg -> SetReg
                -> Regs -> Regs
incRegWithCarry = incDecRegWithCarry incI8

--DEC RR
decRegWithCarry :: GetReg -> GetReg -> SetReg -> SetReg
                -> Regs -> Regs
decRegWithCarry = incDecRegWithCarry decI8

--NOTE: consider refactoring to something along the lines of
--"split2Regs . incI16 . joinRegs", if you have leeway, performance-wise.
incDecRegWithCarry :: (I8 -> { res :: I8, carry :: Boolean })
          -> GetReg -> GetReg -> SetReg -> SetReg
          -> Regs -> Regs
incDecRegWithCarry op getCarryReg getMainReg setCarryReg setMainReg regs =
  setCarryReg carryReg' <<< setMainReg mainReg' $ regs{m = 1}
 where
  carryReg' = (if mainRegInc.carry then _.res <<< op else id)
    $ getCarryReg regs
  mainReg' = mainRegInc.res
  mainRegInc = op $ getMainReg regs

--INC SP
incSP :: Regs -> Regs
incSP = incDecSP $ \x -> 0xFFFF .&. (x + 1)

--DEC SP
decSP :: Regs -> Regs
decSP = incDecSP $ \x -> 0xFFFF .&. (x - 1)

incDecSP :: (I16 -> I16) -> Regs -> Regs
incDecSP op regs = regs {sp = op $ regs.sp, m = 1}

--INC (HL)
incHLMem :: Mem -> Mem
incHLMem = incDecHLMem incI8

--DEC (HL)
decHLMem :: Mem -> Mem
decHLMem = incDecHLMem decI8

incDecHLMem :: (I8 -> { res :: I8, carry :: Boolean })
            -> Mem -> Mem
incDecHLMem op mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs {f = testZeroFlag inced.res, m = 3} }
 where
  mainMem' = wr8 inced.res addr mainMem
  inced = op $ rd8 addr mainMem
  addr = joinRegs h l regs

incI8 :: I8 -> { res :: I8, carry :: Boolean }
incI8 i8 = { res : i8', carry : i8' == 0 }
 where
  i8' = (i8 + 1) .&. 255

decI8 :: I8 -> { res :: I8, carry :: Boolean }
decI8 i8 = { res : i8', carry : i8' == 255 }
 where
  i8' = (i8 - 1) .&. 255

-- Loads
-- =====

--LD R,R
ldRegFromReg :: SetReg -> GetReg
      -> Regs -> Regs
ldRegFromReg setDestReg getSrcReg regs = setDestReg (getSrcReg regs)
  regs { m = 1 }

--LD (nn),SP
ldMemImmFromSP :: Mem -> Mem
ldMemImmFromSP mem@{mainMem, regs} =
  mem { mainMem = mainMem', regs = regs { pc = regs.pc + 3, m = 5 } }
 where
  mainMem' = wr16 regs.sp addr mainMem
  addr = rd16 (regs.pc+1) mainMem

--LD SP,HL
ldSPFromHL :: Regs -> Regs
ldSPFromHL regs  =
  regs { sp = sp', m = 2 }
 where sp' = joinRegs h l regs

ldSPFromImm :: Mem -> Regs
ldSPFromImm { mainMem, regs } =
  regs { sp = sp', pc = regs.pc + 3, m = 3 }
 where sp' = rd16 (regs.pc+1) mainMem

--LD RR,nn
ldTwoRegsFromImm :: SetReg -> SetReg
               -> Mem -> Regs
ldTwoRegsFromImm setHighReg setLowReg mem@{regs} = regs'' { pc = regs.pc+3, m = 3 }
 where
  regs'' = ldRegFromMem setHighReg (regs.pc+2) $ mem { regs = regs' }
  regs'  = ldRegFromMem setLowReg (regs.pc+1) mem

--LD R,(IOC)
ldRegFromFF00CMem :: SetReg -> Mem -> Regs
ldRegFromFF00CMem setReg mem@{regs, mainMem} = regs' { m = 2 }
 where regs' = ldRegFromFF00PlusX regs.c setReg mem

--LD R,(IOn)
ldRegFromFF00ImmMem :: SetReg -> Mem -> Regs
ldRegFromFF00ImmMem setReg mem@{regs, mainMem} = regs' { pc = regs.pc + 2, m = 3 }
 where regs' = ldRegFromFF00PlusX (rd8 (regs.pc+1) mainMem) setReg mem

ldRegFromFF00PlusX :: I8 -> SetReg -> Mem -> Regs
ldRegFromFF00PlusX  x setReg mem@{regs} = ldRegFromMem setReg addr mem
 where addr = 0xFF00 + x

--LD R,n
ldRegFromImm :: SetReg -> Mem -> Regs
ldRegFromImm setReg mem@{regs} = regs' { pc = regs.pc + 2 }
  where regs' = ldRegFromMem setReg (regs.pc+1) mem

--LD R,(RR)
ldRegFromMem2R :: SetReg -> GetReg -> GetReg
               -> Mem -> Regs
ldRegFromMem2R setReg msByteReg lsByteReg mem@{regs} =
  ldRegFromMem setReg ((msByteReg regs `shl` 8) + lsByteReg regs) mem

--LD A,(nn)
ldRegAFromMemImm :: Mem -> Regs
ldRegAFromMemImm mem@{ mainMem, regs } = regs' { pc = regs.pc + 3, m = 4 }
 where
  regs' = ldRegFromMem setA addr mem
  addr = rd16 (regs.pc+1) mainMem

--LDD A,(HL)
ldRegFromMemHLDec :: SetReg -> Mem -> Regs
ldRegFromMemHLDec = ldRegFromMemHLIncDec decRegWithCarry

--LDI A,(HL)
ldRegFromMemHLInc :: SetReg -> Mem -> Regs
ldRegFromMemHLInc = ldRegFromMemHLIncDec incRegWithCarry

ldRegFromMemHLIncDec :: (GetReg -> GetReg -> SetReg -> SetReg -> Regs -> Regs)
                   -- Inc/Dec reg operation's type signature
                   -> SetReg -> Mem -> Regs
ldRegFromMemHLIncDec op setReg mem@{ regs } = regs' {m = 2}
 where
  regs' = op h l setH setL
        $ ldRegFromMem setA addr mem
  addr = joinRegs h l regs

ldRegFromMem :: SetReg -> I16 -> Mem -> Regs
ldRegFromMem setReg addr { mainMem, regs } =
  setReg (rd8 addr mainMem) regs{m = 2}

--LD HL,SP|n|
ldHLFromSPImm :: Mem -> Regs
ldHLFromSPImm  mem@{ regs, mainMem } =
  regs {h = split.ms, l = split.ls, pc = regs.pc + 2, m = 3}
 where
  split = splitI16 x
  x = (absI8 imm + regs.sp) .&. 0xFFFF
  imm = rd8 (regs.pc+1) mainMem

--LDI (HL),A
ldMemHLFromRegInc :: GetReg -> Mem -> Mem
ldMemHLFromRegInc = ldMemHLFromRegIncDec incRegWithCarry

--LDD (HL),A
ldMemHLFromRegDec :: GetReg -> Mem -> Mem
ldMemHLFromRegDec  = ldMemHLFromRegIncDec decRegWithCarry

ldMemHLFromRegIncDec :: (GetReg -> GetReg -> SetReg -> SetReg -> Regs -> Regs)
                   -- Inc/Dec reg operation's type signature
                   -> GetReg
                   -> Mem -> Mem
ldMemHLFromRegIncDec op getReg mem@{regs} =
  mem { mainMem = mainMem', regs = regs' {m = 2} }
 where
  regs' = op h l setH setL regs
  mainMem' = _.mainMem $ ldMemFromReg addr a mem
  addr = joinRegs h l regs

--LD (IOC),R
ldFF00CMemFromReg :: GetReg -> Mem -> Mem
ldFF00CMemFromReg getReg mem@{regs, mainMem} =
  mem' { regs = regs{m = 2} }
 where mem' = ldFF00PlusXFromReg  regs.c getReg mem

--LD (IOn),R
ldFF00ImmMemFromReg :: GetReg -> Mem -> Mem
ldFF00ImmMemFromReg getReg mem@{regs, mainMem} =
  mem' { regs = regs{pc = regs.pc + 2, m = 3} }
 where
  mem' = ldFF00PlusXFromReg imm getReg mem
  imm = rd8 (regs.pc+1) mainMem

ldFF00PlusXFromReg :: I8 -> GetReg -> Mem -> Mem
ldFF00PlusXFromReg x getReg mem@{regs, mainMem} = mem'
 where
  mem' = ldMemFromReg addr getReg mem
  addr = 0xFF00 + x

--LD (nn),A
ldMemImmFromRegA :: Mem -> Mem
ldMemImmFromRegA  mem@{ mainMem, regs } =
 mem' { regs = regs{m = 4, pc = regs.pc + 3} }
 where
  mem' = ldMemFromReg addr a mem
  addr = rd16 (regs.pc+1) mainMem

--LD (HL),n
ldMemHLFromImm :: Mem -> Mem
ldMemHLFromImm  mem@{mainMem,regs} =
  mem { mainMem = mainMem' , regs = regs{m = 3, pc = regs.pc + 2} }
 where
  mainMem' = wr8 imm addr mainMem
  addr =  joinRegs h l regs
  imm = rd8 (regs.pc+1) mainMem

--LD (RR),R
ldMem2RFromReg :: GetReg -> GetReg -> GetReg
                        -> Mem -> Mem
ldMem2RFromReg msbAddrReg lsbAddrReg getReg mem@{ regs } =
  ldMemFromReg (joinRegs msbAddrReg lsbAddrReg regs) getReg mem

ldMemFromReg :: I16 -> GetReg
           -> Mem -> Mem
ldMemFromReg addr getReg mem@{ regs } = ldMemFromX addr (getReg regs) mem

ldMemFromX :: I16 -> I8
           -> Mem -> Mem
ldMemFromX addr x mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs{m = 2} }
 where mainMem' = wr8 x addr mainMem

-- Compares
-- ========

--CP A,R
compAToReg :: GetReg -> Regs -> Regs
compAToReg getReg regs = compAToX (getReg regs) regs

--CP A,(HL)
compAToMemHL :: Mem -> Regs
compAToMemHL { mainMem, regs } = (compAToX hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

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

compAToX :: I8 -> Regs -> Regs
compAToX x regs = regs { f = diff.flags, m = 1 }
 where
  diff = subI8s regs.a x

-- Stack operations
-- ================

--NOTE: On the one hand, there's an advantage of letting the compiler catch
--more mistakes by using row polymorphism in this case,
--on the other hand it obfuscates the signature, is there a better way?
--forall r s. { regs :: {sp::I8 | s}, mem :: MainMem | r }
--         -> { regs :: {sp::I8 | s}, mem :: MainMem | r }
--NOTE: Only 4 versions of PUSH so consider hard-coding them for performance.
--PUSH RR
pushReg :: GetReg -> GetReg
        -> Mem -> Mem
pushReg msByteReg lsByteReg mem@{regs,mainMem} =
  mem { mainMem = mainMem', regs = regs { sp = regs.sp - 2, m = 3 } }
 where
  mainMem' =  wr8 (lsByteReg regs) (regs.sp - 2)
          <<< wr8 (msByteReg regs) (regs.sp - 1)
           $  mainMem

--POP RR
popReg :: SetReg -> SetReg
       -> Mem -> Regs
popReg setMsByteReg setLsByteReg { mainMem, regs = regs@{sp} }
    = setMsByteReg (rd8 (sp + 1) mainMem)
   <<< setLsByteReg (rd8 sp mainMem)
    $  regs { sp = sp + 2, m = 3 }

-- Jumps
-- =====

-- JR NZ,n
-- JR Z,n
-- JR NC,n
-- JR C,n
jumpRelImmFlag :: Boolean -> I8 -> Mem -> Regs
jumpRelImmFlag inverse flag mem@{mainMem, regs} =
  if inverse `xor` isSetFlag flag regs.f
    then jumpRelImm mem
    else regs { pc = regs.pc + 2, m = 2 }

--JR n
jumpRelImm :: Mem -> Regs
jumpRelImm { mainMem, regs } =
  regs { pc = pc', m = 3 }
 where
  --NOTE: is it necessary to abs the immediate?
  pc' = addOrSubImm $ regs.pc + 2 --absI8 imm
  imm = rd8 (regs.pc+1) mainMem
  absImm = absI8 imm
  addOrSubImm = if absImm == imm
    then (_ + absImm) else (_ - absImm)

-- JP NZ,nn
-- JP Z,nn
-- JP NC,nn
-- JP C,nn
jumpImmFlag :: Boolean -> I8 -> Mem -> Regs
jumpImmFlag inverse flag mem@{mainMem,regs} =
  if inverse `xor` isSetFlag flag regs.f
    then (jumpImm mem) { m = 4 }
    else regs { pc = regs.pc + 3, m = 3 }

-- JP nn
jumpImm :: Mem -> Regs
jumpImm { mainMem, regs } =
  regs { pc = pc', m = 3 }
 where pc' = rd16 (regs.pc+1) mainMem

-- JP (HL)
jumpHL :: Regs -> Regs
jumpHL regs = regs { pc = pc', m = 1 }
 where pc' = joinRegs h l regs

{--jumpX :: I8 -> Regs--}
{--jumpX { mainMem, regs } =--}
  {--regs { pc = pc', m = 3 }--}
 {--where pc' = rd16 regs.pc mainMem--}

-- Call Z,nn
-- Call NZ,nn
-- Call C,nn
-- Call NC,nn
callImmFlag :: Boolean -> I8 -> Mem -> Mem
callImmFlag inverse flag mem@{mainMem,regs} =
  if inverse `xor` isSetFlag flag regs.f
    then callImm mem
    else mem { regs = regs {pc = regs.pc + 3, m = 3} }

-- Call nn
callImm :: Mem -> Mem
callImm mem@{mainMem,regs} =
  mem { mainMem =  mainMem', regs = regs { pc = imm, sp = regs.sp - 2, m = 5 } }
 where
  mainMem' = wr16 (regs.pc + 3) (regs.sp-2) $ mainMem
  imm = rd16 (regs.pc+1) mainMem

-- RET Z
-- RET NZ
-- RET C
-- RET NC
retFlag :: Boolean -> I8 -> Mem -> Regs
retFlag inverse flag mem@{mainMem,regs} =
  if inverse `xor` isSetFlag flag regs.f
    then ret mem
    else regs { m = 1 }

-- RETI
retEnableInterrupt :: Mem -> Regs
retEnableInterrupt { mainMem, regs, svdRegs } =
  --NOTE; not certain restoreRegs is necessary here
  {-restoreRegs svdRegs-} regs { ime = true, pc = pc', sp = regs.sp + 2, m = 3 }
 where pc' = rd16 regs.sp mainMem

-- RET
ret :: Mem -> Regs
ret { mainMem, regs } =
  regs { pc = pc', sp = regs.sp + 2, m = 3 }
 where pc' = rd16 regs.sp mainMem

--RST XX
callRoutine :: I16 -> Mem -> Mem
callRoutine addr { mainMem, regs, svdRegs } =
  { mainMem : mainMem', regs : regs', svdRegs : saveRegs regs svdRegs }
 where
  regs' = regs { sp = regs.sp - 2, pc = addr, m = 3 }
  mainMem' = wr16 regs.pc (regs.sp - 2) mainMem

-- Misc.
-- =====

--SWAP R
swapReg :: SetReg -> GetReg -> Regs -> Regs
swapReg setReg getReg regs = setReg reg' $ regs { f = f', m = 1 }
 where
  f' = testZeroFlag reg'
  reg' = ((0x0F.&.reg) `shl` 4) .|. ((0xF0.&.reg) `zshr` 4)
  reg = getReg regs

--SWAP (HL)
swapMemHL :: Mem -> Mem
swapMemHL mem@{mainMem, regs} =
  mem { mainMem = mainMem', regs = regs { m = 4 } }
 where
  mainMem' = wr8 hlMem' addr mainMem
  hlMem' = ((0x0F.&.hlMem) `shl` 4) .|. ((0xF0.&.hlMem) `zshr` 4)
  hlMem = rd8 addr mainMem
  addr = joinRegs h l regs

--Why a command called 'clear' actually flips the tag
--and not unset it, is a question that shouldn't be directed at me!
--CCF
clearCarryFlag :: Regs -> Regs
clearCarryFlag = changeCarryFlag false

--SCF
setCarryFlag :: Regs -> Regs
setCarryFlag = changeCarryFlag true

changeCarryFlag :: Boolean -> Regs -> Regs
changeCarryFlag isSet regs = regs { f = f', m = 1 }
 where f' =  unsetFlag subtractionFlag
         <<< unsetFlag halfCarryFlag
         <<< (if isSet then setFlag else flipFlag) carryFlag
          $  regs.f

--DAA
adjAForBCDAdd :: Regs -> Regs
adjAForBCDAdd regs = regs { f = adjF regs.f, a = a', m = 1 }
 where
  a' = adjHighNyb <<< adjLowNyb $ regs.a
  adjLowNyb = if (regs.f .&. halfCarryFlag /= 0) || (regs.a .&. 15 > 9)
    then (6 + _) else id
  adjHighNyb = if shouldAdjHighNyb then (0x60 + _) else id
  adjF = if shouldAdjHighNyb then (carryFlag .|. _) else (cmplCarryFlag .&. _)
  shouldAdjHighNyb = (regs.f .&. halfCarryFlag /= 0) || (regs.a > 0x99)

--NOP
nop :: Regs -> Regs
nop = _ { m = 1}

--Invalid opCode
invalidOpCode :: Z80State -> Z80State
--NOTE: LOG THIS! for debugging purposes
invalidOpCode state = state { stop = true }

--STOP
--NOTE: this is just a guess
stop :: Z80State -> Z80State
stop state@{mem=mem@{regs}} =
  state { stop = true
        , mem = mem { regs = regs { m = 1 } }
        }

--HALT
halt :: Z80State -> Z80State
halt state@{mem=mem@{regs}} =
  state { halt = true
        , mem = mem { regs = regs { m = 1 } }
        }

--DI
--EI
setInterrupts :: Boolean -> Regs -> Regs
setInterrupts enable = _ { ime = enable, m = 1 }

--Extended Ops
execExtOps :: Array (Z80State -> Z80State)
           -> Z80State -> Z80State
execExtOps opsMap state@{ mem = mem@{mainMem,regs} } = extOp state'
 where
  --NOTE replace toMaybe, with something to log errors
  extOp = getOpcode opCode opsMap
  state' = state { mem = mem { regs = regs { pc = 65535 .&. (regs.pc + 2) } } }
  opCode = rd8 (regs.pc+1) mainMem

-- 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 :: GetReg -> GetReg -> 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
             }

adjFlag :: I8 -> Regs -> Regs
adjFlag flag regs = regs { f = setFlag flag regs.f }

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)

--NOTE: replace fromMaybe with an error report mechanism to trace bad cases
getOpcode :: Int -> Array (Z80State -> Z80State) -> Z80State -> Z80State
getOpcode ix table = fromMaybe id $ table A.!! ix

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

module Ops where

import Prelude
import Data.Int.Bits
import Data.Maybe
import Data.Array ((!!)) as A

import Types
import MainMem
import Utils

--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 + 2, m = 2 }
 where imm = rd8 (regs.pc+1) 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 + 2, m = 2 }
 where imm = rd8 (regs.pc+1) 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 + 2, m = 4}
 where
  sp' = (absI8 imm + regs.sp) .&. 0xFFFF
  imm = rd8 (regs.pc+1) 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 + 2, m = 2 }
 where imm = rd8 (regs.pc+1) 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 + 2, m = 2 }
 where imm = rd8 (regs.pc+1) 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 = adjFlag halfCarryFlag `cmp2` 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 = adjFlag halfCarryFlag <<< 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 = adjFlag halfCarryFlag <<< 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 + 2, m = 2}
 where imm = rd8 (regs.pc+1) 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 -> Mem -> Regs
testBitNOfHLMem n { 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
--RES N,R
setBitNOfReg :: Boolean -> Int -> SetReg -> GetReg
               -> Regs -> Regs
setBitNOfReg setVal n setReg getReg regs = setReg reg' regs { m = 2 }
 where reg' = setBitNOfX setVal n (getReg regs)

--SET N,(HL)
--RES N,(HL)
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

-- Rotations
-- =========

data Dir = LeftD | RightD
derive instance eqDir :: Eq Dir

-- RL[C] A, base-opcode
-- RR[C] A, base-opcode
rotA :: Dir -> Boolean -> Regs -> Regs
rotA dir isCarryRot regs = regs { a = rotated.res, f = rotated.flags, m = 1 }
 where rotated = rotX {dir,isCarryRot,isCB:false} regs.a regs.f

-- RL[C] R, CB-prefix instruction
-- RR[C] R, CB-prefix instruction
rotReg :: Dir -> Boolean -> SetReg -> GetReg -> Regs -> Regs
rotReg dir isCarryRot setReg getReg regs =
  setReg rotated.res regs { f = rotated.flags, m = 2 }
 where rotated = rotX {dir,isCarryRot,isCB:true} (getReg regs) regs.f

-- RL[C] (HL)
-- RR[C] (HL)
rotHLMem :: Dir -> Boolean -> Mem -> Mem
rotHLMem dir isCarryRot mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs { f = rotated.flags, m = 4 } }
 where
  mainMem' = wr8 rotated.res addr mainMem
  addr = joinRegs h l regs
  rotated = rotX {dir,isCarryRot,isCB:true} (rd8 addr mainMem) regs.f

rotX :: {dir::Dir,isCarryRot::Boolean,isCB::Boolean}
      -> I8 -> I8 -> { res :: I8, flags :: I8 }
rotX { dir, isCarryRot, isCB } x oldFlags = { res, flags }
 where
  res = 255 .&. (currCarry + (x `shiftFunc` 1))
  -- RotA basic, use old flags, RotR CB, start fresh with zeroFlag
  flags = setNewCarry
    $ if isCB then testZeroFlag res else oldFlags
  currCarry = if   (not isCarryRot) && (oldFlags .&. carryFlag /= 0)
                || (isCarryRot      && isNewCarry)
    then case dir of
      LeftD -> 1
      RightD -> 0x80
    else 0
  setNewCarry = if isNewCarry
    then (carryFlag .|. _)
    else (cmplCarryFlag .&. _)
  isNewCarry = x .&. edgeBit /= 0
  edgeBit = case dir of
    LeftD -> 0x80
    RightD -> 1
  shiftFunc = case dir of
    LeftD -> shl
    RightD -> zshr

-- Shifts
-- ======

--SLA R
--SRA R preserve sign
--SRL R
shiftReg :: Dir -> Boolean -> SetReg -> GetReg
         -> Regs -> Regs
shiftReg dir sign setReg getReg regs =
  setReg shifted.res regs { f = shifted.flags, m = 2 }
 where
  shifted = shiftX dir sign $ getReg regs

shiftMemHL :: Dir -> Boolean -> Mem -> Mem
shiftMemHL dir sign mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs { f = shifted.flags, m = 4 } }
 where
  mainMem' = wr8 shifted.res addr mainMem
  shifted = shiftX dir sign $ rd8 addr mainMem
  addr = joinRegs h l regs

shiftX :: Dir -> Boolean -> I8
       -> { res::I8, flags::I8 }
shiftX dir sign x = { res, flags }
 where
  res =  (255 .&. _)
     <<< (if sign && dir == RightD then (currCarry + _) else id)
      $  x `shiftFunc` 1
  shiftFunc = case dir of
    LeftD -> shl
    RightD -> zshr
  flags = newCarry .|. testZeroFlag res
  newCarry = if x .&. edgeBit /= 0 then carryFlag else 0
  currCarry = x .&. 0x80 --sign is only relevant for right shifts
  edgeBit = case dir of
    LeftD -> 0x80
    RightD -> 1

-- Increments / Decrements
-- =======================

--INC R
incReg :: GetReg -> SetReg -> Regs -> Regs
incReg = incDecReg incI8

--DEC R
decReg :: GetReg -> SetReg -> Regs -> Regs
decReg getReg setReg regs = regs' { f = setFlag subtractionFlag regs'.f }
  where regs' = (incDecReg decI8 getReg setReg regs)

incDecReg :: (I8 -> { res :: I8, carry :: Boolean })
          -> GetReg -> SetReg -> Regs -> Regs
incDecReg op getReg setReg regs =
  setReg inced .res regs {f = testZeroFlag inced.res, m = 1}
 where
  inced  = op $ getReg regs

--INC RR
incRegWithCarry :: GetReg -> GetReg -> SetReg -> SetReg
                -> Regs -> Regs
incRegWithCarry = incDecRegWithCarry incI8

--DEC RR
decRegWithCarry :: GetReg -> GetReg -> SetReg -> SetReg
                -> Regs -> Regs
decRegWithCarry = incDecRegWithCarry decI8

--NOTE: consider refactoring to something along the lines of
--"split2Regs . incI16 . joinRegs", if you have leeway, performance-wise.
incDecRegWithCarry :: (I8 -> { res :: I8, carry :: Boolean })
          -> GetReg -> GetReg -> SetReg -> SetReg
          -> Regs -> Regs
incDecRegWithCarry op getCarryReg getMainReg setCarryReg setMainReg regs =
  setCarryReg carryReg' <<< setMainReg mainReg' $ regs{m = 1}
 where
  carryReg' = (if mainRegInc.carry then _.res <<< op else id)
    $ getCarryReg regs
  mainReg' = mainRegInc.res
  mainRegInc = op $ getMainReg regs

--INC SP
incSP :: Regs -> Regs
incSP = incDecSP $ \x -> 0xFFFF .&. (x + 1)

--DEC SP
decSP :: Regs -> Regs
decSP = incDecSP $ \x -> 0xFFFF .&. (x - 1)

incDecSP :: (I16 -> I16) -> Regs -> Regs
incDecSP op regs = regs {sp = op $ regs.sp, m = 1}

--INC (HL)
incHLMem :: Mem -> Mem
incHLMem = incDecHLMem incI8

--DEC (HL)
decHLMem :: Mem -> Mem
decHLMem = incDecHLMem decI8

incDecHLMem :: (I8 -> { res :: I8, carry :: Boolean })
            -> Mem -> Mem
incDecHLMem op mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs {f = testZeroFlag inced.res, m = 3} }
 where
  mainMem' = wr8 inced.res addr mainMem
  inced = op $ rd8 addr mainMem
  addr = joinRegs h l regs

incI8 :: I8 -> { res :: I8, carry :: Boolean }
incI8 i8 = { res : i8', carry : i8' == 0 }
 where
  i8' = (i8 + 1) .&. 255

decI8 :: I8 -> { res :: I8, carry :: Boolean }
decI8 i8 = { res : i8', carry : i8' == 255 }
 where
  i8' = (i8 - 1) .&. 255

-- Loads
-- =====

--LD R,R
ldRegFromReg :: SetReg -> GetReg
      -> Regs -> Regs
ldRegFromReg setDestReg getSrcReg regs = setDestReg (getSrcReg regs)
  regs { m = 1 }

--LD (nn),SP
ldMemImmFromSP :: Mem -> Mem
ldMemImmFromSP mem@{mainMem, regs} =
  mem { mainMem = mainMem', regs = regs { pc = regs.pc + 3, m = 5 } }
 where
  mainMem' = wr16 regs.sp addr mainMem
  addr = rd16 (regs.pc+1) mainMem

--LD SP,HL
ldSPFromHL :: Regs -> Regs
ldSPFromHL regs  =
  regs { sp = sp', m = 2 }
 where sp' = joinRegs h l regs

ldSPFromImm :: Mem -> Regs
ldSPFromImm { mainMem, regs } =
  regs { sp = sp', pc = regs.pc + 3, m = 3 }
 where sp' = rd16 (regs.pc+1) mainMem

--LD RR,nn
ldTwoRegsFromImm :: SetReg -> SetReg
               -> Mem -> Regs
ldTwoRegsFromImm setHighReg setLowReg mem@{regs} = regs'' { pc = regs.pc+3, m = 3 }
 where
  regs'' = ldRegFromMem setHighReg (regs.pc+2) $ mem { regs = regs' }
  regs'  = ldRegFromMem setLowReg (regs.pc+1) mem

--LD R,(IOC)
ldRegFromFF00CMem :: SetReg -> Mem -> Regs
ldRegFromFF00CMem setReg mem@{regs, mainMem} = regs' { m = 2 }
 where regs' = ldRegFromFF00PlusX regs.c setReg mem

--LD R,(IOn)
ldRegFromFF00ImmMem :: SetReg -> Mem -> Regs
ldRegFromFF00ImmMem setReg mem@{regs, mainMem} = regs' { pc = regs.pc + 2, m = 3 }
 where regs' = ldRegFromFF00PlusX (rd8 (regs.pc+1) mainMem) setReg mem

ldRegFromFF00PlusX :: I8 -> SetReg -> Mem -> Regs
ldRegFromFF00PlusX  x setReg mem@{regs} = ldRegFromMem setReg addr mem
 where addr = 0xFF00 + x

--LD R,n
ldRegFromImm :: SetReg -> Mem -> Regs
ldRegFromImm setReg mem@{regs} = regs' { pc = regs.pc + 2 }
  where regs' = ldRegFromMem setReg (regs.pc+1) mem

--LD R,(RR)
ldRegFromMem2R :: SetReg -> GetReg -> GetReg
               -> Mem -> Regs
ldRegFromMem2R setReg msByteReg lsByteReg mem@{regs} =
  ldRegFromMem setReg ((msByteReg regs `shl` 8) + lsByteReg regs) mem

--LD A,(nn)
ldRegAFromMemImm :: Mem -> Regs
ldRegAFromMemImm mem@{ mainMem, regs } = regs' { pc = regs.pc + 3, m = 4 }
 where
  regs' = ldRegFromMem setA addr mem
  addr = rd16 (regs.pc+1) mainMem

--LDD A,(HL)
ldRegFromMemHLDec :: SetReg -> Mem -> Regs
ldRegFromMemHLDec = ldRegFromMemHLIncDec decRegWithCarry

--LDI A,(HL)
ldRegFromMemHLInc :: SetReg -> Mem -> Regs
ldRegFromMemHLInc = ldRegFromMemHLIncDec incRegWithCarry

ldRegFromMemHLIncDec :: (GetReg -> GetReg -> SetReg -> SetReg -> Regs -> Regs)
                   -- Inc/Dec reg operation's type signature
                   -> SetReg -> Mem -> Regs
ldRegFromMemHLIncDec op setReg mem@{ regs } = regs' {m = 2}
 where
  regs' = op h l setH setL
        $ ldRegFromMem setA addr mem
  addr = joinRegs h l regs

ldRegFromMem :: SetReg -> I16 -> Mem -> Regs
ldRegFromMem setReg addr { mainMem, regs } =
  setReg (rd8 addr mainMem) regs{m = 2}

--LD HL,SP|n|
ldHLFromSPImm :: Mem -> Regs
ldHLFromSPImm  mem@{ regs, mainMem } =
  regs {h = split.ms, l = split.ls, pc = regs.pc + 2, m = 3}
 where
  split = splitI16 x
  x = (absI8 imm + regs.sp) .&. 0xFFFF
  imm = rd8 (regs.pc+1) mainMem

--LDI (HL),A
ldMemHLFromRegInc :: GetReg -> Mem -> Mem
ldMemHLFromRegInc = ldMemHLFromRegIncDec incRegWithCarry

--LDD (HL),A
ldMemHLFromRegDec :: GetReg -> Mem -> Mem
ldMemHLFromRegDec  = ldMemHLFromRegIncDec decRegWithCarry

ldMemHLFromRegIncDec :: (GetReg -> GetReg -> SetReg -> SetReg -> Regs -> Regs)
                   -- Inc/Dec reg operation's type signature
                   -> GetReg
                   -> Mem -> Mem
ldMemHLFromRegIncDec op getReg mem@{regs} =
  mem { mainMem = mainMem', regs = regs' {m = 2} }
 where
  regs' = op h l setH setL regs
  mainMem' = _.mainMem $ ldMemFromReg addr a mem
  addr = joinRegs h l regs

--LD (IOC),R
ldFF00CMemFromReg :: GetReg -> Mem -> Mem
ldFF00CMemFromReg getReg mem@{regs, mainMem} =
  mem' { regs = regs{m = 2} }
 where mem' = ldFF00PlusXFromReg  regs.c getReg mem

--LD (IOn),R
ldFF00ImmMemFromReg :: GetReg -> Mem -> Mem
ldFF00ImmMemFromReg getReg mem@{regs, mainMem} =
  mem' { regs = regs{pc = regs.pc + 2, m = 3} }
 where
  mem' = ldFF00PlusXFromReg imm getReg mem
  imm = rd8 (regs.pc+1) mainMem

ldFF00PlusXFromReg :: I8 -> GetReg -> Mem -> Mem
ldFF00PlusXFromReg x getReg mem@{regs, mainMem} = mem'
 where
  mem' = ldMemFromReg addr getReg mem
  addr = 0xFF00 + x

--LD (nn),A
ldMemImmFromRegA :: Mem -> Mem
ldMemImmFromRegA  mem@{ mainMem, regs } =
 mem' { regs = regs{m = 4, pc = regs.pc + 3} }
 where
  mem' = ldMemFromReg addr a mem
  addr = rd16 (regs.pc+1) mainMem

--LD (HL),n
ldMemHLFromImm :: Mem -> Mem
ldMemHLFromImm  mem@{mainMem,regs} =
  mem { mainMem = mainMem' , regs = regs{m = 3, pc = regs.pc + 2} }
 where
  mainMem' = wr8 imm addr mainMem
  addr =  joinRegs h l regs
  imm = rd8 (regs.pc+1) mainMem

--LD (RR),R
ldMem2RFromReg :: GetReg -> GetReg -> GetReg
                        -> Mem -> Mem
ldMem2RFromReg msbAddrReg lsbAddrReg getReg mem@{ regs } =
  ldMemFromReg (joinRegs msbAddrReg lsbAddrReg regs) getReg mem

ldMemFromReg :: I16 -> GetReg
           -> Mem -> Mem
ldMemFromReg addr getReg mem@{ regs } = ldMemFromX addr (getReg regs) mem

ldMemFromX :: I16 -> I8
           -> Mem -> Mem
ldMemFromX addr x mem@{mainMem,regs} =
  mem { mainMem = mainMem', regs = regs{m = 2} }
 where mainMem' = wr8 x addr mainMem

-- Compares
-- ========

--CP A,R
compAToReg :: GetReg -> Regs -> Regs
compAToReg getReg regs = compAToX (getReg regs) regs

--CP A,(HL)
compAToMemHL :: Mem -> Regs
compAToMemHL { mainMem, regs } = (compAToX hlMem regs) { m = 2 }
 where hlMem = rd8 (joinRegs h l regs) mainMem

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

compAToX :: I8 -> Regs -> Regs
compAToX x regs = regs { f = diff.flags, m = 1 }
 where
  diff = subI8s regs.a x

-- Stack operations
-- ================

--NOTE: On the one hand, there's an advantage of letting the compiler catch
--more mistakes by using row polymorphism in this case,
--on the other hand it obfuscates the signature, is there a better way?
--forall r s. { regs :: {sp::I8 | s}, mem :: MainMem | r }
--         -> { regs :: {sp::I8 | s}, mem :: MainMem | r }
--NOTE: Only 4 versions of PUSH so consider hard-coding them for performance.
--PUSH RR
pushReg :: GetReg -> GetReg
        -> Mem -> Mem
pushReg msByteReg lsByteReg mem@{regs,mainMem} =
  mem { mainMem = mainMem', regs = regs { sp = regs.sp - 2, m = 3 } }
 where
  mainMem' =  wr8 (lsByteReg regs) (regs.sp - 2)
          <<< wr8 (msByteReg regs) (regs.sp - 1)
           $  mainMem

--POP RR
popReg :: SetReg -> SetReg
       -> Mem -> Regs
popReg setMsByteReg setLsByteReg { mainMem, regs = regs@{sp} }
    = setMsByteReg (rd8 (sp + 1) mainMem)
   <<< setLsByteReg (rd8 sp mainMem)
    $  regs { sp = sp + 2, m = 3 }

-- Jumps
-- =====

-- JR NZ,n
-- JR Z,n
-- JR NC,n
-- JR C,n
jumpRelImmFlag :: Boolean -> I8 -> Mem -> Regs
jumpRelImmFlag inverse flag mem@{mainMem, regs} =
  if inverse `xor` isSetFlag flag regs.f
    then jumpRelImm mem
    else regs { pc = regs.pc + 2, m = 2 }

--JR n
jumpRelImm :: Mem -> Regs
jumpRelImm { mainMem, regs } =
  regs { pc = pc', m = 3 }
 where
  --NOTE: is it necessary to abs the immediate?
  pc' = addOrSubImm $ regs.pc + 2 --absI8 imm
  imm = rd8 (regs.pc+1) mainMem
  absImm = absI8 imm
  addOrSubImm = if absImm == imm
    then (_ + absImm) else (_ - absImm)

-- JP NZ,nn
-- JP Z,nn
-- JP NC,nn
-- JP C,nn
jumpImmFlag :: Boolean -> I8 -> Mem -> Regs
jumpImmFlag inverse flag mem@{mainMem,regs} =
  if inverse `xor` isSetFlag flag regs.f
    then (jumpImm mem) { m = 4 }
    else regs { pc = regs.pc + 3, m = 3 }

-- JP nn
jumpImm :: Mem -> Regs
jumpImm { mainMem, regs } =
  regs { pc = pc', m = 3 }
 where pc' = rd16 (regs.pc+1) mainMem

-- JP (HL)
jumpHL :: Regs -> Regs
jumpHL regs = regs { pc = pc', m = 1 }
 where pc' = joinRegs h l regs

{--jumpX :: I8 -> Regs--}
{--jumpX { mainMem, regs } =--}
  {--regs { pc = pc', m = 3 }--}
 {--where pc' = rd16 regs.pc mainMem--}

-- Call Z,nn
-- Call NZ,nn
-- Call C,nn
-- Call NC,nn
callImmFlag :: Boolean -> I8 -> Mem -> Mem
callImmFlag inverse flag mem@{mainMem,regs} =
  if inverse `xor` isSetFlag flag regs.f
    then callImm mem
    else mem { regs = regs {pc = regs.pc + 3, m = 3} }

-- Call nn
callImm :: Mem -> Mem
callImm mem@{mainMem,regs} =
  mem { mainMem =  mainMem', regs = regs { pc = imm, sp = regs.sp - 2, m = 5 } }
 where
  mainMem' = wr16 (regs.pc + 3) (regs.sp-2) $ mainMem
  imm = rd16 (regs.pc+1) mainMem

-- RET Z
-- RET NZ
-- RET C
-- RET NC
retFlag :: Boolean -> I8 -> Mem -> Regs
retFlag inverse flag mem@{mainMem,regs} =
  if inverse `xor` isSetFlag flag regs.f
    then ret mem
    else regs { m = 1 }

-- RETI
retEnableInterrupt :: Mem -> Regs
retEnableInterrupt { mainMem, regs, svdRegs } =
  --NOTE; not certain restoreRegs is necessary here
  {-restoreRegs svdRegs-} regs { ime = true, pc = pc', sp = regs.sp + 2, m = 3 }
 where pc' = rd16 regs.sp mainMem

-- RET
ret :: Mem -> Regs
ret { mainMem, regs } =
  regs { pc = pc', sp = regs.sp + 2, m = 3 }
 where pc' = rd16 regs.sp mainMem

--RST XX
callRoutine :: I16 -> Mem -> Mem
callRoutine addr { mainMem, regs, svdRegs } =
  { mainMem : mainMem', regs : regs', svdRegs : saveRegs regs svdRegs }
 where
  regs' = regs { sp = regs.sp - 2, pc = addr, m = 3 }
  mainMem' = wr16 regs.pc (regs.sp - 2) mainMem

-- Misc.
-- =====

--SWAP R
swapReg :: SetReg -> GetReg -> Regs -> Regs
swapReg setReg getReg regs = setReg reg' $ regs { f = f', m = 1 }
 where
  f' = testZeroFlag reg'
  reg' = ((0x0F.&.reg) `shl` 4) .|. ((0xF0.&.reg) `zshr` 4)
  reg = getReg regs

--SWAP (HL)
swapMemHL :: Mem -> Mem
swapMemHL mem@{mainMem, regs} =
  mem { mainMem = mainMem', regs = regs { m = 4 } }
 where
  mainMem' = wr8 hlMem' addr mainMem
  hlMem' = ((0x0F.&.hlMem) `shl` 4) .|. ((0xF0.&.hlMem) `zshr` 4)
  hlMem = rd8 addr mainMem
  addr = joinRegs h l regs

--Why a command called 'clear' actually flips the tag
--and not unset it, is a question that shouldn't be directed at me!
--CCF
clearCarryFlag :: Regs -> Regs
clearCarryFlag = changeCarryFlag false

--SCF
setCarryFlag :: Regs -> Regs
setCarryFlag = changeCarryFlag true

changeCarryFlag :: Boolean -> Regs -> Regs
changeCarryFlag isSet regs = regs { f = f', m = 1 }
 where f' =  unsetFlag subtractionFlag
         <<< unsetFlag halfCarryFlag
         <<< (if isSet then setFlag else flipFlag) carryFlag
          $  regs.f

--DAA
adjAForBCDAdd :: Regs -> Regs
adjAForBCDAdd regs = regs { f = adjF regs.f, a = a', m = 1 }
 where
  a' = adjHighNyb <<< adjLowNyb $ regs.a
  adjLowNyb = if (regs.f .&. halfCarryFlag /= 0) || (regs.a .&. 15 > 9)
    then (6 + _) else id
  adjHighNyb = if shouldAdjHighNyb then (0x60 + _) else id
  adjF = if shouldAdjHighNyb then (carryFlag .|. _) else (cmplCarryFlag .&. _)
  shouldAdjHighNyb = (regs.f .&. halfCarryFlag /= 0) || (regs.a > 0x99)

--NOP
nop :: Regs -> Regs
nop = _ { m = 1}

--Invalid opCode
invalidOpCode :: Z80State -> Z80State
--NOTE: LOG THIS! for debugging purposes
invalidOpCode state = state { stop = true }

--STOP
--NOTE: this is just a guess
stop :: Z80State -> Z80State
stop state@{mem=mem@{regs}} =
  state { stop = true
        , mem = mem { regs = regs { m = 1 } }
        }

--HALT
halt :: Z80State -> Z80State
halt state@{mem=mem@{regs}} =
  state { halt = true
        , mem = mem { regs = regs { m = 1 } }
        }

--DI
--EI
setInterrupts :: Boolean -> Regs -> Regs
setInterrupts enable = _ { ime = enable, m = 1 }

--Extended Ops
execExtOps :: Array (Z80State -> Z80State)
           -> Z80State -> Z80State
execExtOps opsMap state@{ mem = mem@{mainMem,regs} } = extOp state'
 where
  --NOTE replace toMaybe, with something to log errors
  extOp = getOpcode opCode opsMap
  state' = state { mem = mem { regs = regs { pc = 65535 .&. (regs.pc + 1) } } }
  opCode = rd8 regs.pc mainMem

-- 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 :: GetReg -> GetReg -> 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
             }

adjFlag :: I8 -> Regs -> Regs
adjFlag flag regs = regs { f = setFlag flag regs.f }

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)

--NOTE: replace fromMaybe with an error report mechanism to trace bad cases
getOpcode :: Int -> Array (Z80State -> Z80State) -> Z80State -> Z80State
getOpcode ix table = fromMaybe id $ table A.!! ix

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


show App Type in Div

show App Type in Div

module Web
  ( exprToJQuery
  , getPath
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.JQuery as J
import DOM
import Prelude

import Data.Foldable (all)
import Data.Traversable (for)
import Data.List
import Data.Tuple
import Data.String (joinWith)
import Data.Foreign (unsafeFromForeign)
import Control.Apply ((*>))
import Control.Bind ((=<<), (>=>))

import AST
import Evaluator (Path(..))
import TypeChecker (prettyPrintType,extractType)

pathPropName :: String
pathPropName = "clickyEvaluation_path"

getPath :: forall eff. J.JQuery -> Eff (dom :: DOM | eff) Path
getPath j = unsafeFromForeign <$> J.getProp pathPropName j

-- TODO rename to fit new Type
exprToJQuery :: forall eff. Output -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery output = go id output
  where
  go :: (Path -> Path) -> Output -> Eff (dom :: DOM | eff) J.JQuery
  go p o = J.setProp pathPropName (p End) =<< case o of
    {expr:(Atom a), typ:(TAtom t)} -> atom a t
    {expr:(Binary op e1 e2), typ:(TBinary opt tt1 tt2 t)} -> do
      j1 <- go (p <<< Fst) {expr:e1, typ:tt1}
      j2 <- go (p <<< Snd) {expr:e2, typ:tt2}
      binary op opt t j1 j2 --TODO show type of op or type of expr ?

    {expr:(List es), typ:(TListTree ts t)} -> case isString es of
                  true  -> string es t
                  false -> do js <- zipWithA (\i (Tuple e t) -> go (p <<< Nth i) {expr:e, typ:t}) (0 .. (length es - 1)) (zip es ts)
                              list js (map extractType ts) t
    {expr:NTuple es, typ:TNTuple ts t} -> do
      js <- zipWithA (\i (Tuple e t) -> go (p <<< Nth i) {expr:e, typ:t}) (0 .. (length es - 1)) (zip es ts)
      tuple js (map extractType ts) t
    {expr:SectL e op, typ:TSectL tt opt t} -> do
      j <- go (p <<< Fst) {expr:e, typ:tt}
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt
      section j jop t
    {expr:SectR op e, typ:TSectR opt tt t} -> do
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt
      j <- go (p <<< Snd) {expr:e, typ:tt}
      section jop j t
    {expr:PrefixOp op, typ:TPrefixOp t} -> makeDiv ("(" ++ pPrintOp op ++ ")") (toList ["prefix", "op"]) >>= addTypetoDiv t
    {expr:IfExpr cond thenExpr elseExpr, typ:TIfExpr tt1 tt2  tt3 t} -> do
      jc <- go (p <<< Fst) {expr:cond, typ:tt1}
      jt <- go (p <<< Snd) {expr:thenExpr, typ:tt2}
      je <- go (p <<< Thrd) {expr:elseExpr, typ:tt3}
      ifexpr jc jt je t
    {expr:Lambda binds body, typ:TLambda lb tt t} -> do
      jBinds <- for (zip binds lb) binding
      jBody <- go (p <<< Fst) {expr:body, typ:tt}
      lambda jBinds jBody t
    {expr:App func args, typ:TApp tt ts t} -> do
      jFunc <- go (p <<< Fst) {expr:func, typ:tt}
      jArgs <- zipWithA (\i (Tuple e t) -> go (p <<< Nth i) {expr:e, typ:t}) (0 .. (length args - 1)) (zip args ts)
      app jFunc jArgs t

atom :: forall eff. Atom -> Type -> Eff (dom :: DOM | eff) J.JQuery
atom (AInt n) t     = makeDiv (show n) (toList ["atom", "num"]) >>= addTypetoDiv (TypCon "HALLO") >>= addTypetoDiv t
atom (Bool true) t  = makeDiv "True"  (toList ["atom", "bool"]) >>= addTypetoDiv t
atom (Bool false) t = makeDiv "False" (toList ["atom", "bool"]) >>= addTypetoDiv t
atom (Char c) t    = (makeDiv ("'" ++ c ++ "'") (toList ["atom", "char"])) >>= addTypetoDiv t
atom (Name name) t = makeDiv name (toList ["atom", "name"]) >>= addTypetoDiv t

binding :: forall eff. Tuple Binding  TypeBinding -> Eff (dom :: DOM | eff) J.JQuery
binding b = case b of
  Tuple (Lit a) (TLit t)       -> atom a t
  Tuple (ConsLit b bs) (TConsLit tb tbs t)-> do
    jCons <- makeDiv "" Nil >>= addTypetoDiv t
    makeDiv "(" (singleton "brace") >>= flip J.append jCons
    binding (Tuple b tb)            >>= flip J.append jCons
    makeDiv ":" (singleton "colon") >>= flip J.append jCons
    binding (Tuple bs tbs)           >>= flip J.append jCons
    makeDiv ")" (singleton "brace") >>= flip J.append jCons
  Tuple (ListLit bs) (TListLit tbs t) -> do
    jList <- makeDiv "" Nil >>= addTypetoDiv t
    makeDiv "[" (singleton "brace") >>= flip J.append jList
    let bx = zip bs tbs
    for bx $ \b -> do
      binding b >>= flip J.append jList
      makeDiv "," (singleton "comma") >>= flip J.append jList
    makeDiv "]" (singleton "brace") >>= flip J.append jList
  Tuple (NTupleLit bs) (TNTupleLit tbs t)-> do
    jTuple <- makeDiv "" Nil >>= addTypetoDiv t
    makeDiv "(" (singleton "brace") >>= flip J.append jTuple
    let b = (zip bs tbs)
    interleaveM_ (binding >=> flip J.append jTuple) (makeDiv "," (singleton "comma") >>= flip J.append jTuple) b
    makeDiv ")" (singleton "brace") >>= flip J.append jTuple
    return jTuple

lambda :: forall eff. List J.JQuery -> J.JQuery -> Type -> Eff (dom :: DOM | eff) J.JQuery
lambda jBinds jBody t = do
  jLam <- makeDiv "" (singleton "lambda") >>= addTypetoDiv t
  open <- makeDiv "(" (singleton "brace")
  J.append open jLam
  bs <- makeDiv "\\" (singleton "backslash")
  J.append bs jLam
  for jBinds (flip J.append jLam)
  arrow <- makeDiv "->" (singleton "arrow")
  J.append arrow jLam
  J.append jBody jLam
  close <- makeDiv ")" (singleton "brace")
  J.append close jLam
  return jLam

binary :: forall eff. Op -> Type -> Type -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
binary op opt t j1 j2 = do
  dBin <- makeDiv "" (singleton "binary") >>= addTypetoDiv t
  J.append j1 dBin
  dOp <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt
  J.append dOp dBin
  J.append j2 dBin
  return dBin

section :: forall eff. J.JQuery -> J.JQuery -> Type -> Eff (dom :: DOM | eff) J.JQuery
section j1 j2 t = do
  jSect <- makeDiv "" (singleton "section") >>= addTypetoDiv t
  open <- makeDiv "(" (singleton "brace")
  J.append open jSect
  J.append j1 jSect
  J.append j2 jSect
  close <- makeDiv ")" (singleton "brace")
  J.append close jSect
  return jSect

ifexpr :: forall eff. J.JQuery -> J.JQuery -> J.JQuery -> Type -> Eff (dom :: DOM | eff) J.JQuery
ifexpr cond thenExpr elseExpr t = do
  dIf <- makeDiv "" (singleton "if") >>= addTypetoDiv t
  makeDiv "if" (singleton "keyword") >>= flip J.append dIf
  J.append cond dIf
  makeDiv "then" (singleton "keyword") >>= flip J.append dIf
  J.append thenExpr dIf
  makeDiv "else" (singleton "keyword") >>= flip J.append dIf
  J.append elseExpr dIf
  return dIf

interleaveM_ :: forall a b m. (Monad m) => (a -> m b) -> m b -> List a -> m Unit
interleaveM_ f sep = go
  where
  go Nil     = return unit
  go (Cons x Nil)    = void $ f x
  go (Cons x xs) = f x *> sep *> go xs

tuple :: forall eff. List J.JQuery -> List Type -> Type -> Eff (dom :: DOM | eff) J.JQuery
tuple js ts t = do
  dtuple <- makeDiv "" (singleton "tuple") >>= addTypetoDiv t
  open <- makeDiv "(" (singleton "brace")
  js' <- zipWithA (\j t -> addTypetoDiv t j) js ts
  J.append open dtuple
  interleaveM_ (flip J.append dtuple) (makeDiv "," (singleton "comma") >>= flip J.append dtuple) js'
  close <- makeDiv ")" (singleton "brace")
  J.append close dtuple
  return dtuple

list :: forall eff. List J.JQuery -> List Type -> Type -> Eff (dom :: DOM | eff) J.JQuery
list js ts t = do
  dls <- makeDiv "" (singleton "list") >>= addTypetoDiv t
  open <- makeDiv "[" (singleton "brace")
  js' <- zipWithA (\j t -> addTypetoDiv t j) js ts
  J.append open dls
  interleaveM_ (flip J.append dls) (makeDiv "," (singleton "comma") >>= flip J.append dls) js'
  close <- makeDiv "]" (singleton "brace")
  J.append close dls
  return dls

isString :: List Expr -> Boolean
isString es = length es > 0 && all isChar es
  where
  isChar (Atom (Char _)) = true
  isChar _               = false

string :: forall eff. List Expr -> Type -> Eff (dom :: DOM | eff) J.JQuery
string es t = do
  let str = "\"" ++ joinWith "" (fromList ((\(Atom (Char s)) -> s) <$> es)) ++ "\""
  dstring <- makeDiv str (toList ["list", "string"]) >>= addTypetoDiv t
  return dstring

app :: forall eff. J.JQuery -> List J.JQuery -> Type -> Eff (dom :: DOM | eff) J.JQuery
app jFunc jArgs t = do
  dApp <- makeDiv "" (singleton "app") >>= addTypetoDiv t
  J.addClass "func" jFunc
  J.append jFunc dApp
  for jArgs (flip J.append dApp)
  return dApp

type Class = String

makeDiv :: forall eff. String -> List Class -> Eff (dom :: DOM | eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for classes (flip J.addClass d)
  return d

addTypetoDiv:: forall eff. Type -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addTypetoDiv typ = J.setAttr "title" (prettyPrintType typ)

module Web
  ( exprToJQuery
  , getPath
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.JQuery as J
import DOM
import Prelude

import Data.Foldable (all)
import Data.Traversable (for)
import Data.List
import Data.Tuple
import Data.String (joinWith)
import Data.Foreign (unsafeFromForeign)
import Control.Apply ((*>))
import Control.Bind ((=<<), (>=>))

import AST
import Evaluator (Path(..))
import TypeChecker (prettyPrintType,extractType)

pathPropName :: String
pathPropName = "clickyEvaluation_path"

getPath :: forall eff. J.JQuery -> Eff (dom :: DOM | eff) Path
getPath j = unsafeFromForeign <$> J.getProp pathPropName j

-- TODO rename to fit new Type
exprToJQuery :: forall eff. Output -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery output = go id output
  where
  go :: (Path -> Path) -> Output -> Eff (dom :: DOM | eff) J.JQuery
  go p o = J.setProp pathPropName (p End) =<< case o of
    {expr:(Atom a), typ:(TAtom t)} -> atom a t
    {expr:(Binary op e1 e2), typ:(TBinary opt tt1 tt2 t)} -> do
      j1 <- go (p <<< Fst) {expr:e1, typ:tt1}
      j2 <- go (p <<< Snd) {expr:e2, typ:tt2}
      binary op opt t j1 j2 --TODO show type of op or type of expr ?

    {expr:(List es), typ:(TListTree ts t)} -> case isString es of
                  true  -> string es t
                  false -> do js <- zipWithA (\i (Tuple e t) -> go (p <<< Nth i) {expr:e, typ:t}) (0 .. (length es - 1)) (zip es ts)
                              list js (map extractType ts) t
    {expr:NTuple es, typ:TNTuple ts t} -> do
      js <- zipWithA (\i (Tuple e t) -> go (p <<< Nth i) {expr:e, typ:t}) (0 .. (length es - 1)) (zip es ts)
      tuple js (map extractType ts) t
    {expr:SectL e op, typ:TSectL tt opt t} -> do
      j <- go (p <<< Fst) {expr:e, typ:tt}
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt
      section j jop t
    {expr:SectR op e, typ:TSectR opt tt t} -> do
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt
      j <- go (p <<< Snd) {expr:e, typ:tt}
      section jop j t
    {expr:PrefixOp op, typ:TPrefixOp t} -> makeDiv ("(" ++ pPrintOp op ++ ")") (toList ["prefix", "op"]) >>= addTypetoDiv t
    {expr:IfExpr cond thenExpr elseExpr, typ:TIfExpr tt1 tt2  tt3 t} -> do
      jc <- go (p <<< Fst) {expr:cond, typ:tt1}
      jt <- go (p <<< Snd) {expr:thenExpr, typ:tt2}
      je <- go (p <<< Thrd) {expr:elseExpr, typ:tt3}
      ifexpr jc jt je t
    {expr:Lambda binds body, typ:TLambda lb tt t} -> do
      jBinds <- for (zip binds lb) binding
      jBody <- go (p <<< Fst) {expr:body, typ:tt}
      lambda jBinds jBody t
    {expr:App func args, typ:TApp tt ts t} -> do
      jFunc <- go (p <<< Fst) {expr:func, typ:tt}
      jArgs <- zipWithA (\i (Tuple e t) -> go (p <<< Nth i) {expr:e, typ:t}) (0 .. (length args - 1)) (zip args ts)
      app jFunc jArgs

atom :: forall eff. Atom -> Type -> Eff (dom :: DOM | eff) J.JQuery
atom (AInt n) t     = makeDiv (show n) (toList ["atom", "num"]) >>= addTypetoDiv (TypCon "HALLO") >>= addTypetoDiv t
atom (Bool true) t  = makeDiv "True"  (toList ["atom", "bool"]) >>= addTypetoDiv t
atom (Bool false) t = makeDiv "False" (toList ["atom", "bool"]) >>= addTypetoDiv t
atom (Char c) t    = (makeDiv ("'" ++ c ++ "'") (toList ["atom", "char"])) >>= addTypetoDiv t
atom (Name name) t = makeDiv name (toList ["atom", "name"]) >>= addTypetoDiv t

binding :: forall eff. Tuple Binding  TypeBinding -> Eff (dom :: DOM | eff) J.JQuery
binding b = case b of
  Tuple (Lit a) (TLit t)       -> atom a t
  Tuple (ConsLit b bs) (TConsLit tb tbs t)-> do
    jCons <- makeDiv "" Nil >>= addTypetoDiv t
    makeDiv "(" (singleton "brace") >>= flip J.append jCons
    binding (Tuple b tb)            >>= flip J.append jCons
    makeDiv ":" (singleton "colon") >>= flip J.append jCons
    binding (Tuple bs tbs)           >>= flip J.append jCons
    makeDiv ")" (singleton "brace") >>= flip J.append jCons
  Tuple (ListLit bs) (TListLit tbs t) -> do
    jList <- makeDiv "" Nil >>= addTypetoDiv t
    makeDiv "[" (singleton "brace") >>= flip J.append jList
    let bx = zip bs tbs
    for bx $ \b -> do
      binding b >>= flip J.append jList
      makeDiv "," (singleton "comma") >>= flip J.append jList
    makeDiv "]" (singleton "brace") >>= flip J.append jList
  Tuple (NTupleLit bs) (TNTupleLit tbs t)-> do
    jTuple <- makeDiv "" Nil >>= addTypetoDiv t
    makeDiv "(" (singleton "brace") >>= flip J.append jTuple
    let b = (zip bs tbs)
    interleaveM_ (binding >=> flip J.append jTuple) (makeDiv "," (singleton "comma") >>= flip J.append jTuple) b
    makeDiv ")" (singleton "brace") >>= flip J.append jTuple
    return jTuple

lambda :: forall eff. List J.JQuery -> J.JQuery -> Type -> Eff (dom :: DOM | eff) J.JQuery
lambda jBinds jBody t = do
  jLam <- makeDiv "" (singleton "lambda") >>= addTypetoDiv t
  open <- makeDiv "(" (singleton "brace")
  J.append open jLam
  bs <- makeDiv "\\" (singleton "backslash")
  J.append bs jLam
  for jBinds (flip J.append jLam)
  arrow <- makeDiv "->" (singleton "arrow")
  J.append arrow jLam
  J.append jBody jLam
  close <- makeDiv ")" (singleton "brace")
  J.append close jLam
  return jLam

binary :: forall eff. Op -> Type -> Type -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
binary op opt t j1 j2 = do
  dBin <- makeDiv "" (singleton "binary") >>= addTypetoDiv t
  J.append j1 dBin
  dOp <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt
  J.append dOp dBin
  J.append j2 dBin
  return dBin

section :: forall eff. J.JQuery -> J.JQuery -> Type -> Eff (dom :: DOM | eff) J.JQuery
section j1 j2 t = do
  jSect <- makeDiv "" (singleton "section") >>= addTypetoDiv t
  open <- makeDiv "(" (singleton "brace")
  J.append open jSect
  J.append j1 jSect
  J.append j2 jSect
  close <- makeDiv ")" (singleton "brace")
  J.append close jSect
  return jSect

ifexpr :: forall eff. J.JQuery -> J.JQuery -> J.JQuery -> Type -> Eff (dom :: DOM | eff) J.JQuery
ifexpr cond thenExpr elseExpr t = do
  dIf <- makeDiv "" (singleton "if") >>= addTypetoDiv t
  makeDiv "if" (singleton "keyword") >>= flip J.append dIf
  J.append cond dIf
  makeDiv "then" (singleton "keyword") >>= flip J.append dIf
  J.append thenExpr dIf
  makeDiv "else" (singleton "keyword") >>= flip J.append dIf
  J.append elseExpr dIf
  return dIf

interleaveM_ :: forall a b m. (Monad m) => (a -> m b) -> m b -> List a -> m Unit
interleaveM_ f sep = go
  where
  go Nil     = return unit
  go (Cons x Nil)    = void $ f x
  go (Cons x xs) = f x *> sep *> go xs

tuple :: forall eff. List J.JQuery -> List Type -> Type -> Eff (dom :: DOM | eff) J.JQuery
tuple js ts t = do
  dtuple <- makeDiv "" (singleton "tuple") >>= addTypetoDiv t
  open <- makeDiv "(" (singleton "brace")
  js' <- zipWithA (\j t -> addTypetoDiv t j) js ts
  J.append open dtuple
  interleaveM_ (flip J.append dtuple) (makeDiv "," (singleton "comma") >>= flip J.append dtuple) js'
  close <- makeDiv ")" (singleton "brace")
  J.append close dtuple
  return dtuple

list :: forall eff. List J.JQuery -> List Type -> Type -> Eff (dom :: DOM | eff) J.JQuery
list js ts t = do
  dls <- makeDiv "" (singleton "list") >>= addTypetoDiv t
  open <- makeDiv "[" (singleton "brace")
  js' <- zipWithA (\j t -> addTypetoDiv t j) js ts
  J.append open dls
  interleaveM_ (flip J.append dls) (makeDiv "," (singleton "comma") >>= flip J.append dls) js'
  close <- makeDiv "]" (singleton "brace")
  J.append close dls
  return dls

isString :: List Expr -> Boolean
isString es = length es > 0 && all isChar es
  where
  isChar (Atom (Char _)) = true
  isChar _               = false

string :: forall eff. List Expr -> Type -> Eff (dom :: DOM | eff) J.JQuery
string es t = do
  let str = "\"" ++ joinWith "" (fromList ((\(Atom (Char s)) -> s) <$> es)) ++ "\""
  dstring <- makeDiv str (toList ["list", "string"]) >>= addTypetoDiv t
  return dstring

app :: forall eff. J.JQuery -> List J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
app jFunc jArgs = do
  dApp <- makeDiv "" (singleton "app")
  J.addClass "func" jFunc
  J.append jFunc dApp
  for jArgs (flip J.append dApp)
  return dApp

type Class = String

makeDiv :: forall eff. String -> List Class -> Eff (dom :: DOM | eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for classes (flip J.addClass d)
  return d

addTypetoDiv:: forall eff. Type -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addTypetoDiv typ = J.setAttr "title" (prettyPrintType typ)


Fix longstanding issue leading to https://github.com/nwolverson/purescript-language-server/issues/28

module IdePurescript.Completion where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Data.Array (filter, head, intersect, sortBy, (:))
import Data.Either (Either)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.String (Pattern(..), contains, indexOf, length)
import Data.String.Utils (startsWith)
import Data.String.Regex (Regex, regex)
import Data.String.Regex.Flags (noFlags)
import IdePurescript.PscIde (eitherToErr, getCompletion)
import IdePurescript.Regex (match', test')
import IdePurescript.Tokens (identPart, modulePart, moduleRegex)
import PscIde (NET, listAvailableModules)
import PscIde.Command (CompletionOptions(..), ModuleList(..), TypeInfo(..))

type ModuleInfo =
  { modules :: Array String
  , getQualifiedModule :: String -> Array String
  , mainModule :: Maybe String
  , importedModules :: Array String
  }

data SuggestionType = Module | Type | Function | Value

explicitImportRegex :: Either String Regex
explicitImportRegex = regex ("""^import\s+""" <> modulePart <> """\s+\([^)]*?""" <> identPart <> "$") noFlags

getModuleSuggestions :: forall eff. Int -> String -> Aff (net :: NET | eff) (Array String)
getModuleSuggestions port prefix = do
  list <- eitherToErr $ listAvailableModules port
  pure $ case list of
    (ModuleList lst) -> filter (\m -> indexOf (Pattern prefix) m == Just 0) lst

data SuggestionResult =
  ModuleSuggestion { text :: String, suggestType :: SuggestionType, prefix :: String }
  | IdentSuggestion { origMod :: String, exportMod :: String, exportedFrom :: Array String, identifier :: String, qualifier :: Maybe String, valueType :: String, suggestType :: SuggestionType, prefix :: String, documentation :: Maybe String }

getSuggestions :: forall eff. Int -> {
    line :: String,
    moduleInfo :: ModuleInfo,
    groupCompletions :: Boolean,
    maxResults :: Maybe Int,
    preferredModules :: Array String
  } -> Aff (net :: NET | eff) (Array SuggestionResult)
getSuggestions port
    { line
    , moduleInfo: { modules, getQualifiedModule, mainModule, importedModules }
    , maxResults
    , groupCompletions
    , preferredModules
    } =
  if moduleExplicit then
    case match' explicitImportRegex line of
      Just [ Just _, Just mod, Just token ] -> do
        completions <- getCompletion port token mainModule Nothing [ mod ] getQualifiedModule opts
        pure $ map (result Nothing token) completions
      _ -> pure []
  else
    case parsed of
      Just { mod, token } ->
        if moduleCompletion then do
          let prefix = getModuleName (fromMaybe "" mod) token
          completions <- getModuleSuggestions port prefix
          pure $ map (modResult prefix) completions
        else do
          completions <- getCompletion port token mainModule mod ("Prim":modules) getQualifiedModule opts
          pure $ map (result mod token) completions
      Nothing -> pure []
    where
    opts = CompletionOptions { maxResults, groupReexports: groupCompletions }

    getModuleName "" token  = token
    getModuleName mod token = mod <> "." <> token

    isImport = indexOf (Pattern "import") line == Just 0
    hasBracket = indexOf (Pattern "(") line /= Nothing
    moduleCompletion = isImport && not hasBracket
    moduleExplicit = isImport && hasBracket

    parsed = case match' moduleRegex line of
        Just [ Just _, mod, tok ] | mod /= Nothing || tok /= Nothing ->
          Just { mod, token: fromMaybe "" tok}
        _ -> Nothing

    modResult prefix moduleName = ModuleSuggestion { text: moduleName, suggestType: Module, prefix }
    result qualifier prefix (TypeInfo {type', identifier, module': origMod, exportedFrom, documentation }) =
      IdentSuggestion { origMod, exportMod, identifier, qualifier, suggestType, prefix, valueType: type', exportedFrom, documentation }
      where
        suggestType =
          if contains (Pattern "->") type' then Function
          else if test' (regex "^[A-Z]" noFlags) identifier then Type
          else Value

        -- Strategies for picking the re-export to choose
        -- 1. Existing imports
        -- 2. User configuration of preferred modules (ordered list)
        -- 3. Re-export from a prefix named module (e.g. Foo.Bar.Baz reexported from Foo.Bar) shortest first
        -- 4. Original module (if none of the previous rules apply, there are no re-exports, or either grouping
        --    is disabled or compiler version does not support it)
        exportMod = fromMaybe origMod (existingModule <|> preferredModule <|> prefixModule)
        existingModule = head $ intersect importedModules exportedFrom
        preferredModule = head $ intersect preferredModules exportedFrom
        prefixModule = head $
          sortBy (\a b -> length a `compare` length b) $
          filter (\m -> startsWith (m <> ".") origMod) exportedFrom

module IdePurescript.Completion where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Data.Array (filter, head, intersect, sortBy, (:))
import Data.Either (Either)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.String (Pattern(..), contains, indexOf, length)
import Data.String.Utils (startsWith)
import Data.String.Regex (Regex, regex)
import Data.String.Regex.Flags (noFlags)
import IdePurescript.PscIde (eitherToErr, getCompletion)
import IdePurescript.Regex (match', test')
import IdePurescript.Tokens (identPart, modulePart, moduleRegex)
import PscIde (NET, listAvailableModules)
import PscIde.Command (CompletionOptions(..), ModuleList(..), TypeInfo(..))

type ModuleInfo =
  { modules :: Array String
  , getQualifiedModule :: String -> Array String
  , mainModule :: Maybe String
  , importedModules :: Array String
  }

data SuggestionType = Module | Type | Function | Value

explicitImportRegex :: Either String Regex
explicitImportRegex = regex ("""^import\s+""" <> modulePart <> """\s+\([^)]*?""" <> identPart <> "$") noFlags

getModuleSuggestions :: forall eff. Int -> String -> Aff (net :: NET | eff) (Array String)
getModuleSuggestions port prefix = do
  list <- eitherToErr $ listAvailableModules port
  pure $ case list of
    (ModuleList lst) -> filter (\m -> indexOf (Pattern prefix) m == Just 0) lst

data SuggestionResult =
  ModuleSuggestion { text :: String, suggestType :: SuggestionType, prefix :: String }
  | IdentSuggestion { origMod :: String, exportMod :: String, exportedFrom :: Array String, identifier :: String, qualifier :: Maybe String, valueType :: String, suggestType :: SuggestionType, prefix :: String, documentation :: Maybe String }

getSuggestions :: forall eff. Int -> {
    line :: String,
    moduleInfo :: ModuleInfo,
    groupCompletions :: Boolean,
    maxResults :: Maybe Int,
    preferredModules :: Array String
  } -> Aff (net :: NET | eff) (Array SuggestionResult)
getSuggestions port
    { line
    , moduleInfo: { modules, getQualifiedModule, mainModule, importedModules }
    , maxResults
    , groupCompletions
    , preferredModules
    } =
  if moduleExplicit then
    case match' explicitImportRegex line of
      Just [ Just _, Just mod, Just token ] -> do
        completions <- getCompletion port token mainModule Nothing [ mod ] getQualifiedModule opts
        pure $ map (result (Just mod) token) completions
      _ -> pure []
  else
    case parsed of
      Just { mod, token } ->
        if moduleCompletion then do
          let prefix = getModuleName (fromMaybe "" mod) token
          completions <- getModuleSuggestions port prefix
          pure $ map (modResult prefix) completions
        else do
          completions <- getCompletion port token mainModule mod ("Prim":modules) getQualifiedModule opts
          pure $ map (result mod token) completions
      Nothing -> pure []
    where
    opts = CompletionOptions { maxResults, groupReexports: groupCompletions }

    getModuleName "" token  = token
    getModuleName mod token = mod <> "." <> token

    isImport = indexOf (Pattern "import") line == Just 0
    hasBracket = indexOf (Pattern "(") line /= Nothing
    moduleCompletion = isImport && not hasBracket
    moduleExplicit = isImport && hasBracket

    parsed = case match' moduleRegex line of
        Just [ Just _, mod, tok ] | mod /= Nothing || tok /= Nothing ->
          Just { mod, token: fromMaybe "" tok}
        _ -> Nothing

    modResult prefix moduleName = ModuleSuggestion { text: moduleName, suggestType: Module, prefix }
    result qualifier prefix (TypeInfo {type', identifier, module': origMod, exportedFrom, documentation }) =
      IdentSuggestion { origMod, exportMod, identifier, qualifier, suggestType, prefix, valueType: type', exportedFrom, documentation }
      where
        suggestType =
          if contains (Pattern "->") type' then Function
          else if test' (regex "^[A-Z]" noFlags) identifier then Type
          else Value

        -- Strategies for picking the re-export to choose
        -- 1. Existing imports
        -- 2. User configuration of preferred modules (ordered list)
        -- 3. Re-export from a prefix named module (e.g. Foo.Bar.Baz reexported from Foo.Bar) shortest first
        -- 4. Original module (if none of the previous rules apply, there are no re-exports, or either grouping
        --    is disabled or compiler version does not support it)
        exportMod = fromMaybe origMod (existingModule <|> preferredModule <|> prefixModule)
        existingModule = head $ intersect importedModules exportedFrom
        preferredModule = head $ intersect preferredModules exportedFrom
        prefixModule = head $
          sortBy (\a b -> length a `compare` length b) $
          filter (\m -> startsWith (m <> ".") origMod) exportedFrom


fillRect, strokeRect

fillRect, strokeRect

module Graphics.Canvas.Free
  ( Graphics()
  , GraphicsF()

  , setLineWidth
  , setFillStyle
  , setStrokeStyle
  , setShadowColor
  , setShadowBlur
  , setShadowOffsetX
  , setShadowOffsetY
  , setLineCap
  , setComposite
  , setAlpha

  , beginPath
  , stroke
  , fill
  , clip
  , lineTo
  , moveTo
  , closePath

  , arc
  , rect
  , fillRect
  , strokeRect
  , clearRect

  , scale
  , rotate
  , translate
  , transform

  , textAlign
  , setTextAlign
  , font
  , setFont
  , fillText
  , strokeText
  , measureText

  , save
  , restore

  , getImageData
  , putImageData
  , putImageDataFull
  , createImageData
  , createImageDataCopy

  , runGraphics
  ) where

import Control.Monad.Eff
import Control.Monad.Free
import Data.Coyoneda

import qualified Graphics.Canvas as C

data GraphicsF more
  = SetLineWidth         Number      more
  | SetFillStyle         String      more
  | SetStrokeStyle       String      more
  | SetShadowColor       String      more
  | SetShadowBlur        Number      more
  | SetShadowOffsetX     Number      more
  | SetShadowOffsetY     Number      more
  | SetLineCap           C.LineCap   more
  | SetComposite         C.Composite more
  | SetAlpha             Number      more
  | BeginPath            more
  | Stroke               more
  | Fill                 more
  | Clip                 more
  | LineTo               Number      Number      more
  | MoveTo               Number      Number      more
  | ClosePath            more
  | Arc                  C.Arc       more
  | Rect                 C.Rectangle more
  | FillRect             C.Rectangle more
  | StrokeRect           C.Rectangle more
  | ClearRect            C.Rectangle more
  | Scale                Number      Number      more
  | Rotate               Number      more
  | Translate            Number      Number      more
  | Transform            C.Transform more
  | TextAlign            (C.TextAlign -> more)
  | SetTextAlign         C.TextAlign more
  | Font                 (String -> more)
  | SetFont              String      more
  | FillText             String      Number      Number    more
  | StrokeText           String      Number      Number    more
  | MeasureText          String      (C.TextMetrics -> more)
  | Save                 more
  | Restore              more
  | GetImageData         Number      Number      Number    Number   (C.ImageData -> more)
  | PutImageData         C.ImageData Number      Number    more
  | PutImageDataFull     C.ImageData Number      Number    Number   Number  Number  Number  more
  | CreateImageData      Number      Number      more
  | CreateImageDataCopy  C.ImageData (C.ImageData -> more)

type Graphics a = FreeC GraphicsF a

setLineWidth :: Number -> Graphics Unit
setLineWidth w = liftFC $ SetLineWidth w unit

setFillStyle :: String -> Graphics Unit
setFillStyle s = liftFC $ SetFillStyle s unit

setStrokeStyle :: String -> Graphics Unit
setStrokeStyle s = liftFC $ SetStrokeStyle s unit

setShadowColor :: String -> Graphics Unit
setShadowColor c = liftFC $ SetShadowColor c unit

setShadowBlur :: Number -> Graphics Unit
setShadowBlur n = liftFC $ SetShadowBlur n unit

setShadowOffsetX :: Number -> Graphics Unit
setShadowOffsetX n = liftFC $ SetShadowOffsetX n unit

setShadowOffsetY :: Number -> Graphics Unit
setShadowOffsetY n = liftFC $ SetShadowOffsetY n unit

setLineCap :: C.LineCap -> Graphics Unit
setLineCap lc = liftFC $ SetLineCap lc unit

setComposite :: C.Composite -> Graphics Unit
setComposite c = liftFC $ SetComposite c unit

setAlpha :: Number -> Graphics Unit
setAlpha a = liftFC $ SetAlpha a unit

beginPath :: Graphics Unit
beginPath = liftFC $ BeginPath unit

stroke :: Graphics Unit
stroke = liftFC $ Stroke unit

fill :: Graphics Unit
fill = liftFC $ Fill unit

clip :: Graphics Unit
clip = liftFC $ Clip unit

lineTo :: Number -> Number -> Graphics Unit
lineTo x y = liftFC $ LineTo x y unit

moveTo :: Number -> Number -> Graphics Unit
moveTo x y = liftFC $ MoveTo x y unit

closePath :: Graphics Unit
closePath = liftFC $ ClosePath unit

arc :: C.Arc -> Graphics Unit
arc a = liftFC $ Arc a unit

rect :: C.Rectangle -> Graphics Unit
rect r = liftFC $ Rect r unit

fillRect :: C.Rectangle -> Graphics Unit
fillRect r = liftFC $ FillRect r unit

strokeRect :: C.Rectangle -> Graphics Unit
strokeRect r = liftFC $ StrokeRect r unit

clearRect :: C.Rectangle -> Graphics Unit
clearRect r = liftFC $ ClearRect r unit

scale :: Number -> Number -> Graphics Unit
scale sx sy = liftFC $ Scale sx sy unit

rotate :: Number -> Graphics Unit
rotate th = liftFC $ Rotate th unit

translate :: Number -> Number -> Graphics Unit
translate tx ty = liftFC $ Translate tx ty unit

transform :: C.Transform -> Graphics Unit
transform tx = liftFC $ Transform tx unit

textAlign :: Graphics C.TextAlign
textAlign = liftFC $ TextAlign id

setTextAlign :: C.TextAlign -> Graphics Unit
setTextAlign ta = liftFC $ SetTextAlign ta unit

font :: Graphics String
font = liftFC $ Font id

setFont :: String -> Graphics Unit
setFont f = liftFC $ SetFont f unit

fillText :: String -> Number -> Number -> Graphics Unit
fillText s x y = liftFC $ FillText s x y unit

strokeText :: String -> Number -> Number -> Graphics Unit
strokeText s x y = liftFC $ StrokeText s x y unit

measureText :: String -> Graphics C.TextMetrics
measureText s = liftFC $ MeasureText s id

save :: Graphics Unit
save = liftFC $ Save unit

restore :: Graphics Unit
restore = liftFC $ Restore unit

getImageData :: Number -> Number -> Number -> Number -> Graphics C.ImageData
getImageData x y w h = liftFC $ GetImageData x y w h id

putImageData :: C.ImageData -> Number -> Number -> Graphics Unit
putImageData d x y = liftFC $ PutImageData d x y unit

putImageDataFull :: C.ImageData -> Number -> Number -> Number -> Number -> Number -> Number -> Graphics Unit
putImageDataFull d x y dx dy dw dh = liftFC $ PutImageDataFull d x y dx dy dw dh unit

createImageData :: Number -> Number -> Graphics Unit
createImageData w h = liftFC $ CreateImageData w h unit

createImageDataCopy :: C.ImageData -> Graphics C.ImageData
createImageDataCopy d = liftFC $ CreateImageDataCopy d id

runGraphics :: forall a eff. C.Context2D -> Graphics a -> Eff (canvas :: C.Canvas | eff) a
runGraphics ctx = runFreeCM interp
  where
  interp :: forall eff. Natural GraphicsF (Eff (canvas :: C.Canvas | eff))
  interp (SetLineWidth w a)                     = const a <$> C.setLineWidth w ctx
  interp (SetFillStyle s a)                     = const a <$> C.setFillStyle s ctx
  interp (SetStrokeStyle s a)                   = const a <$> C.setStrokeStyle s ctx
  interp (SetShadowColor c a)                   = const a <$> C.setShadowColor c ctx
  interp (SetShadowBlur n a)                    = const a <$> C.setShadowBlur n ctx
  interp (SetShadowOffsetX n a)                 = const a <$> C.setShadowOffsetX n ctx
  interp (SetShadowOffsetY n a)                 = const a <$> C.setShadowOffsetY n ctx
  interp (SetLineCap lc a)                      = const a <$> C.setLineCap lc ctx
  interp (SetComposite c a)                     = const a <$> C.setGlobalCompositeOperation ctx c
  interp (SetAlpha s a)                         = const a <$> C.setGlobalAlpha ctx s
  interp (BeginPath a)                          = const a <$> C.beginPath ctx
  interp (Stroke a)                             = const a <$> C.stroke ctx
  interp (Fill a)                               = const a <$> C.fill ctx
  interp (Clip a)                               = const a <$> C.clip ctx
  interp (LineTo x y a)                         = const a <$> C.lineTo ctx x y
  interp (MoveTo x y a)                         = const a <$> C.moveTo ctx x y
  interp (ClosePath a)                          = const a <$> C.closePath ctx
  interp (Arc arc a)                            = const a <$> C.arc ctx arc
  interp (Rect r a)                             = const a <$> C.rect ctx r
  interp (FillRect r a)                         = const a <$> C.fillRect ctx r
  interp (StrokeRect r a)                       = const a <$> C.strokeRect ctx r
  interp (ClearRect r a)                        = const a <$> C.clearRect ctx r
  interp (Scale sx sy a)                        = const a <$> C.scale { scaleX: sx, scaleY: sy } ctx
  interp (Rotate th a)                          = const a <$> C.rotate th ctx
  interp (Translate tx ty a)                    = const a <$> C.translate { translateX: tx, translateY: ty } ctx
  interp (Transform tx a)                       = const a <$> C.transform tx ctx
  interp (TextAlign k)                          = k <$> C.textAlign ctx
  interp (SetTextAlign ta a)                    = const a <$> C.setTextAlign ctx ta
  interp (Font k)                               = k <$> C.font ctx
  interp (SetFont f a)                          = const a <$> C.setFont f ctx
  interp (FillText s x y a)                     = const a <$> C.fillText ctx s x y
  interp (StrokeText s x y a)                   = const a <$> C.strokeText ctx s x y
  interp (MeasureText s k)                      = k <$> C.measureText ctx s
  interp (Save a)                               = const a <$> C.save ctx
  interp (Restore a)                            = const a <$> C.restore ctx
  interp (GetImageData x y w h k)               = k <$> C.getImageData ctx x y w h
  interp (PutImageData d x y a)                 = const a <$> C.putImageData ctx d x y
  interp (PutImageDataFull d x y dx dy dw dh a) = const a <$> C.putImageDataFull ctx d x y dx dy dw dh
  interp (CreateImageData w h a)                = const a <$> C.createImageData ctx w h
  interp (CreateImageDataCopy d k)              = k <$> C.createImageDataCopy ctx d

module Graphics.Canvas.Free
  ( Graphics()
  , GraphicsF()

  , setLineWidth
  , setFillStyle
  , setStrokeStyle
  , setShadowColor
  , setShadowBlur
  , setShadowOffsetX
  , setShadowOffsetY
  , setLineCap
  , setComposite
  , setAlpha

  , beginPath
  , stroke
  , fill
  , clip
  , lineTo
  , moveTo
  , closePath

  , arc
  , rect
  , clearRect

  , scale
  , rotate
  , translate
  , transform

  , textAlign
  , setTextAlign
  , font
  , setFont
  , fillText
  , strokeText
  , measureText

  , save
  , restore

  , getImageData
  , putImageData
  , putImageDataFull
  , createImageData
  , createImageDataCopy

  , runGraphics
  ) where

import Control.Monad.Eff
import Control.Monad.Free
import Data.Coyoneda

import qualified Graphics.Canvas as C

data GraphicsF more
  = SetLineWidth         Number      more
  | SetFillStyle         String      more
  | SetStrokeStyle       String      more
  | SetShadowColor       String      more
  | SetShadowBlur        Number      more
  | SetShadowOffsetX     Number      more
  | SetShadowOffsetY     Number      more
  | SetLineCap           C.LineCap   more
  | SetComposite         C.Composite more
  | SetAlpha             Number      more
  | BeginPath            more
  | Stroke               more
  | Fill                 more
  | Clip                 more
  | LineTo               Number      Number      more
  | MoveTo               Number      Number      more
  | ClosePath            more
  | Arc                  C.Arc       more
  | Rect                 C.Rectangle more
  | ClearRect            C.Rectangle more
  | Scale                Number      Number      more
  | Rotate               Number      more
  | Translate            Number      Number      more
  | Transform            C.Transform more
  | TextAlign            (C.TextAlign -> more)
  | SetTextAlign         C.TextAlign more
  | Font                 (String -> more)
  | SetFont              String      more
  | FillText             String      Number      Number    more
  | StrokeText           String      Number      Number    more
  | MeasureText          String      (C.TextMetrics -> more)
  | Save                 more
  | Restore              more
  | GetImageData         Number      Number      Number    Number   (C.ImageData -> more)
  | PutImageData         C.ImageData Number      Number    more
  | PutImageDataFull     C.ImageData Number      Number    Number   Number  Number  Number  more
  | CreateImageData      Number      Number      more
  | CreateImageDataCopy  C.ImageData (C.ImageData -> more)

type Graphics a = FreeC GraphicsF a

setLineWidth :: Number -> Graphics Unit
setLineWidth w = liftFC $ SetLineWidth w unit

setFillStyle :: String -> Graphics Unit
setFillStyle s = liftFC $ SetFillStyle s unit

setStrokeStyle :: String -> Graphics Unit
setStrokeStyle s = liftFC $ SetStrokeStyle s unit

setShadowColor :: String -> Graphics Unit
setShadowColor c = liftFC $ SetShadowColor c unit

setShadowBlur :: Number -> Graphics Unit
setShadowBlur n = liftFC $ SetShadowBlur n unit

setShadowOffsetX :: Number -> Graphics Unit
setShadowOffsetX n = liftFC $ SetShadowOffsetX n unit

setShadowOffsetY :: Number -> Graphics Unit
setShadowOffsetY n = liftFC $ SetShadowOffsetY n unit

setLineCap :: C.LineCap -> Graphics Unit
setLineCap lc = liftFC $ SetLineCap lc unit

setComposite :: C.Composite -> Graphics Unit
setComposite c = liftFC $ SetComposite c unit

setAlpha :: Number -> Graphics Unit
setAlpha a = liftFC $ SetAlpha a unit

beginPath :: Graphics Unit
beginPath = liftFC $ BeginPath unit

stroke :: Graphics Unit
stroke = liftFC $ Stroke unit

fill :: Graphics Unit
fill = liftFC $ Fill unit

clip :: Graphics Unit
clip = liftFC $ Clip unit

lineTo :: Number -> Number -> Graphics Unit
lineTo x y = liftFC $ LineTo x y unit

moveTo :: Number -> Number -> Graphics Unit
moveTo x y = liftFC $ MoveTo x y unit

closePath :: Graphics Unit
closePath = liftFC $ ClosePath unit

arc :: C.Arc -> Graphics Unit
arc a = liftFC $ Arc a unit

rect :: C.Rectangle -> Graphics Unit
rect r = liftFC $ Rect r unit

clearRect :: C.Rectangle -> Graphics Unit
clearRect r = liftFC $ ClearRect r unit

scale :: Number -> Number -> Graphics Unit
scale sx sy = liftFC $ Scale sx sy unit

rotate :: Number -> Graphics Unit
rotate th = liftFC $ Rotate th unit

translate :: Number -> Number -> Graphics Unit
translate tx ty = liftFC $ Translate tx ty unit

transform :: C.Transform -> Graphics Unit
transform tx = liftFC $ Transform tx unit

textAlign :: Graphics C.TextAlign
textAlign = liftFC $ TextAlign id

setTextAlign :: C.TextAlign -> Graphics Unit
setTextAlign ta = liftFC $ SetTextAlign ta unit

font :: Graphics String
font = liftFC $ Font id

setFont :: String -> Graphics Unit
setFont f = liftFC $ SetFont f unit

fillText :: String -> Number -> Number -> Graphics Unit
fillText s x y = liftFC $ FillText s x y unit

strokeText :: String -> Number -> Number -> Graphics Unit
strokeText s x y = liftFC $ StrokeText s x y unit

measureText :: String -> Graphics C.TextMetrics
measureText s = liftFC $ MeasureText s id

save :: Graphics Unit
save = liftFC $ Save unit

restore :: Graphics Unit
restore = liftFC $ Restore unit

getImageData :: Number -> Number -> Number -> Number -> Graphics C.ImageData
getImageData x y w h = liftFC $ GetImageData x y w h id

putImageData :: C.ImageData -> Number -> Number -> Graphics Unit
putImageData d x y = liftFC $ PutImageData d x y unit

putImageDataFull :: C.ImageData -> Number -> Number -> Number -> Number -> Number -> Number -> Graphics Unit
putImageDataFull d x y dx dy dw dh = liftFC $ PutImageDataFull d x y dx dy dw dh unit

createImageData :: Number -> Number -> Graphics Unit
createImageData w h = liftFC $ CreateImageData w h unit

createImageDataCopy :: C.ImageData -> Graphics C.ImageData
createImageDataCopy d = liftFC $ CreateImageDataCopy d id

runGraphics :: forall a eff. C.Context2D -> Graphics a -> Eff (canvas :: C.Canvas | eff) a
runGraphics ctx = runFreeCM interp
  where
  interp :: forall eff. Natural GraphicsF (Eff (canvas :: C.Canvas | eff))
  interp (SetLineWidth w a)                     = const a <$> C.setLineWidth w ctx
  interp (SetFillStyle s a)                     = const a <$> C.setFillStyle s ctx
  interp (SetStrokeStyle s a)                   = const a <$> C.setStrokeStyle s ctx
  interp (SetShadowColor c a)                   = const a <$> C.setShadowColor c ctx
  interp (SetShadowBlur n a)                    = const a <$> C.setShadowBlur n ctx
  interp (SetShadowOffsetX n a)                 = const a <$> C.setShadowOffsetX n ctx
  interp (SetShadowOffsetY n a)                 = const a <$> C.setShadowOffsetY n ctx
  interp (SetLineCap lc a)                      = const a <$> C.setLineCap lc ctx
  interp (SetComposite c a)                     = const a <$> C.setGlobalCompositeOperation ctx c
  interp (SetAlpha s a)                         = const a <$> C.setGlobalAlpha ctx s
  interp (BeginPath a)                          = const a <$> C.beginPath ctx
  interp (Stroke a)                             = const a <$> C.stroke ctx
  interp (Fill a)                               = const a <$> C.fill ctx
  interp (Clip a)                               = const a <$> C.clip ctx
  interp (LineTo x y a)                         = const a <$> C.lineTo ctx x y
  interp (MoveTo x y a)                         = const a <$> C.moveTo ctx x y
  interp (ClosePath a)                          = const a <$> C.closePath ctx
  interp (Arc arc a)                            = const a <$> C.arc ctx arc
  interp (Rect r a)                             = const a <$> C.rect ctx r
  interp (ClearRect r a)                        = const a <$> C.clearRect ctx r
  interp (Scale sx sy a)                        = const a <$> C.scale { scaleX: sx, scaleY: sy } ctx
  interp (Rotate th a)                          = const a <$> C.rotate th ctx
  interp (Translate tx ty a)                    = const a <$> C.translate { translateX: tx, translateY: ty } ctx
  interp (Transform tx a)                       = const a <$> C.transform tx ctx
  interp (TextAlign k)                          = k <$> C.textAlign ctx
  interp (SetTextAlign ta a)                    = const a <$> C.setTextAlign ctx ta
  interp (Font k)                               = k <$> C.font ctx
  interp (SetFont f a)                          = const a <$> C.setFont f ctx
  interp (FillText s x y a)                     = const a <$> C.fillText ctx s x y
  interp (StrokeText s x y a)                   = const a <$> C.strokeText ctx s x y
  interp (MeasureText s k)                      = k <$> C.measureText ctx s
  interp (Save a)                               = const a <$> C.save ctx
  interp (Restore a)                            = const a <$> C.restore ctx
  interp (GetImageData x y w h k)               = k <$> C.getImageData ctx x y w h
  interp (PutImageData d x y a)                 = const a <$> C.putImageData ctx d x y
  interp (PutImageDataFull d x y dx dy dw dh a) = const a <$> C.putImageDataFull ctx d x y dx dy dw dh
  interp (CreateImageData w h a)                = const a <$> C.createImageData ctx w h
  interp (CreateImageDataCopy d k)              = k <$> C.createImageDataCopy ctx d