Enum instance

Enum instance

module CubeComposer where

import Data.Array
import Data.Enum
import Data.Foldable
import Data.Maybe
import Debug.Trace

data Cube = Blue | Brown | Red | Orange | Yellow

instance showCube :: Show Cube where
    show Blue = "Blue"
    show Brown = "Brown"
    show Red = "Red"
    show Orange = "Orange"
    show Yellow = "Yellow"

instance eqCube :: Eq Cube where
    (==) a b = fromEnum a == fromEnum b
    (/=) a b = not (a == b)

instance ordCube :: Ord Cube where
    compare a b = fromEnum a `compare` fromEnum b

instance enumCube :: Enum Cube where
    cardinality = Cardinality 5
    firstEnum = cubeFirst
    lastEnum = cubeLast
    succ = defaultSucc cubeToEnum cubeFromEnum
    pred = defaultPred cubeToEnum cubeFromEnum
    toEnum = cubeToEnum
    fromEnum = cubeFromEnum

cubeFirst = Blue
cubeLast = Yellow

cubeFromEnum Blue = 0
cubeFromEnum Brown = 1
cubeFromEnum Red = 2
cubeFromEnum Orange = 3
cubeFromEnum Yellow = 4

cubeToEnum 0 = Just Blue
cubeToEnum 1 = Just Brown
cubeToEnum 2 = Just Red
cubeToEnum 3 = Just Orange
cubeToEnum 4 = Just Yellow
cubeToEnum _ = Nothing

type Stack = [Cube]
type Wall = [Stack]

type Transformer = Wall -> Wall

replace :: Cube -> Cube -> Cube -> Cube
replace a b x  = if x == a then b else x

map2d :: (Cube -> Cube) -> Wall -> Wall
map2d = map >>> map

-- | Adaption of Haskells scanl
scanl :: forall a b . (b -> a -> b) -> b -> [a] -> [b]
scanl f bi as = bi : (case as of
                        [] -> []
                        a:as' -> scanl f (f bi a) as')

reject :: forall a. (a -> Boolean) -> [a] -> [a]
reject f = filter (not <<< f)

-- | Successively apply all transformers to the initial wall and return
-- | all intermediate transformation steps
allSteps :: [Transformer] -> Wall -> [Wall]
allSteps ts wi = scanl (flip ($)) wi ts

-------- TRANSFORMERS ----------

tTail :: Transformer
tTail = map ((fromMaybe []) <<< tail)

tReplace :: Transformer
tReplace = map2d (replace Red Blue)

tStackEqual :: Transformer
tStackEqual [] = []
tStackEqual (s:ss) = (concat (s:split.init)) : tStackEqual split.rest
    where split = span (== s) ss

-- | Remove emtpy stacks
tClearEmpty :: Transformer
tClearEmpty = reject null

-------- TESTING -------

ts :: [Transformer]
ts = [
       tStackEqual
     , tReplace
     , tTail
     , tClearEmpty
     ]

initial :: Wall
initial = [[Red], [Red], [Red, Blue], [Red, Blue], [Red, Blue], [Blue]]

main = do
    trace $ "Initial: " ++ (show initial)
    trace "Steps:"
    sequence_ $ map (trace <<< show) $ allSteps ts initial
    trace "---"
    trace ""

module CubeComposer where

import Data.Array
import Data.Foldable
import Data.Maybe
import Debug.Trace

data Cube = Red | Blue

instance showCube :: Show Cube where
    show Red = "Red"
    show Blue = "Blue"

instance eqCube :: Eq Cube where
    (==) Red Red = true
    (==) Blue Blue = true
    (==) Red Blue = false
    (==) Blue Red = false
    (/=) x y = not (x == y)

type Stack = [Cube]
type Wall = [Stack]

type Transformer = Wall -> Wall

replace :: Cube -> Cube -> Cube -> Cube
replace a b x  = if x == a then b else x

map2d :: (Cube -> Cube) -> Wall -> Wall
map2d = map >>> map

-- | Adaption of Haskells scanl
scanl :: forall a b . (b -> a -> b) -> b -> [a] -> [b]
scanl f bi as = bi : (case as of
                        [] -> []
                        a:as' -> scanl f (f bi a) as')

reject :: forall a. (a -> Boolean) -> [a] -> [a]
reject f = filter (not <<< f)

-- | Successively apply all transformers to the initial wall and return
-- | all intermediate transformation steps
allSteps :: [Transformer] -> Wall -> [Wall]
allSteps ts wi = scanl (flip ($)) wi ts

-------- TRANSFORMERS ----------

tTail :: Transformer
tTail = map ((fromMaybe []) <<< tail)

tReplace :: Transformer
tReplace = map2d (replace Red Blue)

tStackEqual :: Transformer
tStackEqual [] = []
tStackEqual (s:ss) = (concat (s:split.init)) : tStackEqual split.rest
    where split = span (== s) ss

-- | Remove emtpy stacks
tClearEmpty :: Transformer
tClearEmpty = reject null

-------- TESTING -------

ts :: [Transformer]
ts = [
       tStackEqual
     , tReplace
     , tTail
     , tClearEmpty
     ]

initial :: Wall
initial = [[Red], [Red], [Red, Blue], [Red, Blue], [Red, Blue], [Blue]]

main = do
    trace $ "Initial: " ++ (show initial)
    trace "Steps:"
    sequence_ $ map (trace <<< show) $ allSteps ts initial
    trace "---"
    trace ""


Updates for 0.5

Updates for 0.5

module Data.Foreign
  ( Foreign(..)
  , ForeignParser(ForeignParser)
  , parseForeign
  , parseJSON
  , ReadForeign
  , read
  , prop
  ) where

import Prelude
import Data.Array
import Data.Either
import Data.Maybe
import Data.Tuple
import Data.Traversable

foreign import data Foreign :: *

foreign import fromString
  "function fromString (str) { \
  \  try { \
  \    return _ps.Data_Either.Right(JSON.parse(str)); \
  \  } catch (e) { \
  \    return _ps.Data_Either.Left(e.toString()); \
  \  } \
  \}" :: String -> Either String Foreign

foreign import readPrimType
  "function readPrimType (typeName) { \
  \  return function (value) { \
  \    if (toString.call(value) == '[object ' + typeName + ']') { \
  \      return _ps.Data_Either.Right(value);\
  \    } \
  \    return _ps.Data_Either.Left('Value is not a ' + typeName + ''); \
  \  }; \
  \}" :: forall a. String -> Foreign -> Either String a

