Added the extended operations map

Added the extended operations map

module OpCodeMap where

import Prelude

import Types
import Ops
import Utils

--Tried to use typeclasses, but was forced to turn all my type synonyms
--to 'newtypes' which will require writing a specialised function for each
--case to convert from the type synonyms to the newtypes which will beat
--the purpose of using a typeclass in the first place (lets me have function
--overload in this case).
rr2op :: (Regs -> Regs) -> Z80State -> Z80State
rr2op rr state@{mem=mem@{regs}} = state { mem = mem { regs = rr regs } }

mr2op :: (Mem -> Regs) -> Z80State -> Z80State
mr2op mr state@{mem=mem@{regs}} = state { mem = mem { regs = mr mem } }

mm2op :: (Mem -> Mem) -> Z80State -> Z80State
mm2op mm state@{mem=mem@{regs}} = state { mem = mm mem }

basicOps :: Array (Z80State -> Z80State)
basicOps =
                                            -- 0x
  [ rr2op $ nop                             -- NOP
  , mr2op $ ldTwoRegsFromImm setB setC      -- LD BC,nn
  , mm2op $ ldMem2RFromReg b c a            -- LD (BC),A
  , rr2op $ incRegWithCarry b c setB setC   -- INC BC

  , rr2op $ incReg b setB                   -- INC B
  , rr2op $ decReg b setB                   -- DEC B
  , mr2op $ ldRegFromImm setB               -- LD B,n
  , rr2op $ rotA Left true                  -- RLC A

  , mm2op $ ldMemImmFromSP                  -- LD (nn),SP
  , rr2op $ add2RegsToHL b c                -- ADD HL,BC
  , mr2op $ ldRegFromMem2R setA b c         -- LD A,(BC)
  , rr2op $ decRegWithCarry b c setB setC   -- DEC BC

  , rr2op $ incReg c setC                   -- INC C
  , rr2op $ decReg c setC                   -- DEC C
  , mr2op $ ldRegFromImm setC               -- LD C,n
  , rr2op $ rotA Right true                 -- RRC A

                                            -- 1x
  , stop                                    -- STOP
  , mr2op $ ldTwoRegsFromImm setD setE      -- LD DE,nn
  , mm2op $ ldMem2RFromReg d e a            -- LD (DE),A
  , rr2op $ incRegWithCarry d e setD setE   -- INC DE

  , rr2op $ incReg d setD                   -- INC D
  , rr2op $ decReg d setD                   -- DEC D
  , mr2op $ ldRegFromImm setD               -- LD D,n
  , rr2op $ rotA Left false                 -- RL A

  , mr2op $ jumpRelImm                      -- JR n
  , rr2op $ add2RegsToHL d e                -- ADD HL,DE
  , mr2op $ ldRegFromMem2R setA d e         -- LD A,(DE)
  , rr2op $ decRegWithCarry d e setD setE   -- DEC DE

  , rr2op $ incReg e setE                   -- INC E
  , rr2op $ decReg e setE                   -- DEC E
  , mr2op $ ldRegFromImm setE               -- LD E,n
  , rr2op $ rotA Right false                -- RR A

                                            -- 2x
  , mr2op $ jumpRelImmFlag true zeroFlag    -- JR NZ,n
  , mr2op $ ldTwoRegsFromImm setH setL      -- LD HL,nn
  , mm2op $ ldMemHLFromRegInc a             -- LDI (HL),A
  , rr2op $ incRegWithCarry h l setH setL   -- INC HL

  , rr2op $ incReg h setH                   -- INC H
  , rr2op $ decReg h setH                   -- DEC H
  , mr2op $ ldRegFromImm setH               -- LD H,n
  , rr2op $ adjAForBCDAdd                   -- DAA

  , mr2op $ jumpRelImmFlag false zeroFlag   -- JR Z,n
  , rr2op $ add2RegsToHL h l                -- ADD HL,HL
  , mr2op $ ldRegFromMemHLInc setA          -- LDI A,(HL)
  , rr2op $ decRegWithCarry h l setH setL   -- DEC HL

  , rr2op $ incReg l setL                   -- INC L
  , rr2op $ decReg l setL                   -- DEC L
  , mr2op $ ldRegFromImm setL               -- LD L,n
  , rr2op $ cmplA                           -- CPL

                                            -- 3x
  , mr2op $ jumpRelImmFlag true carryFlag   -- JR NC,n
  , mr2op $ ldSPFromImm                     -- LD SP,nn
  , mm2op $ ldMemHLFromRegDec a             -- LDD (HL),A
  , rr2op $ incSP                           -- INC SP

  , mm2op $ incHLMem                        -- INC (HL)
  , mm2op $ decHLMem                        -- DEC (HL)
  , mm2op $ ldMemHLFromImm                  -- LD (HL),n
  , rr2op $ setCarryFlag                    -- SCF

  , mr2op $ jumpRelImmFlag false carryFlag  -- JR C,n
  , rr2op $ addSPToHL                       -- ADD HL,SP
  , mr2op $ ldRegFromMemHLDec setA          -- LDD A,(HL)
  , rr2op $ decSP                           -- DEC SP

  , rr2op $ incReg a setA                   -- INC A
  , rr2op $ decReg a setA                   -- DEC A
  , mr2op $ ldRegFromImm setA               -- LD A,n
  , rr2op $ clearCarryFlag                  -- CCF

                                            -- 4x
  , rr2op $ ldRegFromReg setB b             -- LD B,B
  , rr2op $ ldRegFromReg setB c             -- LD B,C
  , rr2op $ ldRegFromReg setB d             -- LD B,D
  , rr2op $ ldRegFromReg setB e             -- LD B,E

  , rr2op $ ldRegFromReg setB h             -- LD B,H
  , rr2op $ ldRegFromReg setB l             -- LD B,L
  , mr2op $ ldRegFromMem2R setB h l         -- LD B,(HL)
  , rr2op $ ldRegFromReg setB a             -- LD B,A

  , rr2op $ ldRegFromReg setC b             -- LD C,B
  , rr2op $ ldRegFromReg setC c             -- LD C,C
  , rr2op $ ldRegFromReg setC d             -- LD C,D
  , rr2op $ ldRegFromReg setC e             -- LD C,E

  , rr2op $ ldRegFromReg setC h             -- LD C,H
  , rr2op $ ldRegFromReg setC l             -- LD C,L
  , mr2op $ ldRegFromMem2R setC h l         -- LD C,(HL)
  , rr2op $ ldRegFromReg setC a             -- LD C,A

                                            -- 5x
  , rr2op $ ldRegFromReg setD b             -- LD D,B
  , rr2op $ ldRegFromReg setD c             -- LD D,C
  , rr2op $ ldRegFromReg setD d             -- LD D,D
  , rr2op $ ldRegFromReg setD e             -- LD D,E

  , rr2op $ ldRegFromReg setD h             -- LD D,H
  , rr2op $ ldRegFromReg setD l             -- LD D,L
  , mr2op $ ldRegFromMem2R setD h l         -- LD D,(HL)
  , rr2op $ ldRegFromReg setD a             -- LD D,A

  , rr2op $ ldRegFromReg setE b             -- LD E,B
  , rr2op $ ldRegFromReg setE c             -- LD E,C
  , rr2op $ ldRegFromReg setE d             -- LD E,D
  , rr2op $ ldRegFromReg setE e             -- LD E,E

  , rr2op $ ldRegFromReg setE h             -- LD E,H
  , rr2op $ ldRegFromReg setE l             -- LD E,L
  , mr2op $ ldRegFromMem2R setE h l         -- LD E,(HL)
  , rr2op $ ldRegFromReg setE a             -- LD E,A

                                            -- 6x
  , rr2op $ ldRegFromReg setH b             -- LD H,B
  , rr2op $ ldRegFromReg setH c             -- LD H,C
  , rr2op $ ldRegFromReg setH d             -- LD H,D
  , rr2op $ ldRegFromReg setH e             -- LD H,E

  , rr2op $ ldRegFromReg setH h             -- LD H,H
  , rr2op $ ldRegFromReg setH l             -- LD H,L
  , mr2op $ ldRegFromMem2R setH h l         -- LD H,(HL)
  , rr2op $ ldRegFromReg setH a             -- LD H,A

  , rr2op $ ldRegFromReg setL b             -- LD L,B
  , rr2op $ ldRegFromReg setL c             -- LD L,C
  , rr2op $ ldRegFromReg setL d             -- LD L,D
  , rr2op $ ldRegFromReg setL e             -- LD L,E

  , rr2op $ ldRegFromReg setL h             -- LD L,H
  , rr2op $ ldRegFromReg setL l             -- LD L,L
  , mr2op $ ldRegFromMem2R setL h l         -- LD L,(HL)
  , rr2op $ ldRegFromReg setL a             -- LD L,A

                                            -- 7x
  , mm2op $ ldMem2RFromReg h l b            -- LD (HL),B
  , mm2op $ ldMem2RFromReg h l c            -- LD (HL),C
  , mm2op $ ldMem2RFromReg h l d            -- LD (HL),D
  , mm2op $ ldMem2RFromReg h l e            -- LD (HL),E

  , mm2op $ ldMem2RFromReg h l h            -- LD (HL),H
  , mm2op $ ldMem2RFromReg h l l            -- LD (HL),L
  , halt                                    -- HALT
  , mm2op $ ldMem2RFromReg h l a            -- LD (HL),A

  , rr2op $ ldRegFromReg setA b             -- LD A,B
  , rr2op $ ldRegFromReg setA c             -- LD A,C
  , rr2op $ ldRegFromReg setA d             -- LD A,D
  , rr2op $ ldRegFromReg setA e             -- LD A,E

  , rr2op $ ldRegFromReg setA h             -- LD A,H
  , rr2op $ ldRegFromReg setA l             -- LD A,L
  , mr2op $ ldRegFromMem2R setA h l         -- LD A,(HL)
  , rr2op $ ldRegFromReg setA a             -- LD A,A

                                            -- 8x
  , rr2op $ addRegToA b                     -- ADD A,B
  , rr2op $ addRegToA c                     -- ADD A,C
  , rr2op $ addRegToA d                     -- ADD A,D
  , rr2op $ addRegToA e                     -- ADD A,E

  , rr2op $ addRegToA h                     -- ADD A,H
  , rr2op $ addRegToA l                     -- ADD A,L
  , mr2op $ addHLMemToA                     -- ADD A,(HL)
  , rr2op $ addRegToA a                     -- ADD A,A

  , rr2op $ addRegCarryToA b                -- ADC A,B
  , rr2op $ addRegCarryToA c                -- ADC A,C
  , rr2op $ addRegCarryToA d                -- ADC A,D
  , rr2op $ addRegCarryToA e                -- ADC A,E

  , rr2op $ addRegCarryToA h                -- ADC A,H
  , rr2op $ addRegCarryToA l                -- ADC A,L
  , mr2op $ addHLMemCarryToA                -- ADC A,(HL)
  , rr2op $ addRegCarryToA a                -- ADC A,A

                                            -- 9x
  , rr2op $ subRegFromA b                   -- SUB A,B
  , rr2op $ subRegFromA c                   -- SUB A,C
  , rr2op $ subRegFromA d                   -- SUB A,D
  , rr2op $ subRegFromA e                   -- SUB A,E

  , rr2op $ subRegFromA h                   -- SUB A,H
  , rr2op $ subRegFromA l                   -- SUB A,L
  , mr2op $ subHLMemFromA                   -- SUB A,(HL)
  , rr2op $ subRegFromA a                   -- SUB A,A

  , rr2op $ subRegCarryFromA b              -- SBC A,B
  , rr2op $ subRegCarryFromA c              -- SBC A,C
  , rr2op $ subRegCarryFromA d              -- SBC A,D
  , rr2op $ subRegCarryFromA e              -- SBC A,E

  , rr2op $ subRegCarryFromA h              -- SBC A,H
  , rr2op $ subRegCarryFromA l              -- SBC A,L
  , mr2op $ subHLMemCarryFromA              -- SBC A,(HL)
  , rr2op $ subRegCarryFromA a              -- SBC A,A

                                            -- Ax
  , rr2op $ andOpRegIntoA b                 -- AND B
  , rr2op $ andOpRegIntoA c                 -- AND C
  , rr2op $ andOpRegIntoA d                 -- AND D
  , rr2op $ andOpRegIntoA e                 -- AND E

  , rr2op $ andOpRegIntoA h                 -- AND H
  , rr2op $ andOpRegIntoA l                 -- AND L
  , mr2op $ andOpHLMemIntoA                 -- AND (HL)
  , rr2op $ andOpRegIntoA a                 -- AND A

  , rr2op $ xorOpRegIntoA b                 -- XOR B
  , rr2op $ xorOpRegIntoA c                 -- XOR C
  , rr2op $ xorOpRegIntoA d                 -- XOR D
  , rr2op $ xorOpRegIntoA e                 -- XOR E

  , rr2op $ xorOpRegIntoA h                 -- XOR H
  , rr2op $ xorOpRegIntoA l                 -- XOR L
  , mr2op $ xorOpHLMemIntoA                 -- XOR (HL)
  , rr2op $ xorOpRegIntoA a                 -- XOR A

                                            -- Bx
  , rr2op $ orOpRegIntoA b                  -- OR B
  , rr2op $ orOpRegIntoA c                  -- OR C
  , rr2op $ orOpRegIntoA d                  -- OR D
  , rr2op $ orOpRegIntoA e                  -- OR E

  , rr2op $ orOpRegIntoA h                  -- OR H
  , rr2op $ orOpRegIntoA l                  -- OR L
  , mr2op $ orOpHLMemIntoA                  -- OR (HL)
  , rr2op $ orOpRegIntoA a                  -- OR A

  , rr2op $ compAToReg b                    -- CP B
  , rr2op $ compAToReg c                    -- CP C
  , rr2op $ compAToReg d                    -- CP D
  , rr2op $ compAToReg e                    -- CP E

  , rr2op $ compAToReg h                    -- CP H
  , rr2op $ compAToReg l                    -- CP L
  , mr2op $ compAToMemHL                    -- CP(HL)
  , rr2op $ compAToReg a                    -- CP A

                                            -- Cx
  , mr2op $ retFlag true zeroFlag           -- RET NZ
  , mr2op $ popReg setB setC                -- POP BC
  , mr2op $ jumpImmFlag true zeroFlag       -- JP NZ,nn
  , mr2op $ jumpImm                         -- JP nn

  , mm2op $ callImmFlag true zeroFlag       -- CALL NZ,nn
  , mm2op $ pushReg b c                     -- PUSH BC
  , mr2op $ addImmToA                       -- ADD A,n
  , mm2op $ callRoutine 0x00                -- RST 0

  , mr2op $ retFlag false zeroFlag          -- RET Z
  , mr2op $ ret                             -- RET
  , mr2op $ jumpImmFlag false zeroFlag      -- JP Z,nn
  , execExtOps extOps                       -- CB OpCode map

  , mm2op $ callImmFlag false zeroFlag      -- CALL Z,nn
  , mm2op $ callImm                         -- CALL nn
  , mr2op $ addImmCarryToA                  -- ADC A,n
  , mm2op $ callRoutine 0x08                -- RST 8

                                            -- Dx
  , mr2op $ retFlag true carryFlag          -- RET NC
  , mr2op $ popReg setD setE                -- POP DE
  , mr2op $ jumpImmFlag true carryFlag      -- JP NC,nn
  , invalidOpCode

  , mm2op $ callImmFlag true carryFlag      -- CALL NC,nn
  , mm2op $ pushReg d e                     -- PUSH DE
  , mr2op $ subImmFromA                     -- SUB A,n
  , mm2op $ callRoutine 0x10                -- RST 10

  , mr2op $ retFlag false carryFlag         -- RET C
  , mr2op $ retEnableInterrupt              -- RETI
  , mr2op $ jumpImmFlag false carryFlag     -- JP C,nn
  , invalidOpCode

  , mm2op $ callImmFlag true carryFlag      -- CALL C,nn
  , invalidOpCode
  , mr2op subImmCarryToA                    -- SBC A,n
  , mm2op $ callRoutine 0x18                -- RST 18

                                            -- Ex
  , mm2op $ ldFF00ImmMemFromReg a           -- LDH (n),A
  , mr2op $ popReg setH setL                -- POP HL
  , mm2op $ ldFF00CMemFromReg a             -- LDH (C),A
  , invalidOpCode

  , invalidOpCode
  , mm2op $ pushReg h l                     -- PUSH HL
  , mr2op andOpImmIntoA                     -- AND n
  , mm2op $ callRoutine 0x20                -- RST 20

  , mr2op addImmToSP                        -- ADD SP,d
  , rr2op jumpHL                            -- JP (HL)
  , mm2op ldMemImmFromRegA                  -- LD (nn),A
  , invalidOpCode

  , invalidOpCode
  , invalidOpCode
  , mr2op xorOpImmIntoA                     -- XOR n
  , mm2op $ callRoutine 0x28                -- RST 28

                                            -- Fx
  , mr2op $ ldRegFromFF00ImmMem setA        -- LDH A,(n)
  , mr2op $ popReg setA setF                -- POP AF
  , mr2op $ ldRegFromFF00CMem setA          -- LD A,(IOC)
  , rr2op $ setInterrupts false             -- DI

  , invalidOpCode
  , mm2op $ pushReg a f                     -- PUSH AF
  , mr2op orOpImmIntoA                      -- OR n
  , mm2op $ callRoutine 0x30                -- RST 30

  , mr2op ldHLFromSPImm                     -- LDHL SP,d
  , rr2op ldSPFromHL                        -- LD SP,HL
  , mr2op ldRegAFromMemImm                  -- LD A,(nn)
  , rr2op $ setInterrupts true              -- EI

  , invalidOpCode
  , invalidOpCode
  , mr2op compAToImm                        -- CP n
  , mm2op $ callRoutine 0x38                -- RST 38
]