foreign import readMaybeImpl
  "function readMaybeImpl (value) { \
  \  return value === undefined || value === null ? _ps.Data_Maybe.Nothing : _ps.Data_Maybe.Just(value); \
  \}" :: forall a. Foreign -> Maybe Foreign

foreign import readPropImpl
  "function readPropImpl (k) { \
  \  return function (obj) { \
  \    return _ps.Data_Either.Right(obj[k]);\
  \  }; \
  \}" :: forall a. String -> Foreign -> Either String Foreign

foreign import showForeignImpl
  "var showForeignImpl = JSON.stringify;" :: Foreign -> String

instance showForeign :: Prelude.Show Foreign where
  show = showForeignImpl

data ForeignParser a = ForeignParser (Foreign -> Either String a)

parseForeign :: forall a. ForeignParser a -> Foreign -> Either String a
parseForeign (ForeignParser p) x = p x

parseJSON :: forall a. (ReadForeign a) => String -> Either String a
parseJSON json = fromString json >>= parseForeign read

instance functorForeignParser :: Prelude.Functor ForeignParser where
  (<$>) f (ForeignParser p) = ForeignParser \x -> f <$> p x

instance bindForeignParser :: Prelude.Bind ForeignParser where
  (>>=) (ForeignParser p) f = ForeignParser \x -> case p x of
      Left err -> Left err
      Right x' -> parseForeign (f x') x

instance applyForeignParser :: Prelude.Apply ForeignParser where
  (<*>) (ForeignParser f) (ForeignParser p) = ForeignParser \x -> case f x of
      Left err -> Left err
      Right f' -> f' <$> p x

instance applicativeForeignParser :: Prelude.Applicative ForeignParser where
  pure x = ForeignParser \_ -> Right x

instance monadForeignParser :: Prelude.Monad ForeignParser

class ReadForeign a where
  read :: ForeignParser a

instance readString :: ReadForeign String where
  read = ForeignParser $ readPrimType "String"

instance readNumber :: ReadForeign Number where
  read = ForeignParser $ readPrimType "Number"

instance readBoolean :: ReadForeign Boolean where
  read = ForeignParser $ readPrimType "Boolean"

instance readArray :: (ReadForeign a) => ReadForeign [a] where
  read = let
    arrayItem (Tuple i x) = case parseForeign read x of
      Right result -> Right result
      Left err -> Left $ "Error reading item at index " ++ (show i) ++ ":\n" ++ err
    in
    (ForeignParser $ readPrimType "Array") >>= \xs ->
      ForeignParser \_ -> arrayItem `traverse` (zip (range 0 (length xs)) xs)

instance readMaybe :: (ReadForeign a) => ReadForeign (Maybe a) where
  read = (ForeignParser $ Right <<< readMaybeImpl) >>= \x ->
    ForeignParser \_ -> case x of
      Just x' -> parseForeign read x' >>= return <<< Just
      Nothing -> return Nothing

prop :: forall a. (ReadForeign a) => String -> ForeignParser a
prop p = (ForeignParser \x -> readPropImpl p x) >>= \x ->
  ForeignParser \_ -> case parseForeign read x of
    Right result -> Right result
    Left err -> Left $ "Error reading property '" ++ p ++ "':\n" ++ err

module Data.Foreign
  ( Foreign(..)
  , ForeignParser(ForeignParser)
  , parseForeign
  , parseJSON
  , ReadForeign
  , read
  , prop
  ) where

import Prelude
import Data.Array
import Data.Either
import Data.Maybe
import Data.Tuple
import Data.Traversable

foreign import data Foreign :: *

foreign import fromString
  "function fromString (str) { \
  \  try { \
  \    return _ps.Data_Either.Right(JSON.parse(str)); \
  \  } catch (e) { \
  \    return _ps.Data_Either.Left(e.toString()); \
  \  } \
  \}" :: String -> Either String Foreign

foreign import readPrimType
  "function readPrimType (typeName) { \
  \  return function (value) { \
  \    if (toString.call(value) == '[object ' + typeName + ']') { \
  \      return _ps.Data_Either.Right(value);\
  \    } \
  \    return _ps.Data_Either.Left('Value is not a ' + typeName + ''); \
  \  }; \
  \}" :: forall a. String -> Foreign -> Either String a

foreign import readMaybeImpl
  "function readMaybeImpl (value) { \
  \  return value === undefined || value === null ? _ps.Data_Maybe.Nothing : _ps.Data_Maybe.Just(value); \
  \}" :: forall a. Foreign -> Maybe Foreign

foreign import readPropImpl
  "function readPropImpl (k) { \
  \  return function (obj) { \
  \    return _ps.Data_Either.Right(obj[k]);\
  \  }; \
  \}" :: forall a. String -> Foreign -> Either String Foreign

foreign import showForeignImpl
  "var showForeignImpl = JSON.stringify;" :: Foreign -> String

instance showForeign :: Prelude.Show Foreign where
  show = showForeignImpl

data ForeignParser a = ForeignParser (Foreign -> Either String a)

parseForeign :: forall a. ForeignParser a -> Foreign -> Either String a
parseForeign (ForeignParser p) x = p x

parseJSON :: forall a. (ReadForeign a) => String -> Either String a
parseJSON json = fromString json >>= parseForeign read

instance monadForeignParser :: Prelude.Monad ForeignParser where
  return x = ForeignParser \_ -> Right x
  (>>=) (ForeignParser p) f = ForeignParser \x -> case p x of
      Left err -> Left err
      Right x' -> parseForeign (f x') x

instance applicativeForeignParser :: Prelude.Applicative ForeignParser where
  pure x = ForeignParser \_ -> Right x
  (<*>) (ForeignParser f) (ForeignParser p) = ForeignParser \x -> case f x of
      Left err -> Left err
      Right f' -> f' <$> p x

instance functorForeignParser :: Prelude.Functor ForeignParser where
  (<$>) f (ForeignParser p) = ForeignParser \x -> f <$> p x

class ReadForeign a where
  read :: ForeignParser a

instance readString :: ReadForeign String where
  read = ForeignParser $ readPrimType "String"

instance readNumber :: ReadForeign Number where
  read = ForeignParser $ readPrimType "Number"

instance readBoolean :: ReadForeign Boolean where
  read = ForeignParser $ readPrimType "Boolean"

instance readArray :: (ReadForeign a) => ReadForeign [a] where
  read = let
    arrayItem (Tuple i x) = case parseForeign read x of
      Right result -> Right result
      Left err -> Left $ "Error reading item at index " ++ (show i) ++ ":\n" ++ err
    in
    (ForeignParser $ readPrimType "Array") >>= \xs ->
      ForeignParser \_ -> arrayItem `traverse` (zip (range 0 (length xs)) xs)

instance readMaybe :: (ReadForeign a) => ReadForeign (Maybe a) where
  read = (ForeignParser $ Right <<< readMaybeImpl) >>= \x ->
    ForeignParser \_ -> case x of
      Just x' -> parseForeign read x' >>= return <<< Just
      Nothing -> return Nothing

prop :: forall a. (ReadForeign a) => String -> ForeignParser a
prop p = (ForeignParser \x -> readPropImpl p x) >>= \x ->
  ForeignParser \_ -> case parseForeign read x of
    Right result -> Right result
    Left err -> Left $ "Error reading property '" ++ p ++ "':\n" ++ err


Added compare operations

Added compare operations

module Ops where

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

import Types
import MainMem

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

data Dir = Left | Right
derive instance eqDir :: Eq Dir

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

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

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

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

-- Shifts
-- ======

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

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

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

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

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

--DEC R
decReg :: GetReg -> SetReg -> Regs -> Regs
decReg = incDecReg decI8

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

module Ops where

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

import Types
import MainMem

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

data Dir = Left | Right
derive instance eqDir :: Eq Dir

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

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

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

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

-- Shifts
-- ======

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

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

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

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

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

--DEC R
decReg :: GetReg -> SetReg -> Regs -> Regs
decReg = incDecReg decI8

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


Fix alignment

Fix alignment

module Test.Spec.CompatSpec (genCompatSpec) where