extOps :: Array (Z80State -> Z80State)
extOps =
                                          -- 0x
  [ rr2op $ rotReg Left true setB b       -- RLC B
  , rr2op $ rotReg Left true setC c       -- RLC C
  , rr2op $ rotReg Left true setD d       -- RLC D
  , rr2op $ rotReg Left true setE e       -- RLC E

  , rr2op $ rotReg Left true setH h       -- RLC H
  , rr2op $ rotReg Left true setL l       -- RLC L
  , mm2op $ rotHLMem Left true            -- RLC (HL)
  , rr2op $ rotReg Left true setA a       -- RLC A

  , rr2op $ rotReg Right true setB b      -- RRC B
  , rr2op $ rotReg Right true setC c      -- RRC C
  , rr2op $ rotReg Right true setD d      -- RRC D
  , rr2op $ rotReg Right true setE e      -- RRC E

  , rr2op $ rotReg Right true setH h      -- RRC H
  , rr2op $ rotReg Right true setL l      -- RRC L
  , mm2op $ rotHLMem Right true           -- RRC (HL)
  , rr2op $ rotReg Right true setA a      -- RRC A

                                          -- 1x
  , rr2op $ rotReg Left false setB b      -- RL B
  , rr2op $ rotReg Left false setC c      -- RL C
  , rr2op $ rotReg Left false setD d      -- RL D
  , rr2op $ rotReg Left false setE e      -- RL E

  , rr2op $ rotReg Left false setH h      -- RL H
  , rr2op $ rotReg Left false setL l      -- RL L
  , mm2op $ rotHLMem Left false           -- RL (HL)
  , rr2op $ rotReg Left false setA a      -- RL A

  , rr2op $ rotReg Right false setB b     -- RR B
  , rr2op $ rotReg Right false setC c     -- RR C
  , rr2op $ rotReg Right false setD d     -- RR D
  , rr2op $ rotReg Right false setE e     -- RR E

  , rr2op $ rotReg Right false setH h     -- RR H
  , rr2op $ rotReg Right false setL l     -- RR L
  , mm2op $ rotHLMem Right false          -- RR(HL)
  , rr2op $ rotReg Right false setA a     -- RR A

                                          -- 2x
  , rr2op $ shiftReg Left false setB b    -- SLA B
  , rr2op $ shiftReg Left false setC c    -- SLA C
  , rr2op $ shiftReg Left false setD d    -- SLA D
  , rr2op $ shiftReg Left false setE e    -- SLA E

  , rr2op $ shiftReg Left false setH h    -- SLA H
  , rr2op $ shiftReg Left false setL l    -- SLA L
  , mm2op $ shiftMemHL Left false         -- SLA(HL)
  , rr2op $ shiftReg Left false setA a    -- SLA A

  , rr2op $ shiftReg Right true setB b    -- SRA B
  , rr2op $ shiftReg Right true setC c    -- SRA C
  , rr2op $ shiftReg Right true setD d    -- SRA D
  , rr2op $ shiftReg Right true setE e    -- SRA E

  , rr2op $ shiftReg Right true setH h    -- SRA H
  , rr2op $ shiftReg Right true setL l    -- SRA L
  , mm2op $ shiftMemHL Right true         -- SRA (HL)
  , rr2op $ shiftReg Right true setA a    -- SRA A

                                          -- 3x
  , rr2op $ swapReg setB b                -- SWAP B
  , rr2op $ swapReg setC c                -- SWAP C
  , rr2op $ swapReg setD d                -- SWAP D
  , rr2op $ swapReg setE e                -- SWAP E

  , rr2op $ swapReg setH h                -- SWAP H
  , rr2op $ swapReg setL l                -- SWAP L
  , mm2op $ swapMemHL                     -- SWAP(HL)
  , rr2op $ swapReg setA a                -- SWAP A

  , rr2op $ shiftReg Right false setB b   -- SRL B
  , rr2op $ shiftReg Right false setC c   -- SRL C
  , rr2op $ shiftReg Right false setD d   -- SRL D
  , rr2op $ shiftReg Right false setE e   -- SRL E

  , rr2op $ shiftReg Right false setH h   -- SRL H
  , rr2op $ shiftReg Right false setL l   -- SRL L
  , mm2op $ shiftMemHL Right false        -- SRL (HL)
  , rr2op $ shiftReg Right false setA a   -- SRL A

                                          -- 4x
  , rr2op $ testBitNOfReg 0 b             -- BIT 0,B
  , rr2op $ testBitNOfReg 0 c             -- BIT 0,C
  , rr2op $ testBitNOfReg 0 d             -- BIT 0,D
  , rr2op $ testBitNOfReg 0 e             -- BIT 0,E

  , rr2op $ testBitNOfReg 0 h             -- BIT 0,H
  , rr2op $ testBitNOfReg 0 l             -- BIT 0,L
  , mr2op $ testBitNOfHLMem 0             -- BIT 0,(HL)
  , rr2op $ testBitNOfReg 0 a             -- BIT 0,A

  , rr2op $ testBitNOfReg 1 b             -- BIT 1,B
  , rr2op $ testBitNOfReg 1 c             -- BIT 1,C
  , rr2op $ testBitNOfReg 1 d             -- BIT 1,D
  , rr2op $ testBitNOfReg 1 e             -- BIT 1,E

  , rr2op $ testBitNOfReg 1 h             -- BIT 1,H
  , rr2op $ testBitNOfReg 1 l             -- BIT 1,L
  , mr2op $ testBitNOfHLMem 1             -- BIT 1,(HL)
  , rr2op $ testBitNOfReg 1 a             -- BIT 1,A

                                          -- 5x
  , rr2op $ testBitNOfReg 2 b             -- BIT 2,B
  , rr2op $ testBitNOfReg 2 c             -- BIT 2,C
  , rr2op $ testBitNOfReg 2 d             -- BIT 2,D
  , rr2op $ testBitNOfReg 2 e             -- BIT 2,E

  , rr2op $ testBitNOfReg 2 h             -- BIT 2,H
  , rr2op $ testBitNOfReg 2 l             -- BIT 2,L
  , mr2op $ testBitNOfHLMem 2             -- BIT 2,(HL)
  , rr2op $ testBitNOfReg 2 a             -- BIT 2,A

  , rr2op $ testBitNOfReg 3 b             -- BIT 3,B
  , rr2op $ testBitNOfReg 3 c             -- BIT 3,C
  , rr2op $ testBitNOfReg 3 d             -- BIT 3,D
  , rr2op $ testBitNOfReg 3 e             -- BIT 3,E

  , rr2op $ testBitNOfReg 3 h             -- BIT 3,H
  , rr2op $ testBitNOfReg 3 l             -- BIT 3,L
  , mr2op $ testBitNOfHLMem 3             -- BIT 3,(HL)
  , rr2op $ testBitNOfReg 3 a             -- BIT 3,A

                                          -- 6x
  , rr2op $ testBitNOfReg 4 b             -- BIT 4,B
  , rr2op $ testBitNOfReg 4 c             -- BIT 4,C
  , rr2op $ testBitNOfReg 4 d             -- BIT 4,D
  , rr2op $ testBitNOfReg 4 e             -- BIT 4,E

  , rr2op $ testBitNOfReg 4 h             -- BIT 4,H
  , rr2op $ testBitNOfReg 4 l             -- BIT 4,L
  , mr2op $ testBitNOfHLMem 4             -- BIT 4,(HL)
  , rr2op $ testBitNOfReg 4 a             -- BIT 4,A

  , rr2op $ testBitNOfReg 5 b             -- BIT 5,B
  , rr2op $ testBitNOfReg 5 c             -- BIT 5,C
  , rr2op $ testBitNOfReg 5 d             -- BIT 5,D
  , rr2op $ testBitNOfReg 5 e             -- BIT 5,E

  , rr2op $ testBitNOfReg 5 h             -- BIT 5,H
  , rr2op $ testBitNOfReg 5 l             -- BIT 5,L
  , mr2op $ testBitNOfHLMem 5             -- BIT 5,(HL)
  , rr2op $ testBitNOfReg 5 a             -- BIT 5,A

                                          -- 7x
  , rr2op $ testBitNOfReg 6 b             -- BIT 6,B
  , rr2op $ testBitNOfReg 6 c             -- BIT 6,C
  , rr2op $ testBitNOfReg 6 d             -- BIT 6,D
  , rr2op $ testBitNOfReg 6 e             -- BIT 6,E

  , rr2op $ testBitNOfReg 6 h             -- BIT 6,H
  , rr2op $ testBitNOfReg 6 l             -- BIT 6,L
  , mr2op $ testBitNOfHLMem 6             -- BIT 6,(HL)
  , rr2op $ testBitNOfReg 6 a             -- BIT 6,A

  , rr2op $ testBitNOfReg 7 b             -- BIT 7,B
  , rr2op $ testBitNOfReg 7 c             -- BIT 7,C
  , rr2op $ testBitNOfReg 7 d             -- BIT 7,D
  , rr2op $ testBitNOfReg 7 e             -- BIT 7,E

  , rr2op $ testBitNOfReg 7 h             -- BIT 7,H
  , rr2op $ testBitNOfReg 7 l             -- BIT 7,L
  , mr2op $ testBitNOfHLMem 7             -- BIT 7,(HL)
  , rr2op $ testBitNOfReg 7 a             -- BIT 7,A

                                          -- 8x
  , rr2op $ setBitNOfReg false 0 setB b   -- RES 0,B
  , rr2op $ setBitNOfReg false 0 setC c   -- RES 0,C
  , rr2op $ setBitNOfReg false 0 setD d   -- RES 0,D
  , rr2op $ setBitNOfReg false 0 setE e   -- RES 0,E

  , rr2op $ setBitNOfReg false 0 setH h   -- RES 0,H
  , rr2op $ setBitNOfReg false 0 setL l   -- RES 0,L
  , mm2op $ setBitNOfHLMem false 0        -- RES 0,(HL)
  , rr2op $ setBitNOfReg false 0 setA a   -- RES 0,A

  , rr2op $ setBitNOfReg false 1 setB b   -- RES 1,B
  , rr2op $ setBitNOfReg false 1 setC c   -- RES 1,C
  , rr2op $ setBitNOfReg false 1 setD d   -- RES 1,D
  , rr2op $ setBitNOfReg false 1 setE e   -- RES 1,E

  , rr2op $ setBitNOfReg false 1 setH h   -- RES 1,H
  , rr2op $ setBitNOfReg false 1 setL l   -- RES 1,L
  , mm2op $ setBitNOfHLMem false 1        -- RES 1,(HL)
  , rr2op $ setBitNOfReg false 1 setA a   -- RES 1,A

                                          -- 9x
  , rr2op $ setBitNOfReg false 2 setB b   -- RES 2,B
  , rr2op $ setBitNOfReg false 2 setC c   -- RES 2,C
  , rr2op $ setBitNOfReg false 2 setD d   -- RES 2,D
  , rr2op $ setBitNOfReg false 2 setE e   -- RES 2,E

  , rr2op $ setBitNOfReg false 2 setH h   -- RES 2,H
  , rr2op $ setBitNOfReg false 2 setL l   -- RES 2,L
  , mm2op $ setBitNOfHLMem false 2        -- RES 2,(HL)
  , rr2op $ setBitNOfReg false 2 setA a   -- RES 2,A

  , rr2op $ setBitNOfReg false 3 setB b   -- RES 3,B
  , rr2op $ setBitNOfReg false 3 setC c   -- RES 3,C
  , rr2op $ setBitNOfReg false 3 setD d   -- RES 3,D
  , rr2op $ setBitNOfReg false 3 setE e   -- RES 3,E

  , rr2op $ setBitNOfReg false 3 setH h   -- RES 3,H
  , rr2op $ setBitNOfReg false 3 setL l   -- RES 3,L
  , mm2op $ setBitNOfHLMem false 3        -- RES 3,(HL)
  , rr2op $ setBitNOfReg false 3 setA a   -- RES 3,A

                                          -- Ax
  , rr2op $ setBitNOfReg false 4 setB b   -- RES 4,B
  , rr2op $ setBitNOfReg false 4 setC c   -- RES 4,C
  , rr2op $ setBitNOfReg false 4 setD d   -- RES 4,D
  , rr2op $ setBitNOfReg false 4 setE e   -- RES 4,E

  , rr2op $ setBitNOfReg false 4 setH h   -- RES 4,H
  , rr2op $ setBitNOfReg false 4 setL l   -- RES 4,L
  , mm2op $ setBitNOfHLMem false 4        -- RES 4,(HL)
  , rr2op $ setBitNOfReg false 4 setA a   -- RES 4,A

  , rr2op $ setBitNOfReg false 5 setB b   -- RES 5,B
  , rr2op $ setBitNOfReg false 5 setC c   -- RES 5,C
  , rr2op $ setBitNOfReg false 5 setD d   -- RES 5,D
  , rr2op $ setBitNOfReg false 5 setE e   -- RES 5,E

  , rr2op $ setBitNOfReg false 5 setH h   -- RES 5,H
  , rr2op $ setBitNOfReg false 5 setL l   -- RES 5,L
  , mm2op $ setBitNOfHLMem false 5        -- RES 5,(HL)
  , rr2op $ setBitNOfReg false 5 setA a   -- RES 5,A

                                          -- Bx
  , rr2op $ setBitNOfReg false 6 setB b   -- RES 6,B
  , rr2op $ setBitNOfReg false 6 setC c   -- RES 6,C
  , rr2op $ setBitNOfReg false 6 setD d   -- RES 6,D
  , rr2op $ setBitNOfReg false 6 setE e   -- RES 6,E

  , rr2op $ setBitNOfReg false 6 setH h   -- RES 6,H
  , rr2op $ setBitNOfReg false 6 setL l   -- RES 6,L
  , mm2op $ setBitNOfHLMem false 6        -- RES 6,(HL)
  , rr2op $ setBitNOfReg false 6 setA a   -- RES 6,A

  , rr2op $ setBitNOfReg false 7 setB b   -- RES 7,B
  , rr2op $ setBitNOfReg false 7 setC c   -- RES 7,C
  , rr2op $ setBitNOfReg false 7 setD d   -- RES 7,D
  , rr2op $ setBitNOfReg false 7 setE e   -- RES 7,E

  , rr2op $ setBitNOfReg false 7 setH h   -- RES 7,H
  , rr2op $ setBitNOfReg false 7 setL l   -- RES 7,L
  , mm2op $ setBitNOfHLMem false 7        -- RES 7,(HL)
  , rr2op $ setBitNOfReg false 7 setA a   -- RES 7,A

                                          -- Cx
  , rr2op $ setBitNOfReg true 0 setB b    -- SET 0,B
  , rr2op $ setBitNOfReg true 0 setC c    -- SET 0,C
  , rr2op $ setBitNOfReg true 0 setD d    -- SET 0,D
  , rr2op $ setBitNOfReg true 0 setE e    -- SET 0,E

  , rr2op $ setBitNOfReg true 0 setH h    -- SET 0,H
  , rr2op $ setBitNOfReg true 0 setL l    -- SET 0,L
  , mm2op $ setBitNOfHLMem true 0         -- SET 0,(HL)
  , rr2op $ setBitNOfReg true 0 setA a    -- SET 0,A

  , rr2op $ setBitNOfReg true 1 setB b    -- SET 1,B
  , rr2op $ setBitNOfReg true 1 setC c    -- SET 1,C
  , rr2op $ setBitNOfReg true 1 setD d    -- SET 1,D
  , rr2op $ setBitNOfReg true 1 setE e    -- SET 1,E

  , rr2op $ setBitNOfReg true 1 setH h    -- SET 1,H
  , rr2op $ setBitNOfReg true 1 setL l    -- SET 1,L
  , mm2op $ setBitNOfHLMem true 1         -- SET 1,(HL)
  , rr2op $ setBitNOfReg true 1 setA a    -- SET 1,A

                                          -- Dx
  , rr2op $ setBitNOfReg true 2 setB b    -- SET 2,B
  , rr2op $ setBitNOfReg true 2 setC c    -- SET 2,C
  , rr2op $ setBitNOfReg true 2 setD d    -- SET 2,D
  , rr2op $ setBitNOfReg true 2 setE e    -- SET 2,E

  , rr2op $ setBitNOfReg true 2 setH h    -- SET 2,H
  , rr2op $ setBitNOfReg true 2 setL l    -- SET 2,L
  , mm2op $ setBitNOfHLMem true 2         -- SET 2,(HL)
  , rr2op $ setBitNOfReg true 2 setA a    -- SET 2,A

  , rr2op $ setBitNOfReg true 3 setB b    -- SET 3,B
  , rr2op $ setBitNOfReg true 3 setC c    -- SET 3,C
  , rr2op $ setBitNOfReg true 3 setD d    -- SET 3,D
  , rr2op $ setBitNOfReg true 3 setE e    -- SET 3,E

  , rr2op $ setBitNOfReg true 3 setH h    -- SET 3,H
  , rr2op $ setBitNOfReg true 3 setL l    -- SET 3,L
  , mm2op $ setBitNOfHLMem true 3         -- SET 3,(HL)
  , rr2op $ setBitNOfReg true 3 setA a    -- SET 3,A

                                          -- Ex
  , rr2op $ setBitNOfReg true 4 setB b    -- SET 4,B
  , rr2op $ setBitNOfReg true 4 setC c    -- SET 4,C
  , rr2op $ setBitNOfReg true 4 setD d    -- SET 4,D
  , rr2op $ setBitNOfReg true 4 setE e    -- SET 4,E

  , rr2op $ setBitNOfReg true 4 setH h    -- SET 4,H
  , rr2op $ setBitNOfReg true 4 setL l    -- SET 4,L
  , mm2op $ setBitNOfHLMem true 4         -- SET 4,(HL)
  , rr2op $ setBitNOfReg true 4 setA a    -- SET 4,A

  , rr2op $ setBitNOfReg true 5 setB b    -- SET 5,B
  , rr2op $ setBitNOfReg true 5 setC c    -- SET 5,C
  , rr2op $ setBitNOfReg true 5 setD d    -- SET 5,D
  , rr2op $ setBitNOfReg true 5 setE e    -- SET 5,E

  , rr2op $ setBitNOfReg true 5 setH h    -- SET 5,H
  , rr2op $ setBitNOfReg true 5 setL l    -- SET 5,L
  , mm2op $ setBitNOfHLMem true 5         -- SET 5,(HL)
  , rr2op $ setBitNOfReg true 5 setA a    -- SET 5,A

                                          -- Fx
  , rr2op $ setBitNOfReg true 6 setB b    -- SET 6,B
  , rr2op $ setBitNOfReg true 6 setC c    -- SET 6,C
  , rr2op $ setBitNOfReg true 6 setD d    -- SET 6,D
  , rr2op $ setBitNOfReg true 6 setE e    -- SET 6,E

  , rr2op $ setBitNOfReg true 6 setH h    -- SET 6,H
  , rr2op $ setBitNOfReg true 6 setL l    -- SET 6,L
  , mm2op $ setBitNOfHLMem true 6         -- SET 6,(HL)
  , rr2op $ setBitNOfReg true 6 setA a    -- SET 6,A

  , rr2op $ setBitNOfReg true 7 setB b    -- SET 7,B
  , rr2op $ setBitNOfReg true 7 setC c    -- SET 7,C
  , rr2op $ setBitNOfReg true 7 setD d    -- SET 7,D
  , rr2op $ setBitNOfReg true 7 setE e    -- SET 7,E

  , rr2op $ setBitNOfReg true 7 setH h    -- SET 7,H
  , rr2op $ setBitNOfReg true 7 setL l    -- SET 7,L
  , mm2op $ setBitNOfHLMem true 7         -- SET 7,(HL)
  , rr2op $ setBitNOfReg true 7 setA a    -- SET 7,A
]