import Prelude
import Debug.Trace
import Global (readFloat, readInt)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Aff (Aff(), liftEff')
import Control.Monad.Trans (lift)
import Data.List (List(..), toList, concat, last, init)
import Text.Parsing.Parser as P
import Data.Traversable (traverse)
import Data.Bifunctor (lmap)
import Data.StrMap as StrMap
import Data.StrMap (StrMap())
import Data.Map (Map(..))
import Data.Map as Map
import Data.Tuple (Tuple(..))
import Data.Either (Either(..), either)
import Control.Monad.Eff.Exception (EXCEPTION, error, throwException)
import Data.Foldable (foldl, for_, intercalate)
import Text.Wrap (dedent)
import Control.Monad.Aff (launchAff)

import Test.Assert (assert)
import Test.Spec (Spec(), describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Data.String (fromCharArray)

import Test.Support (vliftEff, runEitherEff, prettyPrintMap)
import Test.Support.Usage  as U
import Test.Support.Docopt as D
import Test.Support.Desc   as Desc

import Language.Docopt (runDocopt)
import Language.Docopt.Value as D

import Data.List (List(..), many, some, (:), toList, concat, singleton, length
                , fromList)
import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt.Parser.Base
import Node.FS (FS)
import Node.Encoding (Encoding(..))
import Node.FS.Sync as FS
import Data.Identity
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Plus (empty)
import Data.Array as A

newtype Test = Test {
  doc   :: String
, kases :: Array Kase
}

newtype Kase = Kase {
  argv :: List String
, out  :: Either String (List (Tuple String D.Value))
}

parseUniversalDocoptTests :: forall eff
  . Eff (fs :: FS, err :: EXCEPTION | eff) (List Test)
parseUniversalDocoptTests = do
  f <- FS.readTextFile UTF8 "testcases.docopt"
  runEitherEff $ P.runParser f do
    many kase <* P.eof

  where
    comment = P.char '#' *> P.manyTill P.anyChar (P.char '\n')
    skipComments = void $ many comment

    kase = do
      P.skipSpaces *> skipComments *>  P.skipSpaces
      u  <- usage
      as <- A.many application
      return $ Test {
        doc: u
      , kases: as <#> \(Tuple i o) -> Kase {
          argv: i
        , out:  o
        }
      }

    application = do
      P.skipSpaces *> skipComments *>  P.skipSpaces
      P.string "$ prog"
      P.skipSpaces
      input <- flip P.sepBy (P.char ' ') do
        many (P.char ' ')
        fromCharArray <$> do
          -- Note: Terminate on '{'. This is hacky and pragmatic,
          -- but it doesn't have to be any more than that...
          A.some $ P.noneOf [ ' ', '{', '\n', '"' ]
      P.skipSpaces *> skipComments *>  P.skipSpaces
      output <- P.choice $ P.try <$>
        [ Right <$> do
            P.between (P.char '{') (P.char '}') do
              flip P.sepBy (P.char ',') do
                P.skipSpaces
                key <- P.between (P.char '"') (P.char '"') do
                        fromCharArray <$> do
                          A.many $ P.noneOf [ '"' ]
                P.skipSpaces *> P.char ':' <* P.skipSpaces
                Tuple key <$> value
        , P.string "\"user-error\""
            *> many (P.char ' ')
            *> P.optional comment
            *> return (Left "user-error")
        ]
      P.skipSpaces *> skipComments *>  P.skipSpaces
      return $ Tuple input output

      where
        value = P.choice $ P.try <$> [
          D.BoolValue <$> do
            P.choice $ P.try <$> [
              P.string "false" *> return false
            , P.string "true"  *> return true
            ]
        , D.StringValue <$> do
            fromCharArray <$> do
              P.between (P.char '"') (P.char '"') (A.many $ P.noneOf ['"'])
        , D.ArrayValue <<< fromList <$> do
            P.between (P.char '[') (P.char ']') do
              P.skipSpaces
              flip P.sepBy (P.skipSpaces *> P.char ',' *> P.skipSpaces) do
                value
        , D.NumberValue <$> do
            xs  <- fromCharArray <$> A.some digit
            P.choice [
              readFloat <$> do
                xss <- do
                  P.char '.'
                  fromCharArray <$> A.some digit
                return $ xs ++ "." ++ xss
            , return $ readInt 10 xs
            ]
        ]

    usage = do
      P.string "r\"\"\""
      fromCharArray <<< fromList <$> do
        P.manyTill P.anyChar $ P.string "\"\"\"\n"

-- Somehow, purescript needs this:
_liftEff :: forall e a. Eff e a -> Aff e a
_liftEff = liftEff

type CompatEff e = (fs :: FS, err :: EXCEPTION | e)

genCompatSpec :: forall e. Aff (CompatEff e) (Unit -> Spec (CompatEff e) Unit)
genCompatSpec = do
  tests <- _liftEff parseUniversalDocoptTests
  return $ \_ -> describe "Docopt compatibility" do
    for_ tests \(Test { doc, kases }) -> do
      describe (doc ++ "\n") do
        for_ kases \(Kase { argv, out }) -> do
          describe (intercalate " " argv) do
            it ("\n" ++ prettyPrintOut out) do
              let result = runDocopt (dedent doc) StrMap.empty (fromList argv)
              vliftEff $ case result of
                Left e ->
                  either
                    (const $ pure unit)
                    (const $ throwException $ error $ show e)
                    out
                Right r -> do
                  either
                    (\_ -> do
                      throwException $ error $
                        "Unexpected output: \n"
                          ++ prettyPrintOut (pure $ Map.toList r)
                    )
                    (\r' ->
                      let r'' = Map.toList r
                       in if (r'' /= r')
                        then throwException $ error $
                          "Unexpected output:\n"
                            ++ prettyPrintOut (pure r'')
                        else return unit)
                    out

  where
    prettyPrintOut :: Either String (List (Tuple String D.Value)) -> String
    prettyPrintOut (Left err) = "fail with " ++ show err
    prettyPrintOut (Right xs)
      = intercalate "\n" $ xs <#> \(Tuple k v) -> k ++ " => " ++ show v


Simplify `forall h a. ST h a -> Effect a` function.

module Test.Node.Buffer.ST (test) where

import Prelude

import Control.Monad.ST (run) as ST
import Effect (Effect)
import Effect.Console (log)
import Node.Buffer.Class (create)
import Node.Buffer.Immutable as Immutable
import Node.Buffer.ST (STBuffer, run)
import Test.Assert (assertEqual)
import Test.Node.Buffer.Class (testMutableBuffer)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

test :: Effect Unit
test = do
  log "Testing Node.Buffer.ST ..."
  testMutableBuffer (Proxy :: Proxy (STBuffer _)) unsafeCoerce
  log " - run"
  testRun

testRun :: Effect Unit
testRun = do
  let buf = Immutable.toArray $ run (create 3)
  assertEqual {expected: [0, 0, 0], actual: buf}

module Test.Node.Buffer.ST (test) where

import Prelude

import Control.Monad.ST (run) as ST
import Effect (Effect)
import Effect.Console (log)
import Node.Buffer.Class (create)
import Node.Buffer.Immutable as Immutable
import Node.Buffer.ST (STBuffer, run)
import Test.Assert (assertEqual)
import Test.Node.Buffer.Class (testMutableBuffer)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

test :: Effect Unit
test = do
  log "Testing Node.Buffer.ST ..."
  testMutableBuffer (Proxy :: Proxy (STBuffer _)) (unsafeCoerce ST.run >>> pure)
  log " - run"
  testRun

testRun :: Effect Unit
testRun = do
  let buf = Immutable.toArray $ run (create 3)
  assertEqual {expected: [0, 0, 0], actual: buf}


[CSM-229] Activate spending password

[CSM-229] Activate spending password

module Daedalus.ClientApi where

import Prelude
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (getProfileLocale, mkCAddress, mkCCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit, mkCWalletRedeem, mkCWalletInitIgnoreChecksum, mkBackupPhrase, mkCInitialized, mkCPaperVendWalletRedeem, mkCPassPhrase)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.String.Base64 as B64
import Data.Base58 as B58
import Data.Array as A
import Data.String (length, stripSuffix, Pattern (..))
import Data.Maybe (isJust, maybe)
import Data.Function.Eff (EffFn1, mkEffFn1, EffFn2, mkEffFn2, EffFn4, mkEffFn4, EffFn5, mkEffFn5, EffFn3, mkEffFn3, EffFn6, mkEffFn6, EffFn7, mkEffFn7)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto

getLocale :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getLocale = fromAff $ map encodeJson (getProfileLocale <$> B.getProfile)

updateLocale :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
updateLocale = mkEffFn1 \locale -> fromAff <<< map encodeJson <<< B.updateProfile $ mkCProfile locale

getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWallets

getWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
getWallet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress

getHistory :: forall eff. EffFn3 (ajax :: AJAX | eff) String Int Int (Promise Json)
getHistory = mkEffFn3 \addr skip limit -> fromAff <<< map encodeJson $
    B.getHistory
        (mkCAddress addr)
        skip
        limit

searchHistory :: forall eff. EffFn4 (ajax :: AJAX | eff) String String Int Int (Promise Json)
searchHistory = mkEffFn4 \addr search skip limit -> fromAff <<< map encodeJson $
    B.searchHistory
        (mkCAddress addr)
        search
        skip
        limit

send :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
send = mkEffFn4 \addrFrom addrTo amount spendingPassword -> fromAff <<< map encodeJson $
    B.send
        (mkCPassPhrase spendingPassword)
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)

sendExtended :: forall eff. EffFn7 (ajax :: AJAX | eff) String String String String String String String (Promise Json)
sendExtended = mkEffFn7 \addrFrom addrTo amount curr title desc spendingPassword -> fromAff <<< map encodeJson $
    B.sendExtended
        (mkCPassPhrase spendingPassword)
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)
        (mkCCurrency curr)
        title
        desc

generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
generateMnemonic = Crypto.generateMnemonic

-- | bip39.validateMnemonic and has at least len words
isValidMnemonic :: forall eff. EffFn2 (crypto :: Crypto.CRYPTO | eff) Int String Boolean
isValidMnemonic = mkEffFn2 \len -> pure <<< either (const false) (const true) <<< mkBackupPhrase len

newWallet :: forall eff . EffFn5 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String String String
  (Promise Json)
newWallet = mkEffFn5 \wType wCurrency wName mnemonic spendingPassword -> fromAff <<< map encodeJson <<<
    either throwError (B.newWallet $ mkCPassPhrase spendingPassword) $ mkCWalletInit wType wCurrency wName mnemonic