module OpCodeMap where

import Prelude

import Types
import Ops

--Tried to use typeclasses, but was forced to turn all my type synonyms
--to 'newtypes' which will require writing a specialised function for each
--case to convert from the type synonyms to the newtypes which will beat
--the purpose of using a typeclass in the first place (lets me have function
--overload in this case).
rr2op :: (Regs -> Regs) -> Z80State -> Z80State
rr2op rr state@{mem=mem@{regs}} = state { mem = mem { regs = rr regs } }

mr2op :: (Mem -> Regs) -> Z80State -> Z80State
mr2op mr state@{mem=mem@{regs}} = state { mem = mem { regs = mr mem } }

mm2op :: (Mem -> Mem) -> Z80State -> Z80State
mm2op mm state@{mem=mem@{regs}} = state { mem = mm mem }

basicOps :: Array (Z80State -> Z80State)
basicOps =
                                            -- 0x
  [ rr2op $ nop                             -- NOP
  , mr2op $ ldTwoRegsFromImm setB setC      -- LD BC,nn
  , mm2op $ ldMem2RFromReg b c a            -- LD (BC),A
  , rr2op $ incRegWithCarry b c setB setC   -- INC BC

  , rr2op $ incReg b setB                   -- INC B
  , rr2op $ decReg b setB                   -- DEC B
  , mr2op $ ldRegFromImm setB               -- LD B,n
  , rr2op $ rotA Left true                  -- RLC A

  , mm2op $ ldMemImmFromSP                  -- LD (nn),SP
  , rr2op $ add2RegsToHL b c                -- ADD HL,BC
  , mr2op $ ldRegFromMem2R setA b c         -- LD A,(BC)
  , rr2op $ decRegWithCarry b c setB setC   -- DEC BC

  , rr2op $ incReg c setC                   -- INC C
  , rr2op $ decReg c setC                   -- DEC C
  , mr2op $ ldRegFromImm setC               -- LD C,n
  , rr2op $ rotA Right true                 -- RRC A

                                            -- 1x
  , stop                                    -- STOP
  , mr2op $ ldTwoRegsFromImm setD setE      -- LD DE,nn
  , mm2op $ ldMem2RFromReg d e a            -- LD (DE),A
  , rr2op $ incRegWithCarry d e setD setE   -- INC DE

  , rr2op $ incReg d setD                   -- INC D
  , rr2op $ decReg d setD                   -- DEC D
  , mr2op $ ldRegFromImm setD               -- LD D,n
  , rr2op $ rotA Left false                 -- RL A

  , mr2op $ jumpRelImm                      -- JR n
  , rr2op $ add2RegsToHL d e                -- ADD HL,DE
  , mr2op $ ldRegFromMem2R setA d e         -- LD A,(DE)
  , rr2op $ decRegWithCarry d e setD setE   -- DEC DE

  , rr2op $ incReg e setE                   -- INC E
  , rr2op $ decReg e setE                   -- DEC E
  , mr2op $ ldRegFromImm setE               -- LD E,n
  , rr2op $ rotA Right false                -- RR A

                                            -- 2x
  , mr2op $ jumpRelImmFlag true zeroFlag    -- JR NZ,n
  , mr2op $ ldTwoRegsFromImm setH setL      -- LD HL,nn
  , mm2op $ ldMemHLFromRegInc a             -- LDI (HL),A
  , rr2op $ incRegWithCarry h l setH setL   -- INC HL

  , rr2op $ incReg h setH                   -- INC H
  , rr2op $ decReg h setH                   -- DEC H
  , mr2op $ ldRegFromImm setH               -- LD H,n
  , rr2op $ adjAForBCDAdd                   -- DAA

  , mr2op $ jumpRelImmFlag false zeroFlag   -- JR Z,n
  , rr2op $ add2RegsToHL h l                -- ADD HL,HL
  , mr2op $ ldRegFromMemHLInc setA          -- LDI A,(HL)
  , rr2op $ decRegWithCarry h l setH setL   -- DEC HL

  , rr2op $ incReg l setL                   -- INC L
  , rr2op $ decReg l setL                   -- DEC L
  , mr2op $ ldRegFromImm setL               -- LD L,n
  , rr2op $ cmplA                           -- CPL

                                            -- 3x
  , mr2op $ jumpRelImmFlag true carryFlag   -- JR NC,n
  , mr2op $ ldSPFromImm                     -- LD SP,nn
  , mm2op $ ldMemHLFromRegDec a             -- LDD (HL),A
  , rr2op $ incSP                           -- INC SP

  , mm2op $ incHLMem                        -- INC (HL)
  , mm2op $ decHLMem                        -- DEC (HL)
  , mm2op $ ldMemHLFromImm                  -- LD (HL),n
  , rr2op $ setCarryFlag                    -- SCF

  , mr2op $ jumpRelImmFlag false carryFlag  -- JR C,n
  , rr2op $ addSPToHL                       -- ADD HL,SP
  , mr2op $ ldRegFromMemHLDec setA          -- LDD A,(HL)
  , rr2op $ decSP                           -- DEC SP

  , rr2op $ incReg a setA                   -- INC A
  , rr2op $ decReg a setA                   -- DEC A
  , mr2op $ ldRegFromImm setA               -- LD A,n
  , rr2op $ clearCarryFlag                  -- CCF

                                            -- 4x
  , rr2op $ ldRegFromReg setB b             -- LD B,B
  , rr2op $ ldRegFromReg setB c             -- LD B,C
  , rr2op $ ldRegFromReg setB d             -- LD B,D
  , rr2op $ ldRegFromReg setB e             -- LD B,E

  , rr2op $ ldRegFromReg setB h             -- LD B,H
  , rr2op $ ldRegFromReg setB l             -- LD B,L
  , mr2op $ ldRegFromMem2R setB h l         -- LD B,(HL)
  , rr2op $ ldRegFromReg setB a             -- LD B,A

  , rr2op $ ldRegFromReg setC b             -- LD C,B
  , rr2op $ ldRegFromReg setC c             -- LD C,C
  , rr2op $ ldRegFromReg setC d             -- LD C,D
  , rr2op $ ldRegFromReg setC e             -- LD C,E

  , rr2op $ ldRegFromReg setC h             -- LD C,H
  , rr2op $ ldRegFromReg setC l             -- LD C,L
  , mr2op $ ldRegFromMem2R setC h l         -- LD C,(HL)
  , rr2op $ ldRegFromReg setC a             -- LD C,A

                                            -- 5x
  , rr2op $ ldRegFromReg setD b             -- LD D,B
  , rr2op $ ldRegFromReg setD c             -- LD D,C
  , rr2op $ ldRegFromReg setD d             -- LD D,D
  , rr2op $ ldRegFromReg setD e             -- LD D,E

  , rr2op $ ldRegFromReg setD h             -- LD D,H
  , rr2op $ ldRegFromReg setD l             -- LD D,L
  , mr2op $ ldRegFromMem2R setD h l         -- LD D,(HL)
  , rr2op $ ldRegFromReg setD a             -- LD D,A

  , rr2op $ ldRegFromReg setE b             -- LD E,B
  , rr2op $ ldRegFromReg setE c             -- LD E,C
  , rr2op $ ldRegFromReg setE d             -- LD E,D
  , rr2op $ ldRegFromReg setE e             -- LD E,E

  , rr2op $ ldRegFromReg setE h             -- LD E,H
  , rr2op $ ldRegFromReg setE l             -- LD E,L
  , mr2op $ ldRegFromMem2R setE h l         -- LD E,(HL)
  , rr2op $ ldRegFromReg setE a             -- LD E,A

                                            -- 6x
  , rr2op $ ldRegFromReg setH b             -- LD H,B
  , rr2op $ ldRegFromReg setH c             -- LD H,C
  , rr2op $ ldRegFromReg setH d             -- LD H,D
  , rr2op $ ldRegFromReg setH e             -- LD H,E

  , rr2op $ ldRegFromReg setH h             -- LD H,H
  , rr2op $ ldRegFromReg setH l             -- LD H,L
  , mr2op $ ldRegFromMem2R setH h l         -- LD H,(HL)
  , rr2op $ ldRegFromReg setH a             -- LD H,A

  , rr2op $ ldRegFromReg setL b             -- LD L,B
  , rr2op $ ldRegFromReg setL c             -- LD L,C
  , rr2op $ ldRegFromReg setL d             -- LD L,D
  , rr2op $ ldRegFromReg setL e             -- LD L,E

  , rr2op $ ldRegFromReg setL h             -- LD L,H
  , rr2op $ ldRegFromReg setL l             -- LD L,L
  , mr2op $ ldRegFromMem2R setL h l         -- LD L,(HL)
  , rr2op $ ldRegFromReg setL a             -- LD L,A

                                            -- 7x
  , mm2op $ ldMem2RFromReg h l b            -- LD (HL),B
  , mm2op $ ldMem2RFromReg h l c            -- LD (HL),C
  , mm2op $ ldMem2RFromReg h l d            -- LD (HL),D
  , mm2op $ ldMem2RFromReg h l e            -- LD (HL),E

  , mm2op $ ldMem2RFromReg h l h            -- LD (HL),H
  , mm2op $ ldMem2RFromReg h l l            -- LD (HL),L
  , halt                                    -- HALT
  , mm2op $ ldMem2RFromReg h l a            -- LD (HL),A

  , rr2op $ ldRegFromReg setA b             -- LD A,B
  , rr2op $ ldRegFromReg setA c             -- LD A,C
  , rr2op $ ldRegFromReg setA d             -- LD A,D
  , rr2op $ ldRegFromReg setA e             -- LD A,E

  , rr2op $ ldRegFromReg setA h             -- LD A,H
  , rr2op $ ldRegFromReg setA l             -- LD A,L
  , mr2op $ ldRegFromMem2R setA h l         -- LD A,(HL)
  , rr2op $ ldRegFromReg setA a             -- LD A,A

                                            -- 8x
  , rr2op $ addRegToA b                     -- ADD A,B
  , rr2op $ addRegToA c                     -- ADD A,C
  , rr2op $ addRegToA d                     -- ADD A,D
  , rr2op $ addRegToA e                     -- ADD A,E

  , rr2op $ addRegToA h                     -- ADD A,H
  , rr2op $ addRegToA l                     -- ADD A,L
  , mr2op $ addHLMemToA                     -- ADD A,(HL)
  , rr2op $ addRegToA a                     -- ADD A,A

  , rr2op $ addRegCarryToA b                -- ADC A,B
  , rr2op $ addRegCarryToA c                -- ADC A,C
  , rr2op $ addRegCarryToA d                -- ADC A,D
  , rr2op $ addRegCarryToA e                -- ADC A,E

  , rr2op $ addRegCarryToA h                -- ADC A,H
  , rr2op $ addRegCarryToA l                -- ADC A,L
  , mr2op $ addHLMemCarryToA                -- ADC A,(HL)
  , rr2op $ addRegCarryToA a                -- ADC A,A

                                            -- 9x
  , rr2op $ subRegFromA b                   -- SUB A,B
  , rr2op $ subRegFromA c                   -- SUB A,C
  , rr2op $ subRegFromA d                   -- SUB A,D
  , rr2op $ subRegFromA e                   -- SUB A,E

  , rr2op $ subRegFromA h                   -- SUB A,H
  , rr2op $ subRegFromA l                   -- SUB A,L
  , mr2op $ subHLMemFromA                   -- SUB A,(HL)
  , rr2op $ subRegFromA a                   -- SUB A,A

  , rr2op $ subRegCarryFromA b              -- SBC A,B
  , rr2op $ subRegCarryFromA c              -- SBC A,C
  , rr2op $ subRegCarryFromA d              -- SBC A,D
  , rr2op $ subRegCarryFromA e              -- SBC A,E

  , rr2op $ subRegCarryFromA h              -- SBC A,H
  , rr2op $ subRegCarryFromA l              -- SBC A,L
  , mr2op $ subHLMemCarryFromA              -- SBC A,(HL)
  , rr2op $ subRegCarryFromA a              -- SBC A,A

                                            -- Ax
  , rr2op $ andOpRegIntoA b                 -- AND B
  , rr2op $ andOpRegIntoA c                 -- AND C
  , rr2op $ andOpRegIntoA d                 -- AND D
  , rr2op $ andOpRegIntoA e                 -- AND E

  , rr2op $ andOpRegIntoA h                 -- AND H
  , rr2op $ andOpRegIntoA l                 -- AND L
  , mr2op $ andOpHLMemIntoA                 -- AND (HL)
  , rr2op $ andOpRegIntoA a                 -- AND A

  , rr2op $ xorOpRegIntoA b                 -- XOR B
  , rr2op $ xorOpRegIntoA c                 -- XOR C
  , rr2op $ xorOpRegIntoA d                 -- XOR D
  , rr2op $ xorOpRegIntoA e                 -- XOR E

  , rr2op $ xorOpRegIntoA h                 -- XOR H
  , rr2op $ xorOpRegIntoA l                 -- XOR L
  , mr2op $ xorOpHLMemIntoA                 -- XOR (HL)
  , rr2op $ xorOpRegIntoA a                 -- XOR A

                                            -- Bx
  , rr2op $ orOpRegIntoA b                  -- OR B
  , rr2op $ orOpRegIntoA c                  -- OR C
  , rr2op $ orOpRegIntoA d                  -- OR D
  , rr2op $ orOpRegIntoA e                  -- OR E

  , rr2op $ orOpRegIntoA h                  -- OR H
  , rr2op $ orOpRegIntoA l                  -- OR L
  , mr2op $ orOpHLMemIntoA                  -- OR (HL)
  , rr2op $ orOpRegIntoA a                  -- OR A

  , rr2op $ compAToReg b                    -- CP B
  , rr2op $ compAToReg c                    -- CP C
  , rr2op $ compAToReg d                    -- CP D
  , rr2op $ compAToReg e                    -- CP E

  , rr2op $ compAToReg h                    -- CP H
  , rr2op $ compAToReg l                    -- CP L
  , mr2op $ compAToMemHL                    -- CP(HL)
  , rr2op $ compAToReg a                    -- CP A

                                            -- Cx
  , mr2op $ retFlag true zeroFlag           -- RET NZ
  , mr2op $ popReg setB setC                -- POP BC
  , mr2op $ jumpImmFlag true zeroFlag       -- JP NZ,nn
  , mr2op $ jumpImm                         -- JP nn

  , mm2op $ callImmFlag true zeroFlag       -- CALL NZ,nn
  , mm2op $ pushReg b c                     -- PUSH BC
  , mr2op $ addImmToA                       -- ADD A,n
  , mm2op $ callRoutine 0x00                -- RST 0

  , mr2op $ retFlag false zeroFlag          -- RET Z
  , mr2op $ ret                             -- RET
  , mr2op $ jumpImmFlag false zeroFlag      -- JP Z,nn
  , execExtOps extOps                       -- CB OpCode map

  , mm2op $ callImmFlag false zeroFlag      -- CALL Z,nn
  , mm2op $ callImm                         -- CALL nn
  , mr2op $ addImmCarryToA                  -- ADC A,n
  , mm2op $ callRoutine 0x08                -- RST 8

                                            -- Dx
  , mr2op $ retFlag true carryFlag          -- RET NC
  , mr2op $ popReg setD setE                -- POP DE
  , mr2op $ jumpImmFlag true carryFlag      -- JP NC,nn
  , invalidOpCode

  , mm2op $ callImmFlag true carryFlag      -- CALL NC,nn
  , mm2op $ pushReg d e                     -- PUSH DE
  , mr2op $ subImmFromA                     -- SUB A,n
  , mm2op $ callRoutine 0x10                -- RST 10

  , mr2op $ retFlag false carryFlag         -- RET C
  , mr2op $ retEnableInterrupt              -- RETI
  , mr2op $ jumpImmFlag false carryFlag     -- JP C,nn
  , invalidOpCode

  , mm2op $ callImmFlag true carryFlag      -- CALL C,nn
  , invalidOpCode
  , mr2op subImmCarryToA                    -- SBC A,n
  , mm2op $ callRoutine 0x18                -- RST 18

                                            -- Ex
  , mm2op $ ldFF00ImmMemFromReg a           -- LDH (n),A
  , mr2op $ popReg setH setL                -- POP HL
  , mm2op $ ldFF00CMemFromReg a             -- LDH (C),A
  , invalidOpCode

  , invalidOpCode
  , mm2op $ pushReg h l                     -- PUSH HL
  , mr2op andOpImmIntoA                     -- AND n
  , mm2op $ callRoutine 0x20                -- RST 20

  , mr2op addImmToSP                        -- ADD SP,d
  , rr2op jumpHL                            -- JP (HL)
  , mm2op ldMemImmFromRegA                  -- LD (nn),A
  , invalidOpCode

  , invalidOpCode
  , invalidOpCode
  , mr2op xorOpImmIntoA                     -- XOR n
  , mm2op $ callRoutine 0x28                -- RST 28

                                            -- Fx
  , mr2op $ ldRegFromFF00ImmMem setA        -- LDH A,(n)
  , mr2op $ popReg setA setF                -- POP AF
  , mr2op $ ldRegFromFF00CMem setA          -- LD A,(IOC)
  , rr2op $ setInterrupts false             -- DI

  , invalidOpCode
  , mm2op $ pushReg a f                     -- PUSH AF
  , mr2op orOpImmIntoA                      -- OR n
  , mm2op $ callRoutine 0x30                -- RST 30

  , mr2op ldHLFromSPImm                     -- LDHL SP,d
  , rr2op ldSPFromHL                        -- LD SP,HL
  , mr2op ldRegAFromMemImm                  -- LD A,(nn)
  , rr2op $ setInterrupts true              -- EI

  , invalidOpCode
  , invalidOpCode
  , mr2op compAToImm                        -- CP n
  , mm2op $ callRoutine 0x38                -- RST 38
]