-- NOTE: https://issues.serokell.io/issue/DAE-33#comment=96-1798
-- Daedalus.ClientApi.newWallet(
--     'CWTPersonal'
--   , 'ADA'
--   , 'wallet name'
--   , function(mnemonics) {
--     // if this function finishes we will send request for wallet
--     // creation to the backend. That means user validated and
--     // stored mnemonics.
--     // if an exception is thrown new wallet request will be aborted
--     // and promise should return thrown error
--     if(userSavedMnemonics) {
--       // do nothing
--     } else {
--       throw new Error("Wallet canceled")
--     }
--   }
--   )()
--   .then(function(value) {
--     console.log('SUCCESS', value);
--   }, function(reason) {
--     console.log('ERROR', reason);
--   })
-- newWalletDeprecated :: forall eff . Fn4 String String String (EffFn1 (err :: EXCEPTION | eff) String Unit)
--   (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
-- newWalletDeprecated = mkFn4 \wType wCurrency wName wConfirmMnemonic -> fromAff $ map encodeJson $ do
--
--     mnemonic <- liftEff Crypto.generateMnemonic
--     -- FIXME: @jens how did we satisfy this with notify? I am having trouble again
--     isConfirmed <- liftEff' $ unsafeInterleaveEff $ runEffFn1 wConfirmMnemonic mnemonic
--     either throwError B.newWallet $ do
--         isConfirmed
--         mkCWalletInit wType wCurrency wName mnemonic

updateWallet :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Int (Promise Json)
updateWallet = mkEffFn6 \addr wType wCurrency wName wAssurance wUnit -> fromAff <<< map encodeJson <<<
    B.updateWallet
        (mkCAddress addr)
        $ mkCWalletMeta wType wCurrency wName wAssurance wUnit

updateTransaction :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Number (Promise Unit)
updateTransaction = mkEffFn6 \addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
    B.updateTransaction
        (mkCAddress addr)
        (mkCTxId ctxId)
        $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate

deleteWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Unit)
deleteWallet = mkEffFn1 $ fromAff <<< B.deleteWallet <<< mkCAddress

isValidAddress :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Boolean)
isValidAddress = mkEffFn2 \currency -> fromAff <<< B.isValidAddress (mkCCurrency currency)

notify :: forall eff. EffFn2 (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) (NotifyCb eff) (ErrorCb eff) Unit
notify = mkEffFn2 \messageCb errorCb -> do
    -- TODO (akegalj) grab global (mutable) state of  here
    -- instead of creating newRef
    conn <- newRef WSNotConnected
    openConn $ mkWSState conn messageCb errorCb

blockchainSlotDuration :: forall eff. Eff (ajax :: AJAX | eff) (Promise Int)
blockchainSlotDuration = fromAff B.blockchainSlotDuration

restoreWallet :: forall eff. EffFn5 (ajax :: AJAX | eff) String String String String String (Promise Json)
restoreWallet = mkEffFn5 \wType wCurrency wName spendingPassword -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase spendingPassword) <<< mkCWalletInit wType wCurrency wName

restoreWalletIgnoreChecksum :: forall eff. EffFn5 (ajax :: AJAX | eff) String String String String String (Promise Json)
restoreWalletIgnoreChecksum = mkEffFn5 \wType wCurrency wName spendingPassword -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase spendingPassword) <<< mkCWalletInitIgnoreChecksum wType wCurrency wName

nextUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
nextUpdate = fromAff $ map encodeJson B.nextUpdate

applyUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
applyUpdate = fromAff B.applyUpdate

systemVersion :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
systemVersion = fromAff $ map encodeJson B.systemVersion

redeemAda :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String (Promise Json)
redeemAda = mkEffFn2 \seed -> fromAff <<< map encodeJson <<< B.redeemAda <<< mkCWalletRedeem seed

redeemAdaPaperVend :: forall eff. EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String (Promise Json)
redeemAdaPaperVend = mkEffFn3 \seed mnemonic -> fromAff <<< map encodeJson <<< either throwError B.redeemAdaPaperVend <<< mkCPaperVendWalletRedeem seed mnemonic

reportInit :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) Int Int (Promise Unit)
reportInit = mkEffFn2 \total -> fromAff <<< B.reportInit <<< mkCInitialized total

importKey :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
importKey = mkEffFn1 $ fromAff <<< map encodeJson <<< B.importKey

syncProgress :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
syncProgress = fromAff $ map encodeJson B.syncProgress

testReset :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
testReset = fromAff B.testReset

-- Valid redeem code is base64 encoded 32byte data
-- NOTE: this method handles both base64 and base64url base on rfc4648: see more https://github.com/menelaos/purescript-b64/blob/59e2e9189358a4c8e3eef8662ca281906844e783/src/Data/String/Base64.purs#L182
isValidRedemptionKey :: String -> Boolean
isValidRedemptionKey code = either (const false) (const $ endsWithEqual && 44 == length code) $ B64.decode code
  where
    -- Because it is 32byte base64 encoded
    endsWithEqual = isJust $ stripSuffix (Pattern "=") code

-- Valid paper vend key is base58 encoded 32byte data
isValidPaperVendRedemptionKey :: String -> Boolean
isValidPaperVendRedemptionKey code = maybe false ((==) 32 <<< A.length) $ B58.decode code

module Daedalus.ClientApi where

import Prelude
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (getProfileLocale, mkCAddress, mkCCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit, mkCWalletRedeem, mkCWalletInitIgnoreChecksum, mkBackupPhrase, mkCInitialized, mkCPaperVendWalletRedeem, emptyCPassPhrase)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.String.Base64 as B64
import Data.Base58 as B58
import Data.Array as A
import Data.String (length, stripSuffix, Pattern (..))
import Data.Maybe (isJust, maybe)
import Data.Function.Eff (EffFn1, mkEffFn1, EffFn2, mkEffFn2, EffFn4, mkEffFn4, EffFn3, mkEffFn3, EffFn6, mkEffFn6)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto

getLocale :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getLocale = fromAff $ map encodeJson (getProfileLocale <$> B.getProfile)

updateLocale :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
updateLocale = mkEffFn1 \locale -> fromAff <<< map encodeJson <<< B.updateProfile $ mkCProfile locale

getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWallets

getWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
getWallet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress

getHistory :: forall eff. EffFn3 (ajax :: AJAX | eff) String Int Int (Promise Json)
getHistory = mkEffFn3 \addr skip limit -> fromAff <<< map encodeJson $
    B.getHistory
        (mkCAddress addr)
        skip
        limit

searchHistory :: forall eff. EffFn4 (ajax :: AJAX | eff) String String Int Int (Promise Json)
searchHistory = mkEffFn4 \addr search skip limit -> fromAff <<< map encodeJson $
    B.searchHistory
        (mkCAddress addr)
        search
        skip
        limit

send :: forall eff. EffFn3 (ajax :: AJAX | eff) String String String (Promise Json)
send = mkEffFn3 \addrFrom addrTo amount -> fromAff <<< map encodeJson $
    B.send
        emptyCPassPhrase
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)

sendExtended :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String String (Promise Json)
sendExtended = mkEffFn6 \addrFrom addrTo amount curr title desc -> fromAff <<< map encodeJson $
    B.sendExtended
        emptyCPassPhrase
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)
        (mkCCurrency curr)
        title
        desc

generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
generateMnemonic = Crypto.generateMnemonic

-- | bip39.validateMnemonic and has at least len words
isValidMnemonic :: forall eff. EffFn2 (crypto :: Crypto.CRYPTO | eff) Int String Boolean
isValidMnemonic = mkEffFn2 \len -> pure <<< either (const false) (const true) <<< mkBackupPhrase len

newWallet :: forall eff . EffFn4 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String String
  (Promise Json)
newWallet = mkEffFn4 \wType wCurrency wName mnemonic -> fromAff <<< map encodeJson <<<
    either throwError (B.newWallet emptyCPassPhrase) $ mkCWalletInit wType wCurrency wName mnemonic

-- NOTE: https://issues.serokell.io/issue/DAE-33#comment=96-1798
-- Daedalus.ClientApi.newWallet(
--     'CWTPersonal'
--   , 'ADA'
--   , 'wallet name'
--   , function(mnemonics) {
--     // if this function finishes we will send request for wallet
--     // creation to the backend. That means user validated and
--     // stored mnemonics.
--     // if an exception is thrown new wallet request will be aborted
--     // and promise should return thrown error
--     if(userSavedMnemonics) {
--       // do nothing
--     } else {
--       throw new Error("Wallet canceled")
--     }
--   }
--   )()
--   .then(function(value) {
--     console.log('SUCCESS', value);
--   }, function(reason) {
--     console.log('ERROR', reason);
--   })
-- newWalletDeprecated :: forall eff . Fn4 String String String (EffFn1 (err :: EXCEPTION | eff) String Unit)
--   (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
-- newWalletDeprecated = mkFn4 \wType wCurrency wName wConfirmMnemonic -> fromAff $ map encodeJson $ do
--
--     mnemonic <- liftEff Crypto.generateMnemonic
--     -- FIXME: @jens how did we satisfy this with notify? I am having trouble again
--     isConfirmed <- liftEff' $ unsafeInterleaveEff $ runEffFn1 wConfirmMnemonic mnemonic
--     either throwError B.newWallet $ do
--         isConfirmed
--         mkCWalletInit wType wCurrency wName mnemonic

updateWallet :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Int (Promise Json)
updateWallet = mkEffFn6 \addr wType wCurrency wName wAssurance wUnit -> fromAff <<< map encodeJson <<<
    B.updateWallet
        (mkCAddress addr)
        $ mkCWalletMeta wType wCurrency wName wAssurance wUnit

updateTransaction :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Number (Promise Unit)
updateTransaction = mkEffFn6 \addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
    B.updateTransaction
        (mkCAddress addr)
        (mkCTxId ctxId)
        $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate

deleteWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Unit)
deleteWallet = mkEffFn1 $ fromAff <<< B.deleteWallet <<< mkCAddress

isValidAddress :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Boolean)
isValidAddress = mkEffFn2 \currency -> fromAff <<< B.isValidAddress (mkCCurrency currency)

notify :: forall eff. EffFn2 (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) (NotifyCb eff) (ErrorCb eff) Unit
notify = mkEffFn2 \messageCb errorCb -> do
    -- TODO (akegalj) grab global (mutable) state of  here
    -- instead of creating newRef
    conn <- newRef WSNotConnected
    openConn $ mkWSState conn messageCb errorCb

blockchainSlotDuration :: forall eff. Eff (ajax :: AJAX | eff) (Promise Int)
blockchainSlotDuration = fromAff B.blockchainSlotDuration

restoreWallet :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
restoreWallet = mkEffFn4 \wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ emptyCPassPhrase) <<< mkCWalletInit wType wCurrency wName

restoreWalletIgnoreChecksum :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
restoreWalletIgnoreChecksum = mkEffFn4 \wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ emptyCPassPhrase) <<< mkCWalletInitIgnoreChecksum wType wCurrency wName

nextUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
nextUpdate = fromAff $ map encodeJson B.nextUpdate

applyUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
applyUpdate = fromAff B.applyUpdate

systemVersion :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
systemVersion = fromAff $ map encodeJson B.systemVersion

redeemAda :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String (Promise Json)
redeemAda = mkEffFn2 \seed -> fromAff <<< map encodeJson <<< B.redeemAda <<< mkCWalletRedeem seed

redeemAdaPaperVend :: forall eff. EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String (Promise Json)
redeemAdaPaperVend = mkEffFn3 \seed mnemonic -> fromAff <<< map encodeJson <<< either throwError B.redeemAdaPaperVend <<< mkCPaperVendWalletRedeem seed mnemonic

reportInit :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) Int Int (Promise Unit)
reportInit = mkEffFn2 \total -> fromAff <<< B.reportInit <<< mkCInitialized total

importKey :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
importKey = mkEffFn1 $ fromAff <<< map encodeJson <<< B.importKey

syncProgress :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
syncProgress = fromAff $ map encodeJson B.syncProgress

testReset :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
testReset = fromAff B.testReset

-- Valid redeem code is base64 encoded 32byte data
-- NOTE: this method handles both base64 and base64url base on rfc4648: see more https://github.com/menelaos/purescript-b64/blob/59e2e9189358a4c8e3eef8662ca281906844e783/src/Data/String/Base64.purs#L182
isValidRedemptionKey :: String -> Boolean
isValidRedemptionKey code = either (const false) (const $ endsWithEqual && 44 == length code) $ B64.decode code
  where
    -- Because it is 32byte base64 encoded
    endsWithEqual = isJust $ stripSuffix (Pattern "=") code

-- Valid paper vend key is base58 encoded 32byte data
isValidPaperVendRedemptionKey :: String -> Boolean
isValidPaperVendRedemptionKey code = maybe false ((==) 32 <<< A.length) $ B58.decode code


Overly legalize names for now

Overly legalize names for now

Original commit c374d72cfdb9eb54f080dfab056c7b88ae786b6e

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (for_, intercalate, maximum)

import Data.List as L

import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Set (Set)
import Data.Set as S

import Data.String as Str
import Data.String.Util as Str

import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util (camelCase, capitalize)

import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)
import Data.Either as Either

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> s <> "_"
        , forbiddenNames: []
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = interfaceNamify $ combineNames names

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    isLetterCharacter c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "null"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderType a
        pure $ "Array<" <> rendered <> ">"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> renderUnion $ unionToSet types

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = "'" <> s <> "'"
    | otherwise =
        case Str.charAt 0 s of
            Nothing -> "Empty"
            Just _ -> "'" <> s <> "'"