Fix unfoldTurns by using left fold!

Fix unfoldTurns by using left fold!

module App.Turn (unfoldTurns, Turn'(..)) where

import Data.List
import App.Board as Board
import App.Animation (class Transition)
import App.Hand (State(..))
import Data.Function (apply)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable, unfoldr)
import Prelude (class Show, flip, map, (#), ($), (+), (-), (<$>), (<<<))

data Turn' a
  = Advance (a -> a)
  | Capture (a -> a)
  | Lift (a -> a)
  | Sow (a -> a)

instance showTurn :: Show (Turn' a) where
  show (Advance _) = "Advance"
  show (Capture _) = "Capture"
  show (Lift _) = "Lift"
  show (Sow _) = "Sow"

type Turn = Turn' State

instance transitionTurn :: Transition Turn' State where
  getTransitionF = turnFunction

unfoldTurns :: State -> List Turn
unfoldTurns = concat <<< unfoldr' nextTurns

nextTurns :: State -> Tuple (List Turn) (Maybe State)
nextTurns (State state@{ player, seeds, pitRef, board }) =
  Board.mapPit3 pitRef (f seeds) board
    -- TODO: fill in these functions
    where f 0 0 0 _ =
            -- No hand, next two pits empty. End turn.
            Nil # end
          f 0 0 _ 0 =
            -- Capture and end turn
            advance : capture : Nil # end
          f 0 0 _ _ =
            -- Capture and continue
            advance : capture : advance : Nil # continue
          f 0 _ _ _ =
            -- Lift and continue digging
            lift : advance : Nil # continue
          f _ 3 _ _ =
            -- Pasu; capture
            sow : capture : advance : Nil # continue
          f _ _ _ _ =
            -- Sow 1 seed and continue digging
            sow : advance : Nil # continue
          continue xs =
            Tuple xs $ Just $ applyTurns xs $ State state
          end xs =
            Tuple xs Nothing

turnFunction :: forall a. Turn' a -> a -> a
turnFunction (Advance f) = f
turnFunction (Capture f) = f
turnFunction (Lift f) = f
turnFunction (Sow f) = f

applyTurns :: List Turn -> State -> State
applyTurns turns s = foldl (flip apply) s (turnFunction <$> turns)

-- All turns

advance :: Turn
advance = Advance \(State s) ->
  State $ s { pitRef = Board.nextRef s.pitRef }

capture :: Turn
capture = Capture \(State s) ->
  State $ s { board = s.board
                      # Board.clear s.pitRef
                      # Board.store s.player (Board.lookup s.pitRef s.board)
            }

lift :: Turn
lift = Lift \(State s) ->
  State $ s { seeds = Board.lookup s.pitRef s.board
            , board = Board.clear s.pitRef s.board
            }

sow :: Turn
sow = Sow \(State s) ->
  State $ s { seeds = s.seeds - 1
            , board = Board.modify s.pitRef ((+) 1) s.board
            }

-- Internal

-- | A version of unfoldr that allows a elements in end case.
unfoldr' :: forall a b t. Unfoldable t
         => (b -> Tuple a (Maybe b)) -> b -> t a
unfoldr' f = unfoldr (map f) <<< Just

module App.Turn (unfoldTurns, Turn'(..)) where

import Data.List
import App.Board as Board
import App.Animation (class Transition)
import App.Hand (State(..))
import Data.Function (apply)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable, unfoldr)
import Prelude (class Show, map, (#), ($), (+), (-), (<$>), (<<<))

data Turn' a
  = Advance (a -> a)
  | Capture (a -> a)
  | Lift (a -> a)
  | Sow (a -> a)

instance showTurn :: Show (Turn' a) where
  show (Advance _) = "Advance"
  show (Capture _) = "Capture"
  show (Lift _) = "Lift"
  show (Sow _) = "Sow"

type Turn = Turn' State

instance transitionTurn :: Transition Turn' State where
  getTransitionF = turnFunction

unfoldTurns :: State -> List Turn
unfoldTurns = concat <<< unfoldr' nextTurns

nextTurns :: State -> Tuple (List Turn) (Maybe State)
nextTurns (State state@{ player, seeds, pitRef, board }) =
  Board.mapPit3 pitRef (f seeds) board
    -- TODO: fill in these functions
    where f 0 0 0 _ =
            -- No hand, next two pits empty. End turn.
            Nil # end
          f 0 0 _ 0 =
            -- Capture and end turn
            advance : capture : Nil # end
          f 0 0 _ _ =
            -- Capture and continue
            advance : capture : advance : Nil # continue
          f 0 _ _ _ =
            -- Lift and continue digging
            lift : advance : Nil # continue
          f _ 3 _ _ =
            -- Pasu; capture
            sow : capture : advance : Nil # continue
          f _ _ _ _ =
            -- Sow 1 seed and continue digging
            sow : advance : Nil # continue
          continue xs =
            Tuple xs $ Just $ applyTurns xs $ State state
          end xs =
            Tuple xs Nothing

turnFunction :: forall a. Turn' a -> a -> a
turnFunction (Advance f) = f
turnFunction (Capture f) = f
turnFunction (Lift f) = f
turnFunction (Sow f) = f

applyTurns :: List Turn -> State -> State
applyTurns turns s = foldr apply s (turnFunction <$> turns)

-- All turns

advance :: Turn
advance = Advance \(State s) ->
  State $ s { pitRef = Board.nextRef s.pitRef }

capture :: Turn
capture = Capture \(State s) ->
  State $ s { board = s.board
                      # Board.clear s.pitRef
                      # Board.store s.player (Board.lookup s.pitRef s.board)
            }

lift :: Turn
lift = Lift \(State s) ->
  State $ s { seeds = Board.lookup s.pitRef s.board
            , board = Board.clear s.pitRef s.board
            }

sow :: Turn
sow = Sow \(State s) ->
  State $ s { seeds = s.seeds - 1
            , board = Board.modify s.pitRef ((+) 1) s.board
            }

-- Internal

-- | A version of unfoldr that allows a elements in end case.
unfoldr' :: forall a b t. Unfoldable t
         => (b -> Tuple a (Maybe b)) -> b -> t a
unfoldr' f = unfoldr (map f) <<< Just


convert from mincompo to compo with config in mind

module KanColle.Expedition.New.Config
  ( Config
  , mkConfig
  , defConfig
  ) where

import Prelude
import Data.Maybe
import KanColle.Expedition.New.SType
import KanColle.Expedition.New.MinCompo
import Data.Array as A
import Data.Unfoldable

type FleetCompo = Array SType

-- configuration for a single expedition.
data Config = Conf
  { greatSuccess :: Boolean
  , normDaihatsuCount :: Int -- normalized, should be one of [0..4]
  , wildcardSType :: SType
  }

mkConfig :: Boolean -> Int -> SType -> Config
mkConfig gs dCount wt = Conf
    { greatSuccess: gs
    , normDaihatsuCount: if dCount > 4 then 4 else dCount
    , wildcardSType: wt
    }

defConfig :: Config
defConfig = mkConfig false 0 DD

getComposition :: Config -> Int -> FleetCompo
getComposition (Conf c) n = if c.greatSuccess
    then compo <> replicate (6 - l) c.wildcardSType
    else compo
  where
    minCompo = getMinimumComposition n
    compo = map (fromMaybe c.wildcardSType) minCompo
    l = A.length compo

module KanColle.Expedition.New.Config where

import Prelude
import KanColle.Expedition.New.SType

-- configuration for a single expedition.
data Config = Conf
  { greatSuccess :: Boolean
  , normDaihatsuCount :: Int -- normalized, should be one of [0..4]
  , wildcardSType :: SType
  }

mkConf :: Boolean -> Int -> SType -> Config
mkConf gs dCount wt = Conf
    { greatSuccess: gs
    , normDaihatsuCount: if dCount > 4 then 4 else dCount
    , wildcardSType: wt
    }

defConfig :: Config
defConfig = mkConf false 0 DD


API based on functional dependencies

API based on functional dependencies

module Control.Parallel.Class
  ( class MonadPar
  , parTraverse_
  , parTraverse
  , Parallel
  , parallel
  , sequential
  ) where

import Prelude
import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Monad.Cont.Trans (ContT(..), runContT)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Ref (REF, writeRef, readRef, newRef)
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)
import Control.Monad.Except (mapExceptT)
import Control.Monad.Except.Trans (ExceptT)
import Control.Monad.Reader.Trans (mapReaderT, ReaderT)
import Control.Monad.Writer.Trans (mapWriterT, WriterT)
import Control.Plus (class Plus)
import Data.Foldable (class Foldable, traverse_)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid)
import Data.Traversable (class Traversable, traverse)

-- | The `MonadPar` class abstracts over monads which support
-- | parallel composition via some related `Applicative`.
class (Monad m, Applicative f) <= MonadPar f m | m -> f, f -> m where
  parallel   :: m ~> f
  sequential :: f ~> m

-- | Traverse a collection in parallel, discarding any results.
parTraverse_
  :: forall f m t a b
   . (MonadPar f m, Foldable t)
  => (a -> m b)
  -> t a
  -> m Unit
parTraverse_ f = sequential <<< traverse_ (parallel <<< f)

-- | Traverse a collection in parallel.
parTraverse
  :: forall f m t a b
   . (MonadPar f m, Traversable t)
  => (a -> m b)
  -> t a
  -> m (t b)
parTraverse f = sequential <<< traverse (parallel <<< f)

-- | The `Parallel` type constructor provides an `Applicative` instance
-- | based on `ContT Unit m`, which waits for multiple continuations to be
-- | resumed simultaneously.
-- |
-- | Parallel sections of code can be embedded in sequential code by using
-- | the `parallel` and `sequential` functions:
-- |
-- | ```purescript
-- | loadModel :: ContT Unit (Eff (ajax :: AJAX)) Model
-- | loadModel = do
-- |   token <- authenticate
-- |   sequential $
-- |     Model <$> parallel (get "/products/popular/" token)
-- |           <*> parallel (get "/categories/all" token)
-- | ```
newtype Parallel m a = Parallel (ContT Unit m a)

instance functorParallel :: MonadEff eff m => Functor (Parallel m) where
  map f = parallel <<< map f <<< sequential

instance applyParallel :: MonadEff eff m => Apply (Parallel m) where
  apply (Parallel ca) (Parallel cb) = Parallel $ ContT \k -> do
    ra <- liftEff $ unsafeWithRef (newRef Nothing)
    rb <- liftEff $ unsafeWithRef (newRef Nothing)

    runContT ca \a -> do
      mb <- liftEff $ unsafeWithRef (readRef rb)
      case mb of
        Nothing -> liftEff $ unsafeWithRef (writeRef ra (Just a))
        Just b -> k (a b)

    runContT cb \b -> do
      ma <- liftEff $ unsafeWithRef (readRef ra)
      case ma of
        Nothing -> liftEff $ unsafeWithRef (writeRef rb (Just b))
        Just a -> k (a b)

instance applicativeParallel :: MonadEff eff m => Applicative (Parallel m) where
  pure = parallel <<< pure

instance altParallel :: MonadEff eff m => Alt (Parallel m) where
  alt (Parallel c1) (Parallel c2) = Parallel $ ContT \k -> do
    done <- liftEff $ unsafeWithRef (newRef false)

    runContT c1 \a -> do
      b <- liftEff $ unsafeWithRef (readRef done)
      if b
        then pure unit
        else do
          liftEff $ unsafeWithRef (writeRef done true)
          k a

    runContT c2 \a -> do
      b <- liftEff $ unsafeWithRef (readRef done)
      if b
        then pure unit
        else do
          liftEff $ unsafeWithRef (writeRef done true)
          k a

instance plusParallel :: MonadEff eff m => Plus (Parallel m) where
  empty = Parallel $ ContT \_ -> pure unit

instance alternativeParallel :: MonadEff eff m => Alternative (Parallel m)

instance monadParParallel :: MonadEff eff m => MonadPar (Parallel m) (ContT Unit m) where
  parallel = Parallel
  sequential (Parallel ma) = ma

instance monadParExceptT :: MonadPar f m => MonadPar (ExceptT e f) (ExceptT e m) where
  parallel = mapExceptT parallel
  sequential = mapExceptT sequential

instance monadParReaderT :: MonadPar f m => MonadPar (ReaderT e f) (ReaderT e m) where
  parallel = mapReaderT parallel
  sequential = mapReaderT sequential

instance monadParWriterT :: (Monoid w, MonadPar f m) => MonadPar (WriterT w f) (WriterT w m) where
  parallel = mapWriterT parallel
  sequential = mapWriterT sequential

-- This instance doesn't work yet, since the Applicative instance for MaybeT is
-- too restrictive.

-- instance monadParMaybeT :: MonadPar f m => MonadPar (MaybeT f) (MaybeT m) where
--   parallel = mapMaybeT ?p
--   sequential = mapMaybeT ?s

unsafeWithRef :: forall eff a. Eff (ref :: REF | eff) a -> Eff eff a
unsafeWithRef = unsafeInterleaveEff

module Control.Parallel.Class
  ( class MonadPar
  , par
  , parTraverse_
  , parTraverse
  , class MonadRace
  , stall
  , race
  , Parallel
  , parallel
  , runParallel
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Monad.Cont.Trans (ContT(..), runContT)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (REF, writeRef, readRef, newRef)
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)
import Control.Monad.Except.Trans (ExceptT(..))
import Control.Monad.Reader.Trans (ReaderT(..))
import Control.Monad.Maybe.Trans (MaybeT(..))
import Control.Monad.Writer.Trans (WriterT(..))
import Control.Plus (class Plus)

import Data.Foldable (class Foldable, traverse_)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid)
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(..))

-- | The `MonadPar` class abstracts over monads which support some notion of
-- | parallel composition.
-- |
-- | The `unit` and `par` functions should correspond to `pure` and `lift2` for
-- | some valid `Applicative` instance, but that instance need not arise from
-- | the underlying `Monad`.
class Monad m <= MonadPar m where
  par :: forall a b c. (a -> b -> c) -> m a -> m b -> m c

instance monadParContT :: MonadPar (ContT Unit (Eff eff)) where
  par f ca cb = ContT \k -> do
    ra <- unsafeWithRef (newRef Nothing)
    rb <- unsafeWithRef (newRef Nothing)

    runContT ca \a -> do
      mb <- unsafeWithRef (readRef rb)
      case mb of
        Nothing -> unsafeWithRef (writeRef ra (Just a))
        Just b -> k (f a b)

    runContT cb \b -> do
      ma <- unsafeWithRef (readRef ra)
      case ma of
        Nothing -> unsafeWithRef (writeRef rb (Just b))
        Just a -> k (f a b)

instance monadParExceptT :: MonadPar m => MonadPar (ExceptT e m) where
  par f (ExceptT e1) (ExceptT e2) = ExceptT (par (lift2 f) e1 e2)

instance monadParMaybeT :: MonadPar m => MonadPar (MaybeT m) where
  par f (MaybeT m1) (MaybeT m2) = MaybeT (par (lift2 f) m1 m2)

instance monadParReaderT :: MonadPar m => MonadPar (ReaderT e m) where
  par f (ReaderT r1) (ReaderT r2) = ReaderT \r -> par f (r1 r) (r2 r)

instance monadParWriterT :: (Monoid w, MonadPar m) => MonadPar (WriterT w m) where
  par f (WriterT w1) (WriterT w2) =
    WriterT $
      par (\(Tuple a wa) (Tuple b wb) → Tuple (f a b) (wa <> wb)) w1 w2

-- | Traverse a collection in parallel, discarding any results.
parTraverse_
  :: forall m t a b
   . (MonadPar m, Foldable t)
  => (a -> m b)
  -> t a
  -> m Unit
parTraverse_ f = runParallel <<< traverse_ (Parallel <<< f)

-- | Traverse a collection in parallel.
parTraverse
  :: forall m t a b
   . (MonadPar m, Traversable t)
  => (a -> m b)
  -> t a
  -> m (t b)
parTraverse f = runParallel <<< traverse (Parallel <<< f)

-- | The `MonadRace` class extends `MonadPar` to those monads which can be
-- | _raced_. That is, monads for which two computations can be
-- |
-- | The `stall` and `race` functions should satisfy the `Alternative` laws.
class MonadPar m <= MonadRace m where
  stall :: forall a. m a
  race :: forall a. m a -> m a -> m a

unsafeWithRef :: forall eff a. Eff (ref :: REF | eff) a -> Eff eff a
unsafeWithRef = unsafeInterleaveEff

instance monadRaceContT :: MonadRace (ContT Unit (Eff eff)) where
  stall = ContT \_ -> pure unit
  race c1 c2 = ContT \k -> do
    done <- unsafeWithRef (newRef false)

    runContT c1 \a -> do
      b <- unsafeWithRef (readRef done)
      if b
        then pure unit
        else do
          unsafeWithRef (writeRef done true)
          k a

    runContT c2 \a -> do
      b <- unsafeWithRef (readRef done)
      if b
        then pure unit
        else do
          unsafeWithRef (writeRef done true)
          k a

instance monadRaceExceptT :: MonadRace m => MonadRace (ExceptT e m) where
  stall = ExceptT stall
  race (ExceptT e1) (ExceptT e2) = ExceptT (race e1 e2)

instance monadRaceMaybeT :: MonadRace m => MonadRace (MaybeT m) where
  stall = MaybeT stall
  race (MaybeT m1) (MaybeT m2) = MaybeT (race m1 m2)

instance monadRaceReaderT :: MonadRace m => MonadRace (ReaderT e m) where
  stall = ReaderT \_ -> stall
  race (ReaderT r1) (ReaderT r2) = ReaderT \r -> race (r1 r) (r2 r)

instance monadRaceWriterT :: (Monoid w, MonadRace m) => MonadRace (WriterT w m) where
  stall = WriterT stall
  race (WriterT w1) (WriterT w2) = WriterT (race w1 w2)

-- | The `Parallel` type constructor provides `Applicative` and `Alternative`
-- | instances for any type monad with `MonadPar` and `MonadRace` instances
-- | respectively.
-- |
-- | - The definition of `apply` from `Apply` runs two computations in parallel and applies
-- |   a function when both complete.
-- | - The definition of `alt` from the `Alt` type class runs two computations in parallel
-- |   and returns the result of the computation which completes first.
-- |
-- | Parallel sections of code can be embedded in sequential code by using
-- | the `parallel` and `runParallel` functions:
-- |
-- | ```purescript
-- | loadModel :: ContT Unit (Eff (ajax :: AJAX)) Model
-- | loadModel = do
-- |   token <- authenticate
-- |   runParallel $
-- |     Model <$> parallel (get "/products/popular/" token)
-- |           <*> parallel (get "/categories/all" token)
-- | ```
newtype Parallel m a = Parallel (m a)

-- | Lift a computation to be run in parallel from a computation in the
-- | corresponding `Monad`.
parallel :: forall m a. m a -> Parallel m a
parallel = Parallel

-- | Lower a parallel computation to the underlying `Monad`, so that it may be
-- | used in a larger sequential computation.
runParallel :: forall m a. Parallel m a -> m a
runParallel (Parallel ma) = ma

instance functorParallel :: Functor m => Functor (Parallel m) where
  map f = parallel <<< map f <<< runParallel

instance applyParallel :: MonadPar m => Apply (Parallel m) where
  apply f a = parallel (par ($) (runParallel f) (runParallel a))

instance applicativeParallel :: MonadPar m => Applicative (Parallel m) where
  pure = parallel <<< pure

instance altParallel :: MonadRace m => Alt (Parallel m) where
  alt a b = parallel (runParallel a `race` runParallel b)

instance plusParallel :: MonadRace m => Plus (Parallel m) where
  empty = parallel stall

instance alternativeParallel :: MonadRace m => Alternative (Parallel m)


Add drawImageScale and drawImageFull functions.

module Graphics.Canvas.Free
  ( Graphics
  , GraphicsT
  , GraphicsF
  , arc
  , beginPath
  , clearRect
  , clip
  , closePath
  , createImageData
  , createImageDataCopy
  , drawImage
  , drawImageScale
  , drawImageFull
  , fill
  , fillRect
  , fillText
  , font
  , getImageData
  , lineTo
  , measureText
  , moveTo
  , putImageData
  , putImageDataFull
  , rect
  , restore
  , rotate
  , save
  , scale
  , setAlpha
  , setComposite
  , setFillStyle
  , setFont
  , setLineCap
  , setLineWidth
  , setShadowBlur
  , setShadowColor
  , setShadowOffsetX
  , setShadowOffsetY
  , setStrokeStyle
  , setTextAlign
  , stroke
  , strokeRect
  , strokeText
  , textAlign
  , transform
  , translate
  , runGraphics
  , runGraphicsT
  , interpretGraphics
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Free.Trans (FreeT, liftFreeT, hoistFreeT, runFreeT)
import Data.Identity (Identity)
import Data.Newtype (unwrap)
import Graphics.Canvas as Canvas

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 Canvas.LineCap more
  | SetComposite Canvas.Composite more
  | SetAlpha Number more
  | BeginPath more
  | Stroke more
  | Fill more
  | Clip more
  | LineTo Number Number more
  | MoveTo Number Number more
  | ClosePath more
  | Arc Canvas.Arc more
  | Rect Canvas.Rectangle more
  | FillRect Canvas.Rectangle more
  | StrokeRect Canvas.Rectangle more
  | ClearRect Canvas.Rectangle more
  | Scale Number Number more
  | Rotate Number more
  | Translate Number Number more
  | Transform Canvas.Transform more
  | TextAlign (Canvas.TextAlign -> more)
  | SetTextAlign Canvas.TextAlign more
  | Font (String -> more)
  | SetFont String more
  | FillText String Number Number more
  | StrokeText String Number Number more
  | MeasureText String (Canvas.TextMetrics -> more)
  | Save more
  | Restore more
  | GetImageData Number Number Number Number (Canvas.ImageData -> more)
  | PutImageData Canvas.ImageData Number Number more
  | PutImageDataFull Canvas.ImageData Number Number Number Number Number Number more
  | CreateImageData Number Number (Canvas.ImageData -> more)
  | CreateImageDataCopy Canvas.ImageData (Canvas.ImageData -> more)
  | DrawImage Canvas.CanvasImageSource Number Number more
  | DrawImageScale Canvas.CanvasImageSource Number Number Number Number more
  | DrawImageFull Canvas.CanvasImageSource Number Number Number Number Number Number Number Number more

derive instance functorGraphicsF :: Functor GraphicsF

type GraphicsT = FreeT GraphicsF

type Graphics = GraphicsT Identity

liftGraphics :: forall m. Monad m => GraphicsF ~> GraphicsT m
liftGraphics = liftFreeT

setLineWidth :: forall m. Monad m => Number -> GraphicsT m Unit
setLineWidth w = liftGraphics $ SetLineWidth w unit

setFillStyle :: forall m. Monad m => String -> GraphicsT m Unit
setFillStyle s = liftGraphics $ SetFillStyle s unit

setStrokeStyle :: forall m. Monad m => String -> GraphicsT m Unit
setStrokeStyle s = liftGraphics $ SetStrokeStyle s unit

setShadowColor :: forall m. Monad m => String -> GraphicsT m Unit
setShadowColor c = liftGraphics $ SetShadowColor c unit

setShadowBlur :: forall m. Monad m => Number -> GraphicsT m Unit
setShadowBlur n = liftGraphics $ SetShadowBlur n unit

setShadowOffsetX :: forall m. Monad m => Number -> GraphicsT m Unit
setShadowOffsetX n = liftGraphics $ SetShadowOffsetX n unit

setShadowOffsetY :: forall m. Monad m => Number -> GraphicsT m Unit
setShadowOffsetY n = liftGraphics $ SetShadowOffsetY n unit

setLineCap :: forall m. Monad m => Canvas.LineCap -> GraphicsT m Unit
setLineCap lc = liftGraphics $ SetLineCap lc unit

setComposite :: forall m. Monad m => Canvas.Composite -> GraphicsT m Unit
setComposite c = liftGraphics $ SetComposite c unit

setAlpha :: forall m. Monad m => Number -> GraphicsT m Unit
setAlpha a = liftGraphics $ SetAlpha a unit

beginPath :: forall m. Monad m => GraphicsT m Unit
beginPath = liftGraphics $ BeginPath unit

stroke :: forall m. Monad m => GraphicsT m Unit
stroke = liftGraphics $ Stroke unit

fill :: forall m. Monad m => GraphicsT m Unit
fill = liftGraphics $ Fill unit

clip :: forall m. Monad m => GraphicsT m Unit
clip = liftGraphics $ Clip unit

lineTo :: forall m. Monad m => Number -> Number -> GraphicsT m Unit
lineTo x y = liftGraphics $ LineTo x y unit

moveTo :: forall m. Monad m => Number -> Number -> GraphicsT m Unit
moveTo x y = liftGraphics $ MoveTo x y unit

closePath :: forall m. Monad m => GraphicsT m Unit
closePath = liftGraphics $ ClosePath unit

arc :: forall m. Monad m => Canvas.Arc -> GraphicsT m Unit
arc a = liftGraphics $ Arc a unit

rect :: forall m. Monad m => Canvas.Rectangle -> GraphicsT m Unit
rect r = liftGraphics $ Rect r unit

fillRect :: forall m. Monad m => Canvas.Rectangle -> GraphicsT m Unit
fillRect r = liftGraphics $ FillRect r unit

strokeRect :: forall m. Monad m => Canvas.Rectangle -> GraphicsT m Unit
strokeRect r = liftGraphics $ StrokeRect r unit

clearRect :: forall m. Monad m => Canvas.Rectangle -> GraphicsT m Unit
clearRect r = liftGraphics $ ClearRect r unit

scale :: forall m. Monad m => Number -> Number -> GraphicsT m Unit
scale sx sy = liftGraphics $ Scale sx sy unit

rotate :: forall m. Monad m => Number -> GraphicsT m Unit
rotate th = liftGraphics $ Rotate th unit

translate :: forall m. Monad m => Number -> Number -> GraphicsT m Unit
translate tx ty = liftGraphics $ Translate tx ty unit

transform :: forall m. Monad m => Canvas.Transform -> GraphicsT m Unit
transform tx = liftGraphics $ Transform tx unit

textAlign :: forall m. Monad m => GraphicsT m Canvas.TextAlign
textAlign = liftGraphics $ TextAlign id

setTextAlign :: forall m. Monad m => Canvas.TextAlign -> GraphicsT m Unit
setTextAlign ta = liftGraphics $ SetTextAlign ta unit

font :: forall m. Monad m => GraphicsT m String
font = liftGraphics $ Font id

setFont :: forall m. Monad m => String -> GraphicsT m Unit
setFont f = liftGraphics $ SetFont f unit

fillText :: forall m. Monad m => String -> Number -> Number -> GraphicsT m Unit
fillText s x y = liftGraphics $ FillText s x y unit

strokeText :: forall m. Monad m => String -> Number -> Number -> GraphicsT m Unit
strokeText s x y = liftGraphics $ StrokeText s x y unit

measureText :: forall m. Monad m => String -> GraphicsT m Canvas.TextMetrics
measureText s = liftGraphics $ MeasureText s id

save :: forall m. Monad m => GraphicsT m Unit
save = liftGraphics $ Save unit

restore :: forall m. Monad m => GraphicsT m Unit
restore = liftGraphics $ Restore unit

getImageData :: forall m. Monad m => Number -> Number -> Number -> Number -> GraphicsT m Canvas.ImageData
getImageData x y w h = liftGraphics $ GetImageData x y w h id

putImageData :: forall m. Monad m => Canvas.ImageData -> Number -> Number -> GraphicsT m Unit
putImageData d x y = liftGraphics $ PutImageData d x y unit

putImageDataFull :: forall m. Monad m => Canvas.ImageData -> Number -> Number -> Number -> Number -> Number -> Number -> GraphicsT m Unit
putImageDataFull d x y dx dy dw dh = liftGraphics $ PutImageDataFull d x y dx dy dw dh unit

createImageData :: forall m. Monad m => Number -> Number -> GraphicsT m Canvas.ImageData
createImageData w h = liftGraphics $ CreateImageData w h id

createImageDataCopy :: forall m. Monad m => Canvas.ImageData -> GraphicsT m Canvas.ImageData
createImageDataCopy d = liftGraphics $ CreateImageDataCopy d id

drawImage :: forall m. Monad m => Canvas.CanvasImageSource -> Number -> Number -> GraphicsT m Unit
drawImage src x y = liftGraphics $ DrawImage src x y unit

drawImageScale :: forall m. Monad m => Canvas.CanvasImageSource -> Number -> Number -> Number -> Number -> GraphicsT m Unit
drawImageScale src x y w h = liftGraphics $ DrawImageScale src x y w h unit

drawImageFull :: forall m. Monad m => Canvas.CanvasImageSource -> Number -> Number -> Number -> Number -> Number -> Number -> Number -> Number -> GraphicsT m Unit
drawImageFull src sx sy sw sh dx dy dw dh = liftGraphics $ DrawImageFull src sx sy sw sh dx dy dw dh unit

runGraphics
  :: forall eff
   . Canvas.Context2D
  -> Graphics
  ~> Eff (canvas :: Canvas.CANVAS | eff)
runGraphics ctx = runFreeT (interpretGraphics ctx) <<< hoistFreeT (pure <<< unwrap)

runGraphicsT
  :: forall eff
   . Canvas.Context2D
  -> GraphicsT (Eff (canvas :: Canvas.CANVAS | eff))
  ~> Eff (canvas :: Canvas.CANVAS | eff)
runGraphicsT ctx = runFreeT (interpretGraphics ctx)

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

module Graphics.Canvas.Free
  ( Graphics
  , GraphicsT
  , GraphicsF
  , arc
  , beginPath
  , clearRect
  , clip
  , closePath
  , createImageData
  , createImageDataCopy
  , drawImage
  , fill
  , fillRect
  , fillText
  , font
  , getImageData
  , lineTo
  , measureText
  , moveTo
  , putImageData
  , putImageDataFull
  , rect
  , restore
  , rotate
  , save
  , scale
  , setAlpha
  , setComposite
  , setFillStyle
  , setFont
  , setLineCap
  , setLineWidth
  , setShadowBlur
  , setShadowColor
  , setShadowOffsetX
  , setShadowOffsetY
  , setStrokeStyle
  , setTextAlign
  , stroke
  , strokeRect
  , strokeText
  , textAlign
  , transform
  , translate
  , runGraphics
  , runGraphicsT
  , interpretGraphics
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Free.Trans (FreeT, liftFreeT, hoistFreeT, runFreeT)
import Data.Identity (Identity)
import Data.Newtype (unwrap)
import Graphics.Canvas as Canvas

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 Canvas.LineCap more
  | SetComposite Canvas.Composite more
  | SetAlpha Number more
  | BeginPath more
  | Stroke more
  | Fill more
  | Clip more
  | LineTo Number Number more
  | MoveTo Number Number more
  | ClosePath more
  | Arc Canvas.Arc more
  | Rect Canvas.Rectangle more
  | FillRect Canvas.Rectangle more
  | StrokeRect Canvas.Rectangle more
  | ClearRect Canvas.Rectangle more
  | Scale Number Number more
  | Rotate Number more
  | Translate Number Number more
  | Transform Canvas.Transform more
  | TextAlign (Canvas.TextAlign -> more)
  | SetTextAlign Canvas.TextAlign more
  | Font (String -> more)
  | SetFont String more
  | FillText String Number Number more
  | StrokeText String Number Number more
  | MeasureText String (Canvas.TextMetrics -> more)
  | Save more
  | Restore more
  | GetImageData Number Number Number Number (Canvas.ImageData -> more)
  | PutImageData Canvas.ImageData Number Number more
  | PutImageDataFull Canvas.ImageData Number Number Number Number Number Number more
  | CreateImageData Number Number (Canvas.ImageData -> more)
  | CreateImageDataCopy Canvas.ImageData (Canvas.ImageData -> more)
  | DrawImage Canvas.CanvasImageSource Number Number more

derive instance functorGraphicsF :: Functor GraphicsF

type GraphicsT = FreeT GraphicsF

type Graphics = GraphicsT Identity

liftGraphics :: forall m. Monad m => GraphicsF ~> GraphicsT m
liftGraphics = liftFreeT

setLineWidth :: forall m. Monad m => Number -> GraphicsT m Unit
setLineWidth w = liftGraphics $ SetLineWidth w unit

setFillStyle :: forall m. Monad m => String -> GraphicsT m Unit
setFillStyle s = liftGraphics $ SetFillStyle s unit

setStrokeStyle :: forall m. Monad m => String -> GraphicsT m Unit
setStrokeStyle s = liftGraphics $ SetStrokeStyle s unit

setShadowColor :: forall m. Monad m => String -> GraphicsT m Unit
setShadowColor c = liftGraphics $ SetShadowColor c unit

setShadowBlur :: forall m. Monad m => Number -> GraphicsT m Unit
setShadowBlur n = liftGraphics $ SetShadowBlur n unit

setShadowOffsetX :: forall m. Monad m => Number -> GraphicsT m Unit
setShadowOffsetX n = liftGraphics $ SetShadowOffsetX n unit

setShadowOffsetY :: forall m. Monad m => Number -> GraphicsT m Unit
setShadowOffsetY n = liftGraphics $ SetShadowOffsetY n unit

setLineCap :: forall m. Monad m => Canvas.LineCap -> GraphicsT m Unit
setLineCap lc = liftGraphics $ SetLineCap lc unit

setComposite :: forall m. Monad m => Canvas.Composite -> GraphicsT m Unit
setComposite c = liftGraphics $ SetComposite c unit

setAlpha :: forall m. Monad m => Number -> GraphicsT m Unit
setAlpha a = liftGraphics $ SetAlpha a unit

beginPath :: forall m. Monad m => GraphicsT m Unit
beginPath = liftGraphics $ BeginPath unit

stroke :: forall m. Monad m => GraphicsT m Unit
stroke = liftGraphics $ Stroke unit

fill :: forall m. Monad m => GraphicsT m Unit
fill = liftGraphics $ Fill unit

clip :: forall m. Monad m => GraphicsT m Unit
clip = liftGraphics $ Clip unit

lineTo :: forall m. Monad m => Number -> Number -> GraphicsT m Unit
lineTo x y = liftGraphics $ LineTo x y unit

moveTo :: forall m. Monad m => Number -> Number -> GraphicsT m Unit
moveTo x y = liftGraphics $ MoveTo x y unit

closePath :: forall m. Monad m => GraphicsT m Unit
closePath = liftGraphics $ ClosePath unit

arc :: forall m. Monad m => Canvas.Arc -> GraphicsT m Unit
arc a = liftGraphics $ Arc a unit

rect :: forall m. Monad m => Canvas.Rectangle -> GraphicsT m Unit
rect r = liftGraphics $ Rect r unit

fillRect :: forall m. Monad m => Canvas.Rectangle -> GraphicsT m Unit
fillRect r = liftGraphics $ FillRect r unit

strokeRect :: forall m. Monad m => Canvas.Rectangle -> GraphicsT m Unit
strokeRect r = liftGraphics $ StrokeRect r unit

clearRect :: forall m. Monad m => Canvas.Rectangle -> GraphicsT m Unit
clearRect r = liftGraphics $ ClearRect r unit

scale :: forall m. Monad m => Number -> Number -> GraphicsT m Unit
scale sx sy = liftGraphics $ Scale sx sy unit

rotate :: forall m. Monad m => Number -> GraphicsT m Unit
rotate th = liftGraphics $ Rotate th unit

translate :: forall m. Monad m => Number -> Number -> GraphicsT m Unit
translate tx ty = liftGraphics $ Translate tx ty unit

transform :: forall m. Monad m => Canvas.Transform -> GraphicsT m Unit
transform tx = liftGraphics $ Transform tx unit

textAlign :: forall m. Monad m => GraphicsT m Canvas.TextAlign
textAlign = liftGraphics $ TextAlign id

setTextAlign :: forall m. Monad m => Canvas.TextAlign -> GraphicsT m Unit
setTextAlign ta = liftGraphics $ SetTextAlign ta unit

font :: forall m. Monad m => GraphicsT m String
font = liftGraphics $ Font id

setFont :: forall m. Monad m => String -> GraphicsT m Unit
setFont f = liftGraphics $ SetFont f unit

fillText :: forall m. Monad m => String -> Number -> Number -> GraphicsT m Unit
fillText s x y = liftGraphics $ FillText s x y unit

strokeText :: forall m. Monad m => String -> Number -> Number -> GraphicsT m Unit
strokeText s x y = liftGraphics $ StrokeText s x y unit

measureText :: forall m. Monad m => String -> GraphicsT m Canvas.TextMetrics
measureText s = liftGraphics $ MeasureText s id

save :: forall m. Monad m => GraphicsT m Unit
save = liftGraphics $ Save unit

restore :: forall m. Monad m => GraphicsT m Unit
restore = liftGraphics $ Restore unit

getImageData :: forall m. Monad m => Number -> Number -> Number -> Number -> GraphicsT m Canvas.ImageData
getImageData x y w h = liftGraphics $ GetImageData x y w h id

putImageData :: forall m. Monad m => Canvas.ImageData -> Number -> Number -> GraphicsT m Unit
putImageData d x y = liftGraphics $ PutImageData d x y unit

putImageDataFull :: forall m. Monad m => Canvas.ImageData -> Number -> Number -> Number -> Number -> Number -> Number -> GraphicsT m Unit
putImageDataFull d x y dx dy dw dh = liftGraphics $ PutImageDataFull d x y dx dy dw dh unit

createImageData :: forall m. Monad m => Number -> Number -> GraphicsT m Canvas.ImageData
createImageData w h = liftGraphics $ CreateImageData w h id

createImageDataCopy :: forall m. Monad m => Canvas.ImageData -> GraphicsT m Canvas.ImageData
createImageDataCopy d = liftGraphics $ CreateImageDataCopy d id

drawImage :: forall m. Monad m => Canvas.CanvasImageSource -> Number -> Number -> GraphicsT m Unit
drawImage src x y = liftGraphics $ DrawImage src x y unit

runGraphics
  :: forall eff
   . Canvas.Context2D
  -> Graphics
  ~> Eff (canvas :: Canvas.CANVAS | eff)
runGraphics ctx = runFreeT (interpretGraphics ctx) <<< hoistFreeT (pure <<< unwrap)

runGraphicsT
  :: forall eff
   . Canvas.Context2D
  -> GraphicsT (Eff (canvas :: Canvas.CANVAS | eff))
  ~> Eff (canvas :: Canvas.CANVAS | eff)
runGraphicsT ctx = runFreeT (interpretGraphics ctx)

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


fix warning

fix warning

module Test.Spec.Tree
  ( Tree(..)
  , Item(..)
  , ActionWith
  , bimapTree
  , countTests
  , isAllParallelizable
  , discardUnfocused
  , modifyAroundAction
  , PathItem(..)
  , Path
  , parentSuiteName
  , parentSuite
  ) where

import Prelude

import Control.Monad.State (execState)
import Control.Monad.State as State
import Data.Array (mapMaybe, snoc)
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Array.NonEmpty as NEA
import Data.Bifunctor (class Bifunctor)
import Data.Either (Either, either)
import Data.Foldable (class Foldable, all, foldMapDefaultL, foldl, foldr)
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, un)
import Data.Traversable (for, for_)

data Tree c a
  = Node (Either String c) (Array (Tree c a))
  | Leaf String (Maybe a)

instance showGroup :: (Show c, Show a) => Show (Tree c a) where
  show (Node nc xs) = "(Node " <> show nc <> " " <> show xs <> ")"
  show (Leaf name t) = "(Leaf " <> show name <> " " <> show t <> ")"

instance eqGroup :: (Eq c, Eq a) => Eq (Tree c a) where
  eq (Node nc1 xs1) (Node nc2 xs2) = nc1 == nc2 && xs1 == xs2
  eq (Leaf n1 t1) (Leaf n2 t2) = n1 == n2 && t1 == t2
  eq _                    _                    = false

bimapTree :: forall a b c d. (Array String -> a -> b) -> (NonEmptyArray String ->c -> d) -> Tree a c -> Tree b d
bimapTree g f = go []
  where
    go :: Array String -> Tree a c -> Tree b d
    go namePath spec = case spec of
      Node d xs ->
        let namePath' = either (snoc namePath) (const namePath) d
        in Node (map (g namePath') d) (map (go namePath') xs)
      Leaf n item -> Leaf n (map (f $ NEA.snoc' namePath n) item)

instance treeBifunctor :: Bifunctor Tree where
  bimap g f = bimapTree (const g) (const f)

instance treeFoldable :: Foldable (Tree c) where
  foldr f i (Leaf _ a) = maybe i (\a' -> f a' i) a
  foldr f i (Node _ as) = foldr (\a i' -> foldr f i' a) i as
  foldl f i (Leaf _ a) = maybe i (\a' -> f i a') a
  foldl f i (Node _ as) = foldl (\i' a -> foldl f i' a) i as
  foldMap f = foldMapDefaultL f

type ActionWith m a = a -> m Unit

newtype Item m a = Item
  { isFocused :: Boolean
  , isParallelizable :: Maybe Boolean
  , example :: (ActionWith m a -> m Unit) -> m Unit
  }

derive instance itemNewtype :: Newtype (Item m a) _

instance itemShow :: Show (Item m a) where
  show (Item {isFocused, isParallelizable}) =
    "Item (" <> show {isFocused, isParallelizable, example: "Function"} <> ")"

instance itemEq :: Eq (Item m a) where
  eq (Item a) (Item b) =
    a.isFocused == b.isFocused && a.isParallelizable == b.isParallelizable

-- | Count the total number of tests in a spec
countTests :: forall c t. Array (Tree c t) -> Int
countTests g = execState (for g go) 0
  where
  go (Node _ xs) = for_ xs go
  go (Leaf _ _) = State.modify_ (_ + 1)

-- | Return true if all items in the tree are parallelizable
isAllParallelizable :: forall c m a. Tree c (Item m a) -> Boolean
isAllParallelizable = case _ of
  Node _ xs -> all isAllParallelizable xs
  Leaf _ x -> x == Nothing || (x >>= un Item >>> _.isParallelizable) == Just true

-- | If there is at least one focused element, all paths which don't
-- | lead to a focused element will be remove. otherwise input will
-- | be returned as unchanged.
discardUnfocused :: forall c m a. Array (Tree c (Item m a)) -> Array (Tree c (Item m a))
discardUnfocused ts = case mapMaybe findFocus ts of
  [] -> ts
  r -> r
  where
  findFocus :: Tree c (Item m a) -> Maybe (Tree c (Item m a))
  findFocus (Node n ts') = case mapMaybe findFocus ts' of
    [] -> Nothing
    r -> Just $ Node n r
  findFocus t@(Leaf n (Just (Item { isFocused }))) = if isFocused then Just t else Nothing
  findFocus (Leaf n Nothing) = Nothing

-- | Modify around action of an Item
modifyAroundAction :: forall g a b. (ActionWith g a -> ActionWith g b) -> Item g a -> Item g b
modifyAroundAction action (Item item) = Item $ item
  { example = \aroundAction -> item.example (aroundAction <<< action)
  }

newtype PathItem = PathItem { index :: Int, name :: Maybe String }

derive instance newtypePathItem :: Newtype PathItem _
derive newtype instance showIdTerm :: Show PathItem
derive newtype instance pathItemEq :: Eq PathItem
derive newtype instance pathItemOrd :: Ord PathItem

type Path = Array PathItem

parentSuiteName :: Path -> Array String
parentSuiteName = mapMaybe (un PathItem >>> _.name)

parentSuite :: Path -> Maybe { path :: Path, name :: String }
parentSuite = flip foldr Nothing case _, _ of
  PathItem {name: Just name}, Nothing -> Just {path: [], name}
  PathItem {name: Nothing}, Nothing -> Nothing
  p, Just acc -> Just acc{path = [p] <> acc.path}

module Test.Spec.Tree
  ( Tree(..)
  , Item(..)
  , ActionWith
  , bimapTree
  , countTests
  , isAllParallelizable
  , discardUnfocused
  , modifyAroundAction
  , PathItem(..)
  , Path
  , parentSuiteName
  , parentSuite
  ) where

import Prelude

import Control.Monad.State (execState)
import Control.Monad.State as State
import Data.Array (mapMaybe, snoc, unsnoc)
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Array.NonEmpty as NEA
import Data.Bifunctor (class Bifunctor)
import Data.Either (Either, either)
import Data.Foldable (class Foldable, all, foldMapDefaultL, foldl, foldr)
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, un)
import Data.Traversable (for, for_)
import Data.Tuple (Tuple(..))

data Tree c a
  = Node (Either String c) (Array (Tree c a))
  | Leaf String (Maybe a)

instance showGroup :: (Show c, Show a) => Show (Tree c a) where
  show (Node nc xs) = "(Node " <> show nc <> " " <> show xs <> ")"
  show (Leaf name t) = "(Leaf " <> show name <> " " <> show t <> ")"

instance eqGroup :: (Eq c, Eq a) => Eq (Tree c a) where
  eq (Node nc1 xs1) (Node nc2 xs2) = nc1 == nc2 && xs1 == xs2
  eq (Leaf n1 t1) (Leaf n2 t2) = n1 == n2 && t1 == t2
  eq _                    _                    = false

bimapTree :: forall a b c d. (Array String -> a -> b) -> (NonEmptyArray String ->c -> d) -> Tree a c -> Tree b d
bimapTree g f = go []
  where
    go :: Array String -> Tree a c -> Tree b d
    go namePath spec = case spec of
      Node d xs ->
        let namePath' = either (snoc namePath) (const namePath) d
        in Node (map (g namePath') d) (map (go namePath') xs)
      Leaf n item -> Leaf n (map (f $ NEA.snoc' namePath n) item)

instance treeBifunctor :: Bifunctor Tree where
  bimap g f = bimapTree (const g) (const f)

instance treeFoldable :: Foldable (Tree c) where
  foldr f i (Leaf _ a) = maybe i (\a' -> f a' i) a
  foldr f i (Node _ as) = foldr (\a i' -> foldr f i' a) i as
  foldl f i (Leaf _ a) = maybe i (\a' -> f i a') a
  foldl f i (Node _ as) = foldl (\i' a -> foldl f i' a) i as
  foldMap f = foldMapDefaultL f

type ActionWith m a = a -> m Unit

newtype Item m a = Item
  { isFocused :: Boolean
  , isParallelizable :: Maybe Boolean
  , example :: (ActionWith m a -> m Unit) -> m Unit
  }

derive instance itemNewtype :: Newtype (Item m a) _

instance itemShow :: Show (Item m a) where
  show (Item {isFocused, isParallelizable}) =
    "Item (" <> show {isFocused, isParallelizable, example: "Function"} <> ")"

instance itemEq :: Eq (Item m a) where
  eq (Item a) (Item b) =
    a.isFocused == b.isFocused && a.isParallelizable == b.isParallelizable

-- | Count the total number of tests in a spec
countTests :: forall c t. Array (Tree c t) -> Int
countTests g = execState (for g go) 0
  where
  go (Node _ xs) = for_ xs go
  go (Leaf _ _) = State.modify_ (_ + 1)

-- | Return true if all items in the tree are parallelizable
isAllParallelizable :: forall c m a. Tree c (Item m a) -> Boolean
isAllParallelizable = case _ of
  Node _ xs -> all isAllParallelizable xs
  Leaf _ x -> x == Nothing || (x >>= un Item >>> _.isParallelizable) == Just true

-- | If there is at least one focused element, all paths which don't
-- | lead to a focused element will be remove. otherwise input will
-- | be returned as unchanged.
discardUnfocused :: forall c m a. Array (Tree c (Item m a)) -> Array (Tree c (Item m a))
discardUnfocused ts = case mapMaybe findFocus ts of
  [] -> ts
  r -> r
  where
  findFocus :: Tree c (Item m a) -> Maybe (Tree c (Item m a))
  findFocus (Node n ts') = case mapMaybe findFocus ts' of
    [] -> Nothing
    r -> Just $ Node n r
  findFocus t@(Leaf n (Just (Item { isFocused }))) = if isFocused then Just t else Nothing
  findFocus (Leaf n Nothing) = Nothing

-- | Modify around action of an Item
modifyAroundAction :: forall g a b. (ActionWith g a -> ActionWith g b) -> Item g a -> Item g b
modifyAroundAction action (Item item) = Item $ item
  { example = \aroundAction -> item.example (aroundAction <<< action)
  }

newtype PathItem = PathItem { index :: Int, name :: Maybe String }

derive instance newtypePathItem :: Newtype PathItem _
derive newtype instance showIdTerm :: Show PathItem
derive newtype instance pathItemEq :: Eq PathItem
derive newtype instance pathItemOrd :: Ord PathItem

type Path = Array PathItem

parentSuiteName :: Path -> Array String
parentSuiteName = mapMaybe (un PathItem >>> _.name)

parentSuite :: Path -> Maybe { path :: Path, name :: String }
parentSuite = flip foldr Nothing case _, _ of
  PathItem {name: Just name}, Nothing -> Just {path: [], name}
  PathItem {name: Nothing}, Nothing -> Nothing
  p, Just acc -> Just acc{path = [p] <> acc.path}