hasInternalSeparator :: Rx.Regex
hasInternalSeparator = unsafePartial $ Either.fromRight $ Rx.regex "[-. ]" RxFlags.noFlags

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    top <- getTopLevel >>= renderType
    module_ <- getTopLevelNameGiven
    line $ """// To parse this JSON data:
//
//     import * as """ <> module_  <> """ from "./""" <> module_  <> """";
//     let value = """ <> module_  <> """.Convert.fromJson(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank
    converter

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.empty) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromSet $ unionToSet unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNothing -> pure "'undefined'" -- we can have arrays of nothing
    IRNull -> pure "'undefined'"
    IRInteger -> pure "'number'"
    IRDouble -> pure "'number'"
    IRBool -> pure "'boolean'"
    IRString -> pure "'string'"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object('" <> name <> "')"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapM renderTypeMapType $ L.fromFoldable $ unionToSet types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: IRClassData -> String -> Doc Unit
renderTypeMapClass (IRClassData { names, properties }) className = do
    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        for_ props \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ propertyNamify pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line "// The typeMap is used to assert that objects from"
    line "// JSON.parse conform to the types we expect them to."
    line $ "const typeMap = {"
    indent do
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderTypeMapClass cd className
    line $ "};"

converter :: Doc Unit
converter = do
    top <- getTopLevel >>= renderType
    topTypeMap <- getTopLevel >>= renderTypeMapType

    line $ """export module Convert {
    let path = [];

    export function fromJson(json: string): """ <> top <> """ {
        return cast(JSON.parse(json), """ <> topTypeMap <> """);
    }

    export function toJson(value: """ <> top <> """): string {
        return JSON.stringify(value);
    }

    function cast<T>(obj: any, typ: any): T {
        path = [];
        if (!isValid(typ, obj)) {
            throw `Invalid value: obj${path.join("")}`
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        return typ.isUnion  ? isValidUnion(typ.typs, val)
             : typ.isArray  ? isValidArray(typ.typ, val)
             : typ.isMap    ? isValidMap(typ.typ, val)
             : typ.isObject ? isValidObject(typ.cls, val)
             :                isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == 'undefined') return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`['${prop}']`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (for_, intercalate, maximum)

import Data.List as L

import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Set (Set)
import Data.Set as S

import Data.String as Str
import Data.String.Util as Str

import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util (camelCase, capitalize)

import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)
import Data.Either as Either

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> s <> "_"
        , forbiddenNames: []
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = interfaceNamify $ combineNames names

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    isLetterCharacter c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "null"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderType a
        pure $ "Array<" <> rendered <> ">"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> renderUnion $ unionToSet types

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = "'" <> s <> "'"
    | otherwise =
        case Str.charAt 0 s of
            Nothing -> "Empty"
            Just c | isStartCharacter c -> s
                   | otherwise -> "'" <> s <> "'"

hasInternalSeparator :: Rx.Regex
hasInternalSeparator = unsafePartial $ Either.fromRight $ Rx.regex "[-. ]" RxFlags.noFlags

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    top <- getTopLevel >>= renderType
    module_ <- getTopLevelNameGiven
    line $ """// To parse this JSON data:
//
//     import * as """ <> module_  <> """ from "./""" <> module_  <> """";
//     let value = """ <> module_  <> """.Convert.fromJson(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank
    converter

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.empty) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromSet $ unionToSet unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNothing -> pure "'undefined'" -- we can have arrays of nothing
    IRNull -> pure "'undefined'"
    IRInteger -> pure "'number'"
    IRDouble -> pure "'number'"
    IRBool -> pure "'boolean'"
    IRString -> pure "'string'"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object('" <> name <> "')"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapM renderTypeMapType $ L.fromFoldable $ unionToSet types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: IRClassData -> String -> Doc Unit
renderTypeMapClass (IRClassData { names, properties }) className = do
    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        for_ props \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ propertyNamify pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line "// The typeMap is used to assert that objects from"
    line "// JSON.parse conform to the types we expect them to."
    line $ "const typeMap = {"
    indent do
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderTypeMapClass cd className
    line $ "};"

converter :: Doc Unit
converter = do
    top <- getTopLevel >>= renderType
    topTypeMap <- getTopLevel >>= renderTypeMapType

    line $ """export module Convert {
    let path = [];

    export function fromJson(json: string): """ <> top <> """ {
        return cast(JSON.parse(json), """ <> topTypeMap <> """);
    }

    export function toJson(value: """ <> top <> """): string {
        return JSON.stringify(value);
    }

    function cast<T>(obj: any, typ: any): T {
        path = [];
        if (!isValid(typ, obj)) {
            throw `Invalid value: obj${path.join("")}`
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        return typ.isUnion  ? isValidUnion(typ.typs, val)
             : typ.isArray  ? isValidArray(typ.typ, val)
             : typ.isMap    ? isValidMap(typ.typ, val)
             : typ.isObject ? isValidObject(typ.cls, val)
             :                isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == 'undefined') return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`['${prop}']`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""


Add a test case.

Add a test case.

Add a test case for skipping whitespace around the equals sign in an argument with unquoted value.

module Test.Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Data.Either
import Data.Foldable
import Data.List
import Text.Parsing.StringParser (ParseError(..))

import Text.HTML.Parser
import Text.HTML.Parser.Array

import Test.Utils

main :: Eff (console :: CONSOLE) Unit
main = runTest do
  assertParse ""
    [ element "html" [] [] ]

  assertParse ""
    [ element "html" [] $
        [ element "body" [] []
        , element "head" [] []
        ]
    ]

  assertParse "
"
    [ voidElement "br" [] ]

  assertParse "

"
    [ element "p" [] [voidElement "br" []] ]

  assertParse "

"
    [ element "div" [] []
    , element "span" [] []
    ]

  assertParse "
hellobigworld!
"
    [ element "div" []
      [ textNode "hello"
      , element "em" [] [textNode "big"]
      , textNode "world!"
      ]
    ]

  assertParse """

"""
    [ element "div"
      [ Attribute "id" "foo"
      , Attribute "class" "bar"
      ] []
    ]

  assertParse """

"""
    [ element "div"
      [ Attribute "id" "foo"
      , Attribute "disabled" ""
      , Attribute "class" """bar"""
      ] []
    ]

  assertParse """

"""
    [ element "div" [Attribute "id" "foo"]
      [ voidElement "img" [Attribute "src" "puppies.gif"] ]
    ]

    -- See if whitespace after attributes affect parsing...
  assertParse """
"""
    [ voidElement "br" [Attribute "class" "solid"]
    ]

    -- See if unquoted attribute value is parsed properly...
  assertParse """
"""
    [ voidElement "br" [Attribute "class" "solid"]
    ]

    -- See if spaces around the equals sign affect attribute parsing...
  assertParse """
"""
    [ voidElement "br" [Attribute "class" "solid"]
    ]

    -- See if spaces around the equals sign affect attribute parsing if argument value is not
    --        quoted...

  assertParse """
"""
    [ voidElement "br" [Attribute "class" "solid"]
    ]

assertParse
  :: forall eff f. (Foldable f)
  => String -> f HTML -> Eff (console :: CONSOLE | eff) Unit
assertParse input expected = case parseHTML input of
  Left (ParseError e) ->
    fail $ "Parse error for " <> show input <> "\n  Error: " <> e
  Right actual | actual /= expected' ->
    fail $ "Expected: " <> show expected' <> "\n  Actual: " <> show actual
  _ -> success input
  where
  expected' = fromFoldable expected

module Test.Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Data.Either
import Data.Foldable
import Data.List
import Text.Parsing.StringParser (ParseError(..))

import Text.HTML.Parser
import Text.HTML.Parser.Array

import Test.Utils

main :: Eff (console :: CONSOLE) Unit
main = runTest do
  assertParse ""
    [ element "html" [] [] ]

  assertParse ""
    [ element "html" [] $
        [ element "body" [] []
        , element "head" [] []
        ]
    ]

  assertParse "
"
    [ voidElement "br" [] ]

  assertParse "

"
    [ element "p" [] [voidElement "br" []] ]

  assertParse "

"
    [ element "div" [] []
    , element "span" [] []
    ]

  assertParse "
hellobigworld!
"
    [ element "div" []
      [ textNode "hello"
      , element "em" [] [textNode "big"]
      , textNode "world!"
      ]
    ]

  assertParse """

"""
    [ element "div"
      [ Attribute "id" "foo"
      , Attribute "class" "bar"
      ] []
    ]

  assertParse """

"""
    [ element "div"
      [ Attribute "id" "foo"
      , Attribute "disabled" ""
      , Attribute "class" """bar"""
      ] []
    ]

  assertParse """

"""
    [ element "div" [Attribute "id" "foo"]
      [ voidElement "img" [Attribute "src" "puppies.gif"] ]
    ]

    -- See if whitespace after attributes affect parsing...
  assertParse """
"""
    [ voidElement "br" [Attribute "class" "solid"]
    ]

    -- See if unquoted attribute value is parsed properly...
  assertParse """
"""
    [ voidElement "br" [Attribute "class" "solid"]
    ]

    -- See if spaces around the equals sign affect attribute parsing...
  assertParse """
"""
    [ voidElement "br" [Attribute "class" "solid"]
    ]

assertParse
  :: forall eff f. (Foldable f)
  => String -> f HTML -> Eff (console :: CONSOLE | eff) Unit
assertParse input expected = case parseHTML input of
  Left (ParseError e) ->
    fail $ "Parse error for " <> show input <> "\n  Error: " <> e
  Right actual | actual /= expected' ->
    fail $ "Expected: " <> show expected' <> "\n  Actual: " <> show actual
  _ -> success input
  where
  expected' = fromFoldable expected


Remove unnecessary module for client-side grouping

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Chart.PivotTableRenderer.Pivot
  ( Pivot
  , Dimension
  , classify
  , classify'
  , fold
  , Spine(..)
  , unSpine
  , spine
  ) where

import SlamData.Prelude hiding (fold)
import Data.Unfoldable (class Unfoldable)
import Data.Map (Map)
import Data.Map as Map
import Data.List (List(..), (:))
import Data.List as List

data Pivot k (f ∷ * → *) a
  = Group (Map k (Pivot k f a))
  | Bucket (f a)

type Dimension a k = a → Maybe k

classify
  ∷ ∀ k f a
  . (Foldable f, Unfoldable f, Ord k)
  ⇒ List (Dimension a k)
  → f a
  → Pivot k f a
classify Nil rs = Bucket rs
classify (key : ds) rs =
  Group
    (map (classify ds <<< List.toUnfoldable <<< List.reverse)
      (foldl (updateIndex key) Map.empty
        rs))

classify'
  ∷ ∀ k f a
  . (Foldable f, Unfoldable f, Monoid (f a), Ord k)
  ⇒ List (Dimension a k)
  → f a
  → Pivot k f a
  → Maybe (Pivot k f a)
classify' ds rs p =
  case ds, p of
    Nil, Group _        → Nothing
    Nil, Bucket rs'     → Just (Bucket (rs' <> rs))
    key : ds', Bucket _ → Nothing
    key : ds', Group m  →
      map Group
        (foldl (go ds') (pure m)
          (Map.toList
            (foldl (updateIndex key) Map.empty
              rs)))
  where
  go _ Nothing _ = Nothing
  go ds' (Just m) (Tuple k rs') =
    let
      rs'' = List.toUnfoldable (List.reverse rs')
    in case Map.lookup k m of
      Just p →
        case classify' ds' rs'' p of
          Just p' → pure (Map.insert k p' m)
          Nothing → Nothing
      Nothing →
        pure
          (Map.insert k
            (classify ds' rs'') m)

updateIndex
  ∷ ∀ a k
  . Ord k
  ⇒ (a → Maybe k)
  → Map k (List a)
  → a
  → Map k (List a)
updateIndex f m r =
  case f r of
    Just k  → Map.alter (insert r) k m
    Nothing → m
  where
  insert a r =
    case r of
      Just as → Just (a : as)
      Nothing → Just (List.singleton a)

fold
  ∷ ∀ k f a r
  . (f a → r)
  → (Map k r → r)
  → Pivot k f a
  → r
fold f g (Bucket as) = f as
fold f g (Group m) = g (fold f g <$> m)

newtype Spine k a =
  Spine (a × (Maybe (Map k (Spine k a))))

unSpine ∷ ∀ k a. Spine k a → a × Maybe (Map k (Spine k a))
unSpine (Spine t) = t

spine
  ∷ ∀ k f a b c
  . Monoid b
  ⇒ (f a → b × c)
  → (Map k c → c)
  → Pivot k f a
  → b × (Spine k c)
spine f g = fold f' g'
  where
  f' as = map (\a → Spine (Tuple a Nothing)) (f as)
  g' m  =
    let
      bs = foldMap fst m
      cs = map snd m
      c' = g (map (fst <<< unSpine) cs)
    in
bs × (Spine (c' × (Just cs)))