Added more unit tests

Added more unit tests

module Test.Main where

import Prelude hiding (degree)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)

import Data.StrMap (insert)
import Data.Either(Either(..))
import Data.Foldable (traverse_)

import Test.Unit (suite, test, failure)
import Test.Unit.Main (runTest)
import Test.Unit.Console (TESTOUTPUT)

import Text.Parsing.Parser (parseErrorMessage, parseErrorPosition)
import Text.Parsing.Parser.Pos (Position(..))

import Quantities ((./), (.*), milli, nano, meter, inch, hour, minute, kilo,
                   mile, gram, second, deci, tera, hertz, degree, radian)

import Insect.Language (Func(..), BinOp(..), Expression(..), Statement(..))
import Insect.Parser (parseInsect)
import Insect.Environment (Environment, initialEnvironment)
import Insect (repl)

shouldParseAs ∷ ∀ eff. Statement → String → Aff eff Unit
shouldParseAs expected input =
  case parseInsect input of
    Left err →
      case parseErrorPosition err of
        (Position pos) →
          failure $ "Parse error for input '" <> input <> "': "
                                <> parseErrorMessage err
                                <> " at position "
                                <> show pos.column
    Right output →
      unless (output == expected) $ do
        failure $ "Unexpected result:\n" <>
                  "Input:    '" <> input <> "'\n" <>
                  "Output:   " <> show output <> "\n" <>
                  "Expected: " <> show expected <> "\n"

allParseAs ∷ ∀ eff. Statement → Array String → Aff eff Unit
allParseAs expected = traverse_ (shouldParseAs expected)

shouldFail ∷ ∀ eff. String → Aff eff Unit
shouldFail input = do
  case parseInsect input of
   Left _ → pure unit
   Right output → failure $ "input is expected to throw a parse error: '" <> input <> "'"

expectOutput ∷ ∀ eff. Environment → String → String → Aff eff Unit
expectOutput env expected inp =
  let res = repl env inp
      out = res.msg
  in
    unless (out == expected) do
      failure $ "Unexpected result:\n" <>
                "Input:    '" <> inp <> "'\n" <>
                "Output:   '" <> out <> "'\n" <>
                "Expected: '" <> expected <> "'\n"

main ∷ Eff (console ∷ CONSOLE, testOutput ∷ TESTOUTPUT, avar ∷ AVAR) Unit
main = runTest do
  -- Helper to construct quantities
  let q s u = BinOp Mul (Scalar s) (Unit u)

  suite "Parser - Numbers" do
    test "Simple numbers" do
      allParseAs (Expression (Scalar 1.0))
        [ "1"
        , "1.0"
        , "  1  "
        , " 1.0000   "
        , " +1.0   "
        , "+1"
        ]

      allParseAs (Expression (Scalar 3.5))
        [ "3.5"
        , "  3.5  "
        , "3.50"
        , "+3.50"
        ]

      shouldFail "123.."
      shouldFail "0.."
      shouldFail ".0."
      shouldFail "."
      shouldFail ".2"

    test "Large numbers" do
      allParseAs (Expression (Scalar 1234567890000000.0))
        [ "1234567890000000"
        , "1234567890000000.0"
        , "+1234567890000000.0"
        ]

    test "Negative numbers" do
      shouldParseAs (Expression (Negate (Scalar 123.45)))
        "-123.45"

    test "Exponential notation" do
      shouldParseAs (Expression (Negate (Scalar 1.3e13)))
        "-1.3e13"

      shouldParseAs (Expression (Scalar 2.7e-3))
        "2.7e-3"

      shouldFail "2.7e 3"
      shouldFail "123e+"
      shouldFail "1223e++2"
      shouldFail "1223e+-2"

  suite "Parser - Units" do
    test "Simple" do
      allParseAs (Expression (Unit meter))
        [ "m"
        , "      m "
        , "meter"
        , "meters"
        ]

      allParseAs (Expression (Unit inch))
        [ "in"
        , "      in "
        , "inch"
        , "inches"
        ]

      allParseAs (Expression (Unit degree))
        [ "°"
        , "      ° "
        , "deg"
        , "degree"
        , "degrees"
        ]

  suite "Parser - Quantities" do
    test "Simple" do
      allParseAs (Expression (q 2.3 meter))
        [ "2.3*m"
        , " 2.3 * m "
        , "2.3m"
        , "  2.3 m "
        , "2.3meter"
        , "2.3 meter"
        , "2.3meters"
        ]

      allParseAs (Expression (q 5.0 second))
        [ "5s"
        , "5second"
        , "5 seconds"
        ]

      allParseAs (Expression (q 5.0 gram))
        [ "5g"
        , "5gram"
        , "5 grams"
        ]

      allParseAs (Expression (q 10.0 mile))
        [ "10miles"
        , "10mile"
        ]

      allParseAs (Expression (q 10.0 inch))
        [ "10inches"
        , "10inch"
        , "10in"
        ]

      allParseAs (Expression (q 360.0 degree))
        [ "360degrees"
        , "360degree"
        , "360deg"
        , "360°"
        , "360.0°"
        ]

      allParseAs (Expression (q 1.0 radian))
        [ "1.0rad"
        , "1.0 radian"
        , "1.0 radians"
        ]

    test "SI prefixes" do
      allParseAs (Expression (q 2.3 (kilo meter)))
        [ "2.3km"
        , "  2.3 km "
        , "  2.3 kmeter "
        , "  2.3 kmeters "
        ]

      allParseAs (Expression (q 2.3 (milli meter)))
        [ "2.3mm"
        , "  2.3 mm "
        , "  2.3 mmeter "
        , "  2.3 mmeters "
        ]

      allParseAs (Expression (q 2.3 (nano gram)))
        [ "2.3ng"
        , "  2.3 ng "
        ]

      allParseAs (Expression (q 2.3 (kilo minute)))
        [ "2.3kmin"
        , "  2.3 kmin "
        ]

      allParseAs (Expression (q 2.3 (deci meter)))
        [ "2.3dm"
        , "  2.3 dm "
        ]

      allParseAs (Expression (q 42.3 (tera hertz)))
        [ "42.3THz"
        , "42.3Thertz"
        ]

    test "Divisions" do
      allParseAs (Expression (BinOp Mul (Scalar 2.3) (BinOp Div (Unit (kilo meter)) (Unit hour))))
        [ "2.3km/h"
        , "2.30km/h"
        ]

  suite "Parser - Operators" do
    test "Exponentiation" do
      allParseAs (Expression (BinOp Pow (Scalar 5.0) (Scalar 3.0))) $
        [ "5^3"
        , " 5 ^ 3 "
        , " ( 5 ) ^ ( 3 ) "
        , " ( ( 5 ) ^ ( 3 ) ) "
        , " ( 5 ^ 3 ) "
        , "5^(+3)"
        , "+5^3"
        ]

      shouldParseAs (Expression (BinOp Pow (Scalar 2.0) (BinOp Pow (Scalar 3.0) (BinOp Pow (Scalar 4.0) (Scalar 5.0))))) $
        "2^3^4^5"

      allParseAs (Expression (BinOp Pow (Scalar 4.0) (Scalar 3.0))) $
        [ "4^3"
        , "4 ^ 3"
        , "4**3"
        , "4 ** 3"
        , "4³"
        , "4  ³"
        ]

      allParseAs (Expression (BinOp Pow (Variable "pi") (Scalar 2.0))) $
        [ "pi^2"
        , "pi ^ 2"
        , "pi**2"
        , "pi ** 2"
        , "pi²"
        , "(pi)²"
        ]

      allParseAs (Expression (Negate (BinOp Pow (Scalar 3.0) (Scalar 4.0)))) $
        [ "-3^4"
        , "-3 ^ 4"
        , "-3**4"
        , "-3 ** 4"
        , "-(3^4)"
        ]

      allParseAs (Expression (BinOp Pow (Scalar 3.0) (Negate (Scalar 1.4)))) $
        [ "3 ^ (-1.4)"
        , "3 ** (-1.4)"
        ]

      shouldFail "³"
      shouldFail "³2"
      shouldFail "2^"
      shouldFail "^2"

    test "Multiplication" do
      allParseAs (Expression (BinOp Mul (Scalar 5.0) (Scalar 3.0))) $
        [ "5*3"
        , " 5 * 3 "
        , " ( 5 ) * ( 3 ) "
        , " ( 5 ) ( 3 ) "
        , " ( ( 5 ) * ( 3 ) ) "
        , " ( 5 * 3 ) "
        , "5(3)"
        , "(5)3"
        , "5(+3)"
        , "+5*3"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 5.0) (Negate $ Scalar 3.0))) $
        [ "5*(-3)"
        , " 5 * (-3) "
        , " ( 5 ) * ( -3 ) "
        , " ( ( 5 ) * (-( 3 )) ) "
        , " ( 5 * (-3) ) "
        , "+5*(-3)"
        ]

      shouldFail "5*"

    test "Division" do
      allParseAs (Expression (BinOp Div (Scalar 5.0) (Scalar 3.0))) $
        [ "5/3"
        , " 5 / 3 "
        , " ( 5 ) / ( 3 ) "
        , " ( ( 5 ) / ( 3 ) ) "
        , " ( 5 / 3 ) "
        ]

      shouldFail "5/"

    test "Addition" do
      allParseAs (Expression (BinOp Add (Scalar 5.0) (Scalar 3.0))) $
        [ "5+3"
        , " 5 + 3 "
        , " ( 5 ) + ( 3 ) "
        , " ( ( 5 ) + ( 3 ) ) "
        , " ( 5 + 3 ) "
        ]

      shouldFail "3 + "
      shouldFail "3 + @"

    test "Subtraction" do
      allParseAs (Expression (BinOp Sub (Scalar 5.0) (Scalar 3.0))) $
        [ "5-3"
        , " 5 - 3 "
        , " ( 5 ) - ( 3 ) "
        , " ( ( 5 ) - ( 3 ) ) "
        , " ( 5 - 3 ) "
        ]

      shouldFail "3 - "

    test "Precedence" do
      allParseAs (Expression (BinOp Add (q 5.0 meter) (BinOp Mul (q 3.0 inch) (Scalar 7.0)))) $
        [ "5m+3in*7"
        , "5m+(3in*7)"
        , "5m+(3in·7)"
        , "  5 m +   3  in * 7    "
        ]

      allParseAs (Expression (BinOp Mul (BinOp Add (q 5.0 meter) (q 3.0 inch)) (Scalar 7.0))) $
        [ "(5m+3in)*7"
        , "((5m+3in))*7"
        , "(((((((5m))+((3in)))))))*((7))"
        , "  (  5 m + ( 3  in )  )  * 7    "
        ]

      allParseAs (Expression (BinOp Mul (BinOp Div (Scalar 5.0) (Scalar 3.0)) (Scalar 2.0)))
        [ "5/3*2"
        , "(5/3)*2"
        ]

      shouldFail "3+*4"
      shouldFail "3*/4"
      shouldFail "(3+4"
      shouldFail "3+4)"
      shouldFail "3+("
      shouldFail "()"
      shouldFail "(3+)4"

    test "Multiple division" do
      allParseAs (Expression (BinOp Div (BinOp Div (Scalar 42.0) (Scalar 7.0)) (Scalar 3.0))) $
        [ "42/7/3"
        , "(42/7)/3"
        ]

    test "Involving units" do
      allParseAs (Expression (BinOp Pow (q 3.0 meter) (Scalar 2.0))) $
        [ "(3m)^2"
        , "(3.0m)^(2.0)"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 3.0) (BinOp Pow (Unit meter) (Scalar 2.0)))) $
        [ "3m^2"
        , "3.0(m)^(2.0)"
        , "3m²"
        , "3 m²"
        , "3·m²"
        , "3·m^(2.0)"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 3.0) (BinOp Div (Unit meter) (Unit second)))) $
        [ "3m/s"
        , "3·m/s"
        , "3 meter / second"
        , "3 meter / sec"
        ]

      allParseAs (Expression (BinOp Pow (Unit meter) (Negate $ Scalar 1.0))) $
        [ "m^(-1)"
        , "m^(-1.0)"
        , "meter^(-1.0)"
        ]

  suite "Parser - Conversions" do
    test "Simple" do
      allParseAs (Expression (BinOp ConvertTo (q (2.3) meter) (Unit inch)))
        [ "2.3m -> in"
        , "  2.3 meters->inches "
        , "  2.3 m  ->  in "
        ]

      allParseAs (Expression (BinOp ConvertTo (q 120.0 minute) (Unit hour)))
        [ "120min -> h"
        , "120minutes -> hours"
        ]

      shouldFail "2.3m->"

    test "Complex units" do
      allParseAs (Expression (BinOp ConvertTo (BinOp Mul (Scalar 36.0) (BinOp Div (Unit (kilo meter)) (Unit hour))) (Unit (mile ./ hour))))
        [ "36km/h -> mph"
        , "36·km/h -> mph"
        ]

      allParseAs (Expression (BinOp ConvertTo (BinOp Mul (Scalar 36.0) (BinOp Div (Unit (kilo meter)) (Unit hour))) (BinOp Div (Unit meter) (Unit second))))
        [ "36km/h -> m/s"
        , "36·km/h -> m/s"
        ]

  suite "Parser - Identifiers" do
    test "Valid and invalid names" do
      shouldParseAs (Expression (Variable "x")) "x"
      shouldParseAs (Expression (Variable "µ")) "µ"
      shouldParseAs (Expression (Variable "pi")) "pi"
      shouldParseAs (Expression (Variable "x_2")) "x_2"
      shouldParseAs (Expression (Variable "länge")) "länge"
      shouldParseAs (Expression (Variable "_prefixed")) "_prefixed"
      shouldParseAs (Expression (Variable "x'")) "x'"
      shouldParseAs (Expression (Variable "t''")) "t''"

      shouldFail "xs,as"
      shouldFail "hello$"

    test "Variables which begin like units" do
      shouldParseAs (Expression (Variable "myVariable")) "myVariable"
      shouldParseAs (Expression (Variable "density")) "density"

  suite "Parser - Functions" do
    test "Simple" do
      allParseAs (Expression (Apply Sin (q 30.0 degree)))
        [ "sin(30°)"
        , "  sin( 30° )  "
        , "  sin( +30° )  "
        ]

      allParseAs (Expression (Apply Sqrt (Scalar 2.0)))
        [ "sqrt(2)"
        , "  sqrt( 2.0 )  "
        , "  sqrt( +2.0 )  "
        ]

      allParseAs (Expression (Apply Exp (Negate $ Scalar 10.0)))
        [ "exp(-10)"
        , "  exp( -10 )  "
        ]

  suite "Parser - Assignments" do
    test "Simple" do
      allParseAs (Assignment "xyz_123" (Scalar 1.0)) $
        [ "xyz_123 = 1"
        , "xyz_123=1"
        , "  xyz_123  =  1  "
        ]

      shouldFail "x²=3"
      shouldFail "x+y=3"
      shouldFail "x+2=3"
      shouldFail "3=5"
      shouldFail "x="

  let expectOutput' = expectOutput initialEnvironment

  suite "Integration" do
    test "Simple" do
      expectOutput' "3.0m" "3m"
      expectOutput' "3.0m" " 3.0 meter  "

    test "Implicit multiplication" do
      let myEnv = insert "x" (5.0 .* meter) initialEnvironment
      expectOutput myEnv "5.0m" "x"
      expectOutput myEnv "10.0m" "2x"
      expectOutput myEnv "10.0m" "2 x"
      expectOutput myEnv "25.0m²" "x x"
      expectOutput myEnv "25.0m²" "x²"
      expectOutput myEnv "Unknown variable 'x2'" "x2"

    test "Simple" do
      expectOutput' "1080.0" "1920/16*9"
      expectOutput' "4294967296.0" "2^32"
      expectOutput' "36.316811075498" "pi(1.4+2)²"
      expectOutput' "904778684233.8604km³" "4/3 pi (6000km)³"
      expectOutput' "2.5min" "2min + 30s"
      expectOutput' "150.0s" "2min + 30s -> sec"
      expectOutput' "26.8224m/s" "60mph -> m/s"
      expectOutput' "10.0km/h" "240km/day -> km/h"
      expectOutput' "0.057295779513082325°" "1mrad -> °"
      expectOutput' "364.0d" "52weeks -> days"
      expectOutput' "12.7cm" "5in -> cm"
      expectOutput' "0.7071067811865476" "cos(pi/4)"
      expectOutput' "0.49999999999999994" "sin(30°)"
      expectOutput' "8.530765609948133°" "atan(30cm/(2m)) -> °"

    test "Earth mass" do
      let env1 = initialEnvironment
          env2 = (repl env1 "r = 6000km").newEnv
          env3 = (repl env2 "vol = 4/3 pi r³").newEnv
          env4 = (repl env3 "density = 5g/cm³").newEnv

      expectOutput env4 "4.5238934211693013e+24kg" "vol * density -> kg"

    test "Pendulum" do
      let env1 = initialEnvironment
          env2 = (repl env1 "grav = 9.81m/s²").newEnv
          env3 = (repl env2 "L = 20cm").newEnv

      expectOutput env3 "897.1402930932747ms" "2pi*sqrt(L/grav) -> ms"

module Test.Main where

import Prelude hiding (degree)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)

import Data.StrMap (insert)
import Data.Either(Either(..))
import Data.Foldable (traverse_)

import Test.Unit (suite, test, failure)
import Test.Unit.Main (runTest)
import Test.Unit.Console (TESTOUTPUT)

import Text.Parsing.Parser (parseErrorMessage, parseErrorPosition)
import Text.Parsing.Parser.Pos (Position(..))

import Quantities ((./), (.*), milli, nano, meter, inch, hour, minute, kilo,
                   mile, gram, second, deci, tera, hertz, degree, radian)

import Insect.Language (Func(..), BinOp(..), Expression(..), Statement(..))
import Insect.Parser (parseInsect)
import Insect.Environment (Environment, initialEnvironment)
import Insect (repl)

shouldParseAs ∷ ∀ eff. Statement → String → Aff eff Unit
shouldParseAs expected input =
  case parseInsect input of
    Left err →
      case parseErrorPosition err of
        (Position pos) →
          failure $ "Parse error for input '" <> input <> "': "
                                <> parseErrorMessage err
                                <> " at position "
                                <> show pos.column
    Right output →
      unless (output == expected) $ do
        failure $ "Unexpected result:\n" <>
                  "Input:    '" <> input <> "'\n" <>
                  "Output:   " <> show output <> "\n" <>
                  "Expected: " <> show expected <> "\n"

allParseAs ∷ ∀ eff. Statement → Array String → Aff eff Unit
allParseAs expected = traverse_ (shouldParseAs expected)

shouldFail ∷ ∀ eff. String → Aff eff Unit
shouldFail input = do
  case parseInsect input of
   Left _ → pure unit
   Right output → failure $ "input is expected to throw a parse error: '" <> input <> "'"

expectOutput ∷ ∀ eff. Environment → String → String → Aff eff Unit
expectOutput env expected inp =
  let res = repl env inp
      out = res.msg
  in
    unless (out == expected) do
      failure $ "Unexpected result:\n" <>
                "Input:    '" <> inp <> "'\n" <>
                "Output:   '" <> out <> "'\n" <>
                "Expected: '" <> expected <> "'\n"

main ∷ Eff (console ∷ CONSOLE, testOutput ∷ TESTOUTPUT, avar ∷ AVAR) Unit
main = runTest do
  -- Helper to construct quantities
  let q s u = BinOp Mul (Scalar s) (Unit u)

  suite "Parser - Numbers" do
    test "Simple numbers" do
      allParseAs (Expression (Scalar 1.0))
        [ "1"
        , "1.0"
        , "  1  "
        , " 1.0000   "
        , " +1.0   "
        , "+1"
        ]

      allParseAs (Expression (Scalar 3.5))
        [ "3.5"
        , "  3.5  "
        , "3.50"
        , "+3.50"
        ]

    test "Large numbers" do
      allParseAs (Expression (Scalar 1234567890000000.0))
        [ "1234567890000000"
        , "1234567890000000.0"
        , "+1234567890000000.0"
        ]

    test "Negative numbers" do
      shouldParseAs (Expression (Negate (Scalar 123.45)))
        "-123.45"

    test "Exponential notation" do
      shouldParseAs (Expression (Negate (Scalar 1.3e13)))
        "-1.3e13"

      shouldParseAs (Expression (Scalar 2.7e-3))
        "2.7e-3"

      shouldFail "2.7e 3"

  suite "Parser - Units" do
    test "Simple" do
      allParseAs (Expression (Unit meter))
        [ "m"
        , "      m "
        , "meter"
        , "meters"
        ]

      allParseAs (Expression (Unit inch))
        [ "in"
        , "      in "
        , "inch"
        , "inches"
        ]

      allParseAs (Expression (Unit degree))
        [ "°"
        , "      ° "
        , "deg"
        , "degree"
        , "degrees"
        ]

  suite "Parser - Quantities" do
    test "Simple" do
      allParseAs (Expression (q 2.3 meter))
        [ "2.3*m"
        , " 2.3 * m "
        , "2.3m"
        , "  2.3 m "
        , "2.3meter"
        , "2.3 meter"
        , "2.3meters"
        ]

      allParseAs (Expression (q 5.0 second))
        [ "5s"
        , "5second"
        , "5 seconds"
        ]

      allParseAs (Expression (q 5.0 gram))
        [ "5g"
        , "5gram"
        , "5 grams"
        ]

      allParseAs (Expression (q 10.0 mile))
        [ "10miles"
        , "10mile"
        ]

      allParseAs (Expression (q 10.0 inch))
        [ "10inches"
        , "10inch"
        , "10in"
        ]

      allParseAs (Expression (q 360.0 degree))
        [ "360degrees"
        , "360degree"
        , "360deg"
        , "360°"
        , "360.0°"
        ]

      allParseAs (Expression (q 1.0 radian))
        [ "1.0rad"
        , "1.0 radian"
        , "1.0 radians"
        ]

    test "SI prefixes" do
      allParseAs (Expression (q 2.3 (kilo meter)))
        [ "2.3km"
        , "  2.3 km "
        , "  2.3 kmeter "
        , "  2.3 kmeters "
        ]

      allParseAs (Expression (q 2.3 (milli meter)))
        [ "2.3mm"
        , "  2.3 mm "
        , "  2.3 mmeter "
        , "  2.3 mmeters "
        ]

      allParseAs (Expression (q 2.3 (nano gram)))
        [ "2.3ng"
        , "  2.3 ng "
        ]

      allParseAs (Expression (q 2.3 (kilo minute)))
        [ "2.3kmin"
        , "  2.3 kmin "
        ]

      allParseAs (Expression (q 2.3 (deci meter)))
        [ "2.3dm"
        , "  2.3 dm "
        ]

      allParseAs (Expression (q 42.3 (tera hertz)))
        [ "42.3THz"
        , "42.3Thertz"
        ]

    test "Divisions" do
      allParseAs (Expression (BinOp Mul (Scalar 2.3) (BinOp Div (Unit (kilo meter)) (Unit hour))))
        [ "2.3km/h"
        , "2.30km/h"
        ]

  suite "Parser - Operators" do
    test "Exponentiation" do
      allParseAs (Expression (BinOp Pow (Scalar 5.0) (Scalar 3.0))) $
        [ "5^3"
        , " 5 ^ 3 "
        , " ( 5 ) ^ ( 3 ) "
        , " ( ( 5 ) ^ ( 3 ) ) "
        , " ( 5 ^ 3 ) "
        , "5^(+3)"
        , "+5^3"
        ]

      shouldParseAs (Expression (BinOp Pow (Scalar 2.0) (BinOp Pow (Scalar 3.0) (BinOp Pow (Scalar 4.0) (Scalar 5.0))))) $
        "2^3^4^5"

      allParseAs (Expression (BinOp Pow (Scalar 4.0) (Scalar 3.0))) $
        [ "4^3"
        , "4 ^ 3"
        , "4**3"
        , "4 ** 3"
        , "4³"
        , "4  ³"
        ]

      allParseAs (Expression (BinOp Pow (Variable "pi") (Scalar 2.0))) $
        [ "pi^2"
        , "pi ^ 2"
        , "pi**2"
        , "pi ** 2"
        , "pi²"
        , "(pi)²"
        ]

      allParseAs (Expression (Negate (BinOp Pow (Scalar 3.0) (Scalar 4.0)))) $
        [ "-3^4"
        , "-3 ^ 4"
        , "-3**4"
        , "-3 ** 4"
        , "-(3^4)"
        ]

      allParseAs (Expression (BinOp Pow (Scalar 3.0) (Negate (Scalar 1.4)))) $
        [ "3 ^ (-1.4)"
        , "3 ** (-1.4)"
        ]

    test "Multiplication" do
      allParseAs (Expression (BinOp Mul (Scalar 5.0) (Scalar 3.0))) $
        [ "5*3"
        , " 5 * 3 "
        , " ( 5 ) * ( 3 ) "
        , " ( 5 ) ( 3 ) "
        , " ( ( 5 ) * ( 3 ) ) "
        , " ( 5 * 3 ) "
        , "5(3)"
        , "(5)3"
        , "5(+3)"
        , "+5*3"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 5.0) (Negate $ Scalar 3.0))) $
        [ "5*(-3)"
        , " 5 * (-3) "
        , " ( 5 ) * ( -3 ) "
        , " ( ( 5 ) * (-( 3 )) ) "
        , " ( 5 * (-3) ) "
        , "+5*(-3)"
        ]

    test "Division" do
      allParseAs (Expression (BinOp Div (Scalar 5.0) (Scalar 3.0))) $
        [ "5/3"
        , " 5 / 3 "
        , " ( 5 ) / ( 3 ) "
        , " ( ( 5 ) / ( 3 ) ) "
        , " ( 5 / 3 ) "
        ]

    test "Addition" do
      allParseAs (Expression (BinOp Add (Scalar 5.0) (Scalar 3.0))) $
        [ "5+3"
        , " 5 + 3 "
        , " ( 5 ) + ( 3 ) "
        , " ( ( 5 ) + ( 3 ) ) "
        , " ( 5 + 3 ) "
        ]

    test "Precedence" do
      allParseAs (Expression (BinOp Add (q 5.0 meter) (BinOp Mul (q 3.0 inch) (Scalar 7.0)))) $
        [ "5m+3in*7"
        , "5m+(3in*7)"
        , "5m+(3in·7)"
        , "  5 m +   3  in * 7    "
        ]

      allParseAs (Expression (BinOp Mul (BinOp Add (q 5.0 meter) (q 3.0 inch)) (Scalar 7.0))) $
        [ "(5m+3in)*7"
        , "((5m+3in))*7"
        , "(((((((5m))+((3in)))))))*((7))"
        , "  (  5 m + ( 3  in )  )  * 7    "
        ]

      allParseAs (Expression (BinOp Mul (BinOp Div (Scalar 5.0) (Scalar 3.0)) (Scalar 2.0)))
        [ "5/3*2"
        , "(5/3)*2"
        ]

      shouldFail "3+*4"
      shouldFail "3*/4"
      shouldFail "(3+4"
      shouldFail "3+4)"
      shouldFail "3+("
      shouldFail "()"
      shouldFail "(3+)4"

    test "Multiple division" do
      allParseAs (Expression (BinOp Div (BinOp Div (Scalar 42.0) (Scalar 7.0)) (Scalar 3.0))) $
        [ "42/7/3"
        , "(42/7)/3"
        ]

    test "Involving units" do
      allParseAs (Expression (BinOp Pow (q 3.0 meter) (Scalar 2.0))) $
        [ "(3m)^2"
        , "(3.0m)^(2.0)"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 3.0) (BinOp Pow (Unit meter) (Scalar 2.0)))) $
        [ "3m^2"
        , "3.0(m)^(2.0)"
        , "3m²"
        , "3 m²"
        , "3·m²"
        , "3·m^(2.0)"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 3.0) (BinOp Div (Unit meter) (Unit second)))) $
        [ "3m/s"
        , "3·m/s"
        , "3 meter / second"
        , "3 meter / sec"
        ]

      allParseAs (Expression (BinOp Pow (Unit meter) (Negate $ Scalar 1.0))) $
        [ "m^(-1)"
        , "m^(-1.0)"
        , "meter^(-1.0)"
        ]

  suite "Parser - Conversions" do
    test "Simple" do
      allParseAs (Expression (BinOp ConvertTo (q (2.3) meter) (Unit inch)))
        [ "2.3m -> in"
        , "  2.3 meters->inches "
        , "  2.3 m  ->  in "
        ]

      allParseAs (Expression (BinOp ConvertTo (q 120.0 minute) (Unit hour)))
        [ "120min -> h"
        , "120minutes -> hours"
        ]

      shouldFail "2.3m->"

    test "Complex units" do
      allParseAs (Expression (BinOp ConvertTo (BinOp Mul (Scalar 36.0) (BinOp Div (Unit (kilo meter)) (Unit hour))) (Unit (mile ./ hour))))
        [ "36km/h -> mph"
        , "36·km/h -> mph"
        ]

      allParseAs (Expression (BinOp ConvertTo (BinOp Mul (Scalar 36.0) (BinOp Div (Unit (kilo meter)) (Unit hour))) (BinOp Div (Unit meter) (Unit second))))
        [ "36km/h -> m/s"
        , "36·km/h -> m/s"
        ]

  suite "Parser - Identifiers" do
    test "Valid and invalid names" do
      shouldParseAs (Expression (Variable "x")) "x"
      shouldParseAs (Expression (Variable "µ")) "µ"
      shouldParseAs (Expression (Variable "pi")) "pi"
      shouldParseAs (Expression (Variable "x_2")) "x_2"
      shouldParseAs (Expression (Variable "länge")) "länge"
      shouldParseAs (Expression (Variable "_prefixed")) "_prefixed"
      shouldParseAs (Expression (Variable "x'")) "x'"
      shouldParseAs (Expression (Variable "t''")) "t''"

      shouldFail "xs,as"
      shouldFail "hello$"

    test "Variables which begin like units" do
      shouldParseAs (Expression (Variable "myVariable")) "myVariable"
      shouldParseAs (Expression (Variable "density")) "density"

  suite "Parser - Functions" do
    test "Simple" do
      allParseAs (Expression (Apply Sin (q 30.0 degree)))
        [ "sin(30°)"
        , "  sin( 30° )  "
        , "  sin( +30° )  "
        ]

      allParseAs (Expression (Apply Sqrt (Scalar 2.0)))
        [ "sqrt(2)"
        , "  sqrt( 2.0 )  "
        , "  sqrt( +2.0 )  "
        ]

      allParseAs (Expression (Apply Exp (Negate $ Scalar 10.0)))
        [ "exp(-10)"
        , "  exp( -10 )  "
        ]

  suite "Parser - Assignments" do
    test "Simple" do
      allParseAs (Assignment "xyz_123" (Scalar 1.0)) $
        [ "xyz_123 = 1"
        , "xyz_123=1"
        , "  xyz_123  =  1  "
        ]

      shouldFail "x²=3"
      shouldFail "x+y=3"
      shouldFail "x+2=3"
      shouldFail "3=5"
      shouldFail "x="

  let expectOutput' = expectOutput initialEnvironment

  suite "Integration" do
    test "Simple" do
      expectOutput' "3.0m" "3m"
      expectOutput' "3.0m" " 3.0 meter  "

    test "Implicit multiplication" do
      let myEnv = insert "x" (5.0 .* meter) initialEnvironment
      expectOutput myEnv "5.0m" "x"
      expectOutput myEnv "10.0m" "2x"
      expectOutput myEnv "10.0m" "2 x"
      expectOutput myEnv "25.0m²" "x x"
      expectOutput myEnv "25.0m²" "x²"
      expectOutput myEnv "Unknown variable 'x2'" "x2"

    test "Simple" do
      expectOutput' "1080.0" "1920/16*9"
      expectOutput' "4294967296.0" "2^32"
      expectOutput' "36.316811075498" "pi(1.4+2)²"
      expectOutput' "904778684233.8604km³" "4/3 pi (6000km)³"
      expectOutput' "2.5min" "2min + 30s"
      expectOutput' "150.0s" "2min + 30s -> sec"
      expectOutput' "26.8224m/s" "60mph -> m/s"
      expectOutput' "10.0km/h" "240km/day -> km/h"
      expectOutput' "0.057295779513082325°" "1mrad -> °"
      expectOutput' "364.0d" "52weeks -> days"
      expectOutput' "12.7cm" "5in -> cm"
      expectOutput' "0.7071067811865476" "cos(pi/4)"
      expectOutput' "0.49999999999999994" "sin(30°)"
      expectOutput' "8.530765609948133°" "atan(30cm/(2m)) -> °"

    test "Earth mass" do
      let env1 = initialEnvironment
          env2 = (repl env1 "r = 6000km").newEnv
          env3 = (repl env2 "vol = 4/3 pi r³").newEnv
          env4 = (repl env3 "density = 5g/cm³").newEnv

      expectOutput env4 "4.5238934211693013e+24kg" "vol * density -> kg"

    test "Pendulum" do
      let env1 = initialEnvironment
          env2 = (repl env1 "grav = 9.81m/s²").newEnv
          env3 = (repl env2 "L = 20cm").newEnv

      expectOutput env3 "897.1402930932747ms" "2pi*sqrt(L/grav) -> ms"


rm unnecessary type annotation

rm unnecessary type annotation

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/michaelsbradleyjr/advent-of-code.git/'


New Server errors

New Server errors

-- File auto generated by purescript-bridge! --
module Gonimo.Server.Error where

import Gonimo.Server.DbEntities (Family)
import Gonimo.Types (Key)

import Data.Generic (class Generic)

data ServerError =
    InvalidAuthToken
  | InvitationAlreadyClaimed
  | AlreadyFamilyMember
  | NoSuchFamily (Key Family)
  | NoSuchInvitation
  | NoSuchSocket
  | Forbidden
  | NotFound
  | NoDataAvailable
  | NoNewChannel
  | TransactionTimeout
  | NotPossible

derive instance genericServerError :: Generic ServerError

-- File auto generated by purescript-bridge! --
module Gonimo.Server.Error where

import Gonimo.Server.DbEntities (Family)
import Gonimo.Types (Key)

import Data.Generic (class Generic)

data ServerError =
    InvalidAuthToken
  | InvitationAlreadyClaimed
  | AlreadyFamilyMember
  | NoSuchFamily (Key Family)
  | NoSuchInvitation
  | NoSuchSocket
  | Forbidden
  | NotFound
  | TransactionTimeout

derive instance genericServerError :: Generic ServerError


fine tuning of drop down menus

fine tuning of drop down menus

-- | Loaded application ui logic
module Gonimo.UI.Loaded where

import Gonimo.UI.Html
import Data.Array as Arr
import Data.List as List
import Data.Map as Map
import Data.Tuple as Tuple
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Router as Router
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Error as Error
import Gonimo.UI.Home as HomeC
import Gonimo.UI.Invite as InviteC
import Gonimo.UI.Socket as SocketC
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Lenses as SocketC
import Gonimo.UI.Socket.Types as SocketC
import Gonimo.WebAPI.MakeRequests as Reqs
import Gonimo.WebAPI.Subscriber as Sub
import Pux.Html as H
import Pux.Html.Attributes as A
import Pux.Html.Attributes.Bootstrap as A
import Pux.Html.Events as E
import Servant.Subscriber as Sub
import Servant.Subscriber.Connection as Sub
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.Reader (runReader)
import Control.Monad.Reader.Class (class MonadReader)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (get, modify, put)
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Array (fromFoldable, concat, catMaybes, head)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Right, Left))
import Data.Foldable (foldl)
import Data.Generic (class Generic)
import Data.Generic (gShow)
import Data.Lens ((.=), to, (^.), (^?))
import Data.Map (Map)
import Data.Maybe (isNothing, maybe, Maybe(..))
import Data.Monoid (mempty)
import Data.Profunctor (lmap)
import Data.Semigroup (append)
import Data.String (takeWhile)
import Data.Traversable (traverse)
import Data.Tuple (uncurry, fst, Tuple(Tuple))
import Debug.Trace (trace)
import Gonimo.Client.Types (toIO, Settings, GonimoError, class ReportErrorAction, Gonimo)
import Gonimo.Pux (Component, toParent, runGonimo, liftChild, ComponentType, makeChildData, ToChild, noEffects, onlyModify, Update, wrapAction)
import Gonimo.Server.DbEntities (Device(Device), Family(Family))
import Gonimo.Server.DbEntities.Helpers (runFamily)
import Gonimo.Server.Error (ServerError(InvalidAuthToken))
import Gonimo.Server.Types (DeviceType(Baby, NoBaby), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (dateToString, Key(Key), Secret(Secret))
import Gonimo.UI.Error (viewError, class ErrorAction, UserError(NoError, DeviceInvalid), handleSubscriber, handleError)
import Gonimo.UI.Loaded.Types (familyIds, authData, currentFamily, socketS, homeS, centralHome, Props, acceptS, inviteS, State, Action(..), Central(..))
import Gonimo.UI.Socket (viewParentChannels, getParentChannels)
import Gonimo.Util (toString, fromString)
import Gonimo.WebAPI (deleteOnlineStatusByFamilyIdByDeviceId, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (DeviceInfo(DeviceInfo), AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (text, small, script, li, a, nav, h3, h2, td, tbody, th, tr, thead, table, ul, p, button, input, h1, span, Html, img, div)
import Pux.Html.Attributes (letterSpacing, offset)
import Pux.Html.Events (FormEvent, FocusEvent)
import Pux.Router (navigateTo)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Servant.Subscriber (Subscriber)
import Servant.Subscriber.Connection (Notification(HttpRequestFailed, ParseError, WebSocketClosed, WebSocketError))
import Servant.Subscriber.Internal (doDecode, coerceEffects)
import Servant.Subscriber.Request (HttpRequest(HttpRequest))
import Servant.Subscriber.Response (HttpResponse(HttpResponse))
import Servant.Subscriber.Subscriptions (Subscriptions)
import Servant.Subscriber.Util (toUserType)
import Signal (constant, Signal)
import Prelude hiding (div)

update :: Update Unit State Action
update (SetState state)                    = put state *> pure []
update (ReportError err)                   = handleError err
update (InviteA (InviteC.ReportError err)) = handleError err
update (InviteA action)                    = updateInvite action
update (AcceptA (AcceptC.ReportError err)) = handleError err
update (AcceptA action)                    = updateAccept action
update (SocketA (SocketC.ReportError err)) = handleError err
update (SocketA action)                    = updateSocket action
update (HomeA action)                      = updateHome action
update (SetFamilyIds ids)                  = handleSetFamilyIds ids
update (UpdateFamily familyId' family')    = onlyModify $ \state ->  state { families = Map.insert familyId' family' state.families }
update (SetCentral c)                      = onlyModify $ _ { central = c }
update (SetOnlineDevices devices)          = onlyModify $ _ { onlineDevices = devices }
update (SetDeviceInfos devices)            = onlyModify $ _ { deviceInfos = devices }
update (SetURL url)                        = handleSetURL url
update (HandleSubscriber msg)              = handleSubscriber msg
update ResetDevice                         = handleResetDevice
update ClearError                          = handleClearError
update Nop                                 = noEffects
update _                                   = noEffects

toInvite :: ToChild Unit State Props InviteC.State
toInvite = do
  props <- mkProps <$> get
  pure $ makeChildData inviteS props

toAccept :: ToChild Unit State Props AcceptC.State
toAccept = do
  props <- mkProps <$> get
  pure $ makeChildData acceptS props

toHome :: ToChild Unit State Props HomeC.State
toHome = do
  props <- mkProps <$> get
  pure $ makeChildData homeS props

toSocket :: ToChild Unit State Props SocketC.State
toSocket = do
  props <- mkProps <$> get
  pure $ makeChildData socketS props

updateInvite :: InviteC.Action -> ComponentType Unit State Action
updateInvite = toParent [] InviteA <<< liftChild toInvite <<< InviteC.update

updateAccept :: AcceptC.Action -> ComponentType Unit State Action
updateAccept = toParent [] AcceptA <<< liftChild toAccept <<< AcceptC.update

updateHome :: HomeC.Action -> ComponentType Unit State Action
updateHome action = case action of
    HomeC.SocketA socketA -> updateSocket socketA
    _                     -> toParent [] HomeA <<< liftChild toHome $ HomeC.update action

updateSocket :: SocketC.Action -> ComponentType Unit State Action
updateSocket action = do
  case action of
    SocketC.SetAuthData _ -> handleSetAuthData
    _ -> pure unit
  toParent [] SocketA <<< liftChild toSocket $ SocketC.update action

inviteEffect :: forall m. Monad m => Secret -> m Action
inviteEffect = pure <<< AcceptA <<< AcceptC.LoadInvitation

handleResetDevice :: ComponentType Unit State Action
handleResetDevice = do
  props <- mkProps <$> get :: Component Unit State State
  pure $ [ toIO props.settings $ do
              liftEff $ localStorage.removeItem Key.authData
              SocketA <<< SocketC.SetAuthData <$> getAuthData
         ]

handleSetAuthData :: Component Unit State Unit
handleSetAuthData = modify $ \state -> state
                                  {
                                   userError = case state.userError of
                                      DeviceInvalid -> NoError
                                      _ -> state.userError
                                  }
handleSetFamilyIds :: Array (Key Family) -> ComponentType Unit State Action
handleSetFamilyIds ids = do
  familyIds .= ids
  state <- get :: Component Unit State State
  if isNothing state.socketS.currentFamily
    then pure $ fromFoldable $ pure <<< SocketA <<< SocketC.SwitchFamily <$> Arr.head ids
    else noEffects

handleSetURL :: String -> ComponentType Unit State Action
handleSetURL url = do
  let
    route = Router.match url
    withoutQuery = takeWhile (_ /= '?') url
  case route of
    Router.Home -> onlyModify $ _ { url = url }
    Router.AcceptInvitation s -> do
      modify $ _ { url = withoutQuery
                 , central = CentralAccept
                 }
      pure [ do
              liftEff $ navigateTo withoutQuery
              inviteEffect s
            ]

handleClearError :: ComponentType Unit State Action
handleClearError = do
  state <- (get :: Component Unit State State)
  let
    newCentral = case state.central of
      CentralAccept -> case state.acceptS of
        Nothing  -> centralHome
        Just _ -> state.central
      _ -> state.central

  onlyModify $ _ { userError = NoError
                 , central = newCentral
                 }

--------------------------------------------------------------------------------

view :: State -> Html Action
view state =
  let
    numDevices = Arr.length state.onlineDevices
  in
    case state.userError of
      NoError ->
        div []
        [ viewHeader state
        , viewNavbar state
        , viewCentral state
        , div []
          [ h3 [] [ text "Videos - yeah:" ]
          , div [] $ map SocketA <$> viewParentChannels state.socketS
          ]
        , div []
          [ h3 [] [ text $ show numDevices <> " Device(s) currently online:" ]
          , div [] [ viewOnlineDevices state ]
          ]
        ]
      err -> viewError state

viewHeader :: State -> Html Action
viewHeader state =
      nav [ A.className "navbar navbar-default" ]
      [ div [ A.className "container"]
        [ div [ A.className "navbar-header"]
          [ a [ A.className "navbar-brand navbar-left"]
            [ img [ A.alt "gonimo"
                  , A.src "./pix/gonimo-logo-05.svg"
                  , A.width "35px"
                  , A.height "35px"] []
            ]
          ]

        , div [ A.className "collapse navbar-collapse"]
          [ ul [ A.className "nav navbar-nav"]
            [ li []
              [ a [ E.onClick $ const $ SetCentral centralHome ] [ text "Overview" ]]
            , li []
              [ a [ E.onClick $ const $ SetCentral CentralInvite ] [ text "Invite Device" ] ]

            , table []
              [ tr [] [ text "Your current family is:" ]
              , tr [ A.className "nav navbar-nav"]
                [ li [A.className "dropdown"]
                  [ a [ A.className "dropdown-toggle" , A.href "#"
                      , A.dataToggle "dropdown"       , A.role "button"]
                    [ text "funky hedgehogs"
                    , text " "
                    , span [A.className "caret"] [] ]
                  , ul [A.className "dropdown-menu"]
                    [ li [] [a [] [text "wild frogs"]]
                    , li [] [a [] [text "funny cats"]]
                    , li [] [a [] [text "running dogs"]]
                    , li [] [a [] [ text "funky hedgehogs"
                                  , text " ✔"
                                  ]]
                    ]
                  ]
                ]
              ]
            , li [A.className "dropdown"]
              [ a [ A.className "dropdown-toggle" , A.href "#"
                  , A.dataToggle "dropdown"       , A.role "button"]
                [ text "Signed in as"
                , H.br [] []
                , text "epsilonhalbe"
                , text " "
                , H.i [A.className "fa fa-cog"] [] ]
              , ul [A.className "dropdown-menu"]
                [ li [] [a [] [text "wild frogs"]]
                , li [] [a [] [text "funny cats"]]
                , li [] [a [] [text "running dogs"]]
                , li [] [a [] [ text "funky hedgehogs"
                              , text " ✔"
                              ]]
                ]
              ]
             ]
           ]
         ]
       ]

viewNavbar :: State -> Html Action
viewNavbar state =
       nav [ A.className "navbar navbar-default" ]
        [ div [ A.className "container-fluid" ]
          [ -- Brand and toggle get grouped for better mobile display
            div [ A.className "navbar-header" ]
            [ button [ A.type_ "button"
                     , A.className "navbar-toggle collapsed"
                     , A.dataToggle "collapse"
                     , A.dataTarget "navbar-collapse-1"
                     ]
              [ span [ A.className "sr-only" ] [ text "Toggle navigation" ]
              , span [ A.className "icon-bar" ] []
              , span [ A.className "icon-bar" ] []
              , span [ A.className "icon-bar" ] []
              ]
            , a [ A.className "navbar-brand"
                , A.role "button"
                , E.onClick $ const $ SetCentral centralHome
                ]
                [ text "Home" ]
            , a [ A.className "navbar-brand"
                , A.role "button"
                , E.onClick $ const $ SetCentral CentralInvite
                ]
              [ text "Invite" ]
            ]
          , -- Collect the nav links, forms, and other content for toggling
            div [ A.className "collapse navbar-collapse", A.id_ "navbar-collapse-1" ]
            [
              ul [ A.className "nav navbar-nav" ]
              [ li []
                [ viewFamilyChooser state
                ]
              ]
            , ul [ A.className "nav navbar-nav navbar-right" ]
              [ li [ A.className "dropdown" ]
                [ a [ A.className "dropdown-toggle"
                         , A.dataToggle "dropdown"
                         , A.role "button"
                         ]
                  [ text "Account" , span [ A.className "caret" ] [] ]
                  , ul [ A.className "dropdown-menu" ]
                    [ li [] [ a [ A.href "#" ] [ text "Configure User Details" ] ]
                    , li [] [ a [ A.href "#" ] [ text "change password" ] ]
                    , li [ A.role "separator",  A.className "divider" ] []
                    , li [] [ a [ A.href "#" ] [ text "Log out" ] ]
                    ]
                  ]
                ]
              ]
            ]
          ]

viewCentral :: State -> Html Action
viewCentral state =
  let
    props = mkProps state
  in
   case state.central of
    CentralInvite -> map InviteA $ InviteC.view props state.inviteS
    CentralAccept -> map AcceptA $ AcceptC.view state.acceptS
    CentralHome   -> map HomeA   $ HomeC.view props state.homeS

viewOnlineDevices :: State -> Html Action
viewOnlineDevices state = table [ A.className "table table-stripped"]
                          [ head
                          , body
                          ]
  where
    head = thead []
           [ tr []
             [ th [] [ text "Name" ]
             , th [] [ text "Last Accessed"]
             ]
           ]
    body = tbody []
           <<< Arr.mapMaybe viewOnlineDevice
           $ map fst state.onlineDevices
    viewOnlineDevice deviceId = do
        (DeviceInfo info) <- Tuple.lookup deviceId state.deviceInfos
        let name = info.deviceInfoName
        let lastAccessed = dateToString info.deviceInfoLastAccessed
        pure $ tr []
               [ td [] [ text name ]
               , td [] [ text lastAccessed ]
               ]

viewFamilyChooser :: State -> Html Action
viewFamilyChooser state = H.div []
                          [ H.label [ A.htmlFor "familySelect" ] [ text "Family: " ]
                          , H.select [ A.id_ "familySelect"
                                     , A.className "form-control"
                                     , E.onInput doSwitchFamily
                                     ]
                            $ fromFoldable
                            <<< map (uncurry makeOption)
                            <<< Map.toList $ state.families
                          ]
  where
    doSwitchFamily :: FormEvent -> Action
    doSwitchFamily ev = maybe Nop (SocketA <<< SocketC.SwitchFamily) $ fromString ev.target.value

    makeOption :: Key Family -> Family -> Html Action
    makeOption familyId (Family family) = H.option [ A.value (toString familyId) ]
                                          [ text family.familyName ]
--------------------------------------------------------------------------------
getSubscriptions :: State -> Subscriptions Action
getSubscriptions state =
  let
    familyId = state^?currentFamily

    --subscribeGetFamily :: forall m. MonadReader Settings m => Key Family -> m (Subscriptions Action)
    subscribeGetFamily familyId' =
      Sub.getFamiliesByFamilyId (maybe Nop (UpdateFamily familyId')) familyId'

    subArray :: Array (Subscriptions Action)
    subArray = map (flip runReader (mkSettings $ state^.authData)) <<< concat $
      [ [ Sub.getAccountsByAccountIdFamilies (maybe Nop SetFamilyIds)
                                          (runAuthData $ state^.authData).accountId
        ]
      , fromFoldable $
        Sub.getOnlineStatusByFamilyId (maybe Nop SetOnlineDevices) <$> familyId
      , fromFoldable $
        Sub.getFamiliesByFamilyIdDeviceInfos (maybe Nop SetDeviceInfos) <$> familyId
      , map subscribeGetFamily state.familyIds
      ]
  in
   case state.userError of
     NoError -> foldl append mempty subArray <> map SocketA (SocketC.getSubscriptions (mkProps state) state.socketS)
     _       -> mempty

getPongRequest :: State -> Maybe HttpRequest
getPongRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    onlineStatus' = state ^. socketS <<< SocketC.onlineStatus <<< to SocketC.toDeviceType
    deviceData = Tuple deviceId onlineStatus'
    familyId = state^?currentFamily
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <<< Reqs.postOnlineStatusByFamilyId deviceData <$> familyId
     _ -> Nothing

getCloseRequest :: State -> Maybe HttpRequest
getCloseRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    familyId = state^?currentFamily
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <<< flip Reqs.deleteOnlineStatusByFamilyIdByDeviceId deviceId <$> familyId
     _ -> Nothing

-- | Retrieve AuthData from local storage or if not present get new one from server
getAuthData :: Gonimo AuthData
getAuthData = do
  md <- liftEff $ localStorage.getItem Key.authData
  Gonimo.log $ "Got authdata from local storage: " <> gShow md
  case md of
    Nothing -> do
      auth <- postAccounts
      Gonimo.log $ "Got Nothing - called postAccounts and got: " <> gShow auth
      Gonimo.log $ "Calling setItem with : " <> gShow Key.authData
      liftEff $ localStorage.setItem Key.authData auth
      pure auth
    Just d  -> pure d

mkProps :: State -> Props
mkProps state = { settings : mkSettings $ state^.authData
                , deviceId : (runAuthData $ state^.authData).deviceId
                , familyId : state^?currentFamily
                , onlineStatus  : state ^. socketS <<< SocketC.onlineStatus <<< to SocketC.toDeviceType
                , family : flip Map.lookup state.families =<< state^?currentFamily
                , onlineDevices : state.onlineDevices
                , deviceInfos : state.deviceInfos
                , sendActionSocket : lmap SocketA state.sendAction
                }

mkSettings :: AuthData -> Settings
mkSettings (AuthData auth) = defaultSettings $ SPParams_ {
      authorization : auth.authToken
    , baseURL       : "http://localhost:8081/"
    }

-- | Loaded application ui logic
module Gonimo.UI.Loaded where

import Gonimo.UI.Html
import Data.Array as Arr
import Data.List as List
import Data.Map as Map
import Data.Tuple as Tuple
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Router as Router
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Error as Error
import Gonimo.UI.Home as HomeC
import Gonimo.UI.Invite as InviteC
import Gonimo.UI.Socket as SocketC
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Lenses as SocketC
import Gonimo.UI.Socket.Types as SocketC
import Gonimo.WebAPI.MakeRequests as Reqs
import Gonimo.WebAPI.Subscriber as Sub
import Pux.Html as H
import Pux.Html.Attributes as A
import Pux.Html.Attributes.Bootstrap as A
import Pux.Html.Events as E
import Servant.Subscriber as Sub
import Servant.Subscriber.Connection as Sub
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.Reader (runReader)
import Control.Monad.Reader.Class (class MonadReader)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (get, modify, put)
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Array (fromFoldable, concat, catMaybes, head)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Right, Left))
import Data.Foldable (foldl)
import Data.Generic (class Generic)
import Data.Generic (gShow)
import Data.Lens ((.=), to, (^.), (^?))
import Data.Map (Map)
import Data.Maybe (isNothing, maybe, Maybe(..))
import Data.Monoid (mempty)
import Data.Profunctor (lmap)
import Data.Semigroup (append)
import Data.String (takeWhile)
import Data.Traversable (traverse)
import Data.Tuple (uncurry, fst, Tuple(Tuple))
import Debug.Trace (trace)
import Gonimo.Client.Types (toIO, Settings, GonimoError, class ReportErrorAction, Gonimo)
import Gonimo.Pux (Component, toParent, runGonimo, liftChild, ComponentType, makeChildData, ToChild, noEffects, onlyModify, Update, wrapAction)
import Gonimo.Server.DbEntities (Device(Device), Family(Family))
import Gonimo.Server.DbEntities.Helpers (runFamily)
import Gonimo.Server.Error (ServerError(InvalidAuthToken))
import Gonimo.Server.Types (DeviceType(Baby, NoBaby), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (dateToString, Key(Key), Secret(Secret))
import Gonimo.UI.Error (viewError, class ErrorAction, UserError(NoError, DeviceInvalid), handleSubscriber, handleError)
import Gonimo.UI.Loaded.Types (familyIds, authData, currentFamily, socketS, homeS, centralHome, Props, acceptS, inviteS, State, Action(..), Central(..))
import Gonimo.UI.Socket (viewParentChannels, getParentChannels)
import Gonimo.Util (toString, fromString)
import Gonimo.WebAPI (deleteOnlineStatusByFamilyIdByDeviceId, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (DeviceInfo(DeviceInfo), AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (text, small, script, li, a, nav, h3, h2, td, tbody, th, tr, thead, table, ul, p, button, input, h1, span, Html, img, div)
import Pux.Html.Attributes (letterSpacing, offset)
import Pux.Html.Events (FormEvent, FocusEvent)
import Pux.Router (navigateTo)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Servant.Subscriber (Subscriber)
import Servant.Subscriber.Connection (Notification(HttpRequestFailed, ParseError, WebSocketClosed, WebSocketError))
import Servant.Subscriber.Internal (doDecode, coerceEffects)
import Servant.Subscriber.Request (HttpRequest(HttpRequest))
import Servant.Subscriber.Response (HttpResponse(HttpResponse))
import Servant.Subscriber.Subscriptions (Subscriptions)
import Servant.Subscriber.Util (toUserType)
import Signal (constant, Signal)
import Prelude hiding (div)

update :: Update Unit State Action
update (SetState state)                    = put state *> pure []
update (ReportError err)                   = handleError err
update (InviteA (InviteC.ReportError err)) = handleError err
update (InviteA action)                    = updateInvite action
update (AcceptA (AcceptC.ReportError err)) = handleError err
update (AcceptA action)                    = updateAccept action
update (SocketA (SocketC.ReportError err)) = handleError err
update (SocketA action)                    = updateSocket action
update (HomeA action)                      = updateHome action
update (SetFamilyIds ids)                  = handleSetFamilyIds ids
update (UpdateFamily familyId' family')    = onlyModify $ \state ->  state { families = Map.insert familyId' family' state.families }
update (SetCentral c)                      = onlyModify $ _ { central = c }
update (SetOnlineDevices devices)          = onlyModify $ _ { onlineDevices = devices }
update (SetDeviceInfos devices)            = onlyModify $ _ { deviceInfos = devices }
update (SetURL url)                        = handleSetURL url
update (HandleSubscriber msg)              = handleSubscriber msg
update ResetDevice                         = handleResetDevice
update ClearError                          = handleClearError
update Nop                                 = noEffects
update _                                   = noEffects

toInvite :: ToChild Unit State Props InviteC.State
toInvite = do
  props <- mkProps <$> get
  pure $ makeChildData inviteS props

toAccept :: ToChild Unit State Props AcceptC.State
toAccept = do
  props <- mkProps <$> get
  pure $ makeChildData acceptS props

toHome :: ToChild Unit State Props HomeC.State
toHome = do
  props <- mkProps <$> get
  pure $ makeChildData homeS props

toSocket :: ToChild Unit State Props SocketC.State
toSocket = do
  props <- mkProps <$> get
  pure $ makeChildData socketS props

updateInvite :: InviteC.Action -> ComponentType Unit State Action
updateInvite = toParent [] InviteA <<< liftChild toInvite <<< InviteC.update

updateAccept :: AcceptC.Action -> ComponentType Unit State Action
updateAccept = toParent [] AcceptA <<< liftChild toAccept <<< AcceptC.update

updateHome :: HomeC.Action -> ComponentType Unit State Action
updateHome action = case action of
    HomeC.SocketA socketA -> updateSocket socketA
    _                     -> toParent [] HomeA <<< liftChild toHome $ HomeC.update action

updateSocket :: SocketC.Action -> ComponentType Unit State Action
updateSocket action = do
  case action of
    SocketC.SetAuthData _ -> handleSetAuthData
    _ -> pure unit
  toParent [] SocketA <<< liftChild toSocket $ SocketC.update action

inviteEffect :: forall m. Monad m => Secret -> m Action
inviteEffect = pure <<< AcceptA <<< AcceptC.LoadInvitation

handleResetDevice :: ComponentType Unit State Action
handleResetDevice = do
  props <- mkProps <$> get :: Component Unit State State
  pure $ [ toIO props.settings $ do
              liftEff $ localStorage.removeItem Key.authData
              SocketA <<< SocketC.SetAuthData <$> getAuthData
         ]

handleSetAuthData :: Component Unit State Unit
handleSetAuthData = modify $ \state -> state
                                  {
                                   userError = case state.userError of
                                      DeviceInvalid -> NoError
                                      _ -> state.userError
                                  }
handleSetFamilyIds :: Array (Key Family) -> ComponentType Unit State Action
handleSetFamilyIds ids = do
  familyIds .= ids
  state <- get :: Component Unit State State
  if isNothing state.socketS.currentFamily
    then pure $ fromFoldable $ pure <<< SocketA <<< SocketC.SwitchFamily <$> Arr.head ids
    else noEffects

handleSetURL :: String -> ComponentType Unit State Action
handleSetURL url = do
  let
    route = Router.match url
    withoutQuery = takeWhile (_ /= '?') url
  case route of
    Router.Home -> onlyModify $ _ { url = url }
    Router.AcceptInvitation s -> do
      modify $ _ { url = withoutQuery
                 , central = CentralAccept
                 }
      pure [ do
              liftEff $ navigateTo withoutQuery
              inviteEffect s
            ]

handleClearError :: ComponentType Unit State Action
handleClearError = do
  state <- (get :: Component Unit State State)
  let
    newCentral = case state.central of
      CentralAccept -> case state.acceptS of
        Nothing  -> centralHome
        Just _ -> state.central
      _ -> state.central

  onlyModify $ _ { userError = NoError
                 , central = newCentral
                 }

--------------------------------------------------------------------------------

view :: State -> Html Action
view state =
  let
    numDevices = Arr.length state.onlineDevices
  in
    case state.userError of
      NoError ->
        div []
        [ viewHeader state
        , viewNavbar state
        , viewCentral state
        , div []
          [ h3 [] [ text "Videos - yeah:" ]
          , div [] $ map SocketA <$> viewParentChannels state.socketS
          ]
        , div []
          [ h3 [] [ text $ show numDevices <> " Device(s) currently online:" ]
          , div [] [ viewOnlineDevices state ]
          ]
        ]
      err -> viewError state

viewHeader :: State -> Html Action
viewHeader state =
      nav [ A.className "navbar navbar-default" ]
      [ div [ A.className "container"]
        [ div [ A.className "navbar-header"]
          [ a [ A.className "navbar-brand navbar-left"]
            [ img [ A.alt "gonimo"
                  , A.src "./pix/gonimo-logo-05.svg"
                  , A.width "35px"
                  , A.height "35px"] []
            ]
          ]

        ,div [ A.className "collapse navbar-collapse"]
          [ ul [ A.className "nav navbar-nav"]
            [ li []
              [ a [ E.onClick $ const $ SetCentral centralHome ] [ text "Overview" ]]
            , li []
              [ a [ E.onClick $ const $ SetCentral CentralInvite ] [ text "Invite Device" ] ]

            , li [A.className "dropdown"]
              [ a [ A.className "dropdown-toggle" , A.href "#"
                  , A.dataToggle "dropdown"       , A.role "button"]
                [ text "funky hedgehogs"
                , text " "
                , span [A.className "caret"] [] ]
              , ul [A.className "dropdown-menu"]
                [ li [] [a [] [text "wild frogs"]]
                , li [] [a [] [text "funny cats"]]
                , li [] [a [] [text "running dogs"]]
                , li [] [a [] [ text "funky hedgehogs"
                              , text " ✔"
                              ]]
                ]
              ]
            ]
           , p [ A.className "navbar-text"]
                [ text "Signed in as ε/2"
                --, small [] [text "your family name: foobarbaz"]
                ]
          ]
        ]
      ]

viewNavbar :: State -> Html Action
viewNavbar state =
       nav [ A.className "navbar navbar-default" ]
        [ div [ A.className "container-fluid" ]
          [ -- Brand and toggle get grouped for better mobile display
            div [ A.className "navbar-header" ]
            [ button [ A.type_ "button"
                     , A.className "navbar-toggle collapsed"
                     , A.dataToggle "collapse"
                     , A.dataTarget "navbar-collapse-1"
                     ]
              [ span [ A.className "sr-only" ] [ text "Toggle navigation" ]
              , span [ A.className "icon-bar" ] []
              , span [ A.className "icon-bar" ] []
              , span [ A.className "icon-bar" ] []
              ]
            , a [ A.className "navbar-brand"
                , A.role "button"
                , E.onClick $ const $ SetCentral centralHome
                ]
                [ text "Home" ]
            , a [ A.className "navbar-brand"
                , A.role "button"
                , E.onClick $ const $ SetCentral CentralInvite
                ]
              [ text "Invite" ]
            ]
          , -- Collect the nav links, forms, and other content for toggling
            div [ A.className "collapse navbar-collapse", A.id_ "navbar-collapse-1" ]
            [
              ul [ A.className "nav navbar-nav" ]
              [ li []
                [ viewFamilyChooser state
                ]
              ]
            , ul [ A.className "nav navbar-nav navbar-right" ]
              [ li [ A.className "dropdown" ]
                [ a [ A.className "dropdown-toggle"
                         , A.dataToggle "dropdown"
                         , A.role "button"
                         ]
                  [ text "Account" , span [ A.className "caret" ] [] ]
                  , ul [ A.className "dropdown-menu" ]
                    [ li [] [ a [ A.href "#" ] [ text "Configure User Details" ] ]
                    , li [] [ a [ A.href "#" ] [ text "change password" ] ]
                    , li [ A.role "separator",  A.className "divider" ] []
                    , li [] [ a [ A.href "#" ] [ text "Log out" ] ]
                    ]
                  ]
                ]
              ]
            ]
          ]

viewCentral :: State -> Html Action
viewCentral state =
  let
    props = mkProps state
  in
   case state.central of
    CentralInvite -> map InviteA $ InviteC.view props state.inviteS
    CentralAccept -> map AcceptA $ AcceptC.view state.acceptS
    CentralHome   -> map HomeA   $ HomeC.view props state.homeS

viewOnlineDevices :: State -> Html Action
viewOnlineDevices state = table [ A.className "table table-stripped"]
                          [ head
                          , body
                          ]
  where
    head = thead []
           [ tr []
             [ th [] [ text "Name" ]
             , th [] [ text "Last Accessed"]
             ]
           ]
    body = tbody []
           <<< Arr.mapMaybe viewOnlineDevice
           $ map fst state.onlineDevices
    viewOnlineDevice deviceId = do
        (DeviceInfo info) <- Tuple.lookup deviceId state.deviceInfos
        let name = info.deviceInfoName
        let lastAccessed = dateToString info.deviceInfoLastAccessed
        pure $ tr []
               [ td [] [ text name ]
               , td [] [ text lastAccessed ]
               ]

viewFamilyChooser :: State -> Html Action
viewFamilyChooser state = H.div []
                          [ H.label [ A.htmlFor "familySelect" ] [ text "Family: " ]
                          , H.select [ A.id_ "familySelect"
                                     , A.className "form-control"
                                     , E.onInput doSwitchFamily
                                     ]
                            $ fromFoldable
                            <<< map (uncurry makeOption)
                            <<< Map.toList $ state.families
                          ]
  where
    doSwitchFamily :: FormEvent -> Action
    doSwitchFamily ev = maybe Nop (SocketA <<< SocketC.SwitchFamily) $ fromString ev.target.value

    makeOption :: Key Family -> Family -> Html Action
    makeOption familyId (Family family) = H.option [ A.value (toString familyId) ]
                                          [ text family.familyName ]
--------------------------------------------------------------------------------
getSubscriptions :: State -> Subscriptions Action
getSubscriptions state =
  let
    familyId = state^?currentFamily

    --subscribeGetFamily :: forall m. MonadReader Settings m => Key Family -> m (Subscriptions Action)
    subscribeGetFamily familyId' =
      Sub.getFamiliesByFamilyId (maybe Nop (UpdateFamily familyId')) familyId'

    subArray :: Array (Subscriptions Action)
    subArray = map (flip runReader (mkSettings $ state^.authData)) <<< concat $
      [ [ Sub.getAccountsByAccountIdFamilies (maybe Nop SetFamilyIds)
                                          (runAuthData $ state^.authData).accountId
        ]
      , fromFoldable $
        Sub.getOnlineStatusByFamilyId (maybe Nop SetOnlineDevices) <$> familyId
      , fromFoldable $
        Sub.getFamiliesByFamilyIdDeviceInfos (maybe Nop SetDeviceInfos) <$> familyId
      , map subscribeGetFamily state.familyIds
      ]
  in
   case state.userError of
     NoError -> foldl append mempty subArray <> map SocketA (SocketC.getSubscriptions (mkProps state) state.socketS)
     _       -> mempty

getPongRequest :: State -> Maybe HttpRequest
getPongRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    onlineStatus' = state ^. socketS <<< SocketC.onlineStatus <<< to SocketC.toDeviceType
    deviceData = Tuple deviceId onlineStatus'
    familyId = state^?currentFamily
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <<< Reqs.postOnlineStatusByFamilyId deviceData <$> familyId
     _ -> Nothing

getCloseRequest :: State -> Maybe HttpRequest
getCloseRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    familyId = state^?currentFamily
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <<< flip Reqs.deleteOnlineStatusByFamilyIdByDeviceId deviceId <$> familyId
     _ -> Nothing

-- | Retrieve AuthData from local storage or if not present get new one from server
getAuthData :: Gonimo AuthData
getAuthData = do
  md <- liftEff $ localStorage.getItem Key.authData
  Gonimo.log $ "Got authdata from local storage: " <> gShow md
  case md of
    Nothing -> do
      auth <- postAccounts
      Gonimo.log $ "Got Nothing - called postAccounts and got: " <> gShow auth
      Gonimo.log $ "Calling setItem with : " <> gShow Key.authData
      liftEff $ localStorage.setItem Key.authData auth
      pure auth
    Just d  -> pure d

mkProps :: State -> Props
mkProps state = { settings : mkSettings $ state^.authData
                , deviceId : (runAuthData $ state^.authData).deviceId
                , familyId : state^?currentFamily
                , onlineStatus  : state ^. socketS <<< SocketC.onlineStatus <<< to SocketC.toDeviceType
                , family : flip Map.lookup state.families =<< state^?currentFamily
                , onlineDevices : state.onlineDevices
                , deviceInfos : state.deviceInfos
                , sendActionSocket : lmap SocketA state.sendAction
                }

mkSettings :: AuthData -> Settings
mkSettings (AuthData auth) = defaultSettings $ SPParams_ {
      authorization : auth.authToken
    , baseURL       : "http://localhost:8081/"
    }


simplify

simplify


Added Addition operations and flags

Added Addition operations and flags

module Ops where

import Prelude
import Data.Int.Bits

import Types
import MainMem

-- 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 .&. 0x10 /= 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' = (immAbs + regs.sp) .&. 0xFFFF
  immAbs = (if imm > 127 then negI8 else id) imm
  imm = rd8 regs.pc mainMem

addI8s :: I8 -> I8 -> { res :: I8, flags :: I8 }
addI8s x1 x2 = { res , flags }
 where
  flags =  zeroFlag res
       .|. carryFlag8 sum
       .|. halfCarryFlag x1 x2 res
  res = sum .&. 255
  sum = x1 + x2

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

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

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

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

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

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
             }

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

carryFlag8 :: Int -> I8
carryFlag8 x = if x > 255 then 0x10 else 0

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

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

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

negCarryFlag :: Int -> I8
negCarryFlag reg = if reg < 0 then 0x10 else 0

subtractionFlag :: I8
subtractionFlag = 0x40

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

error: pathspec 'src/Ops.purs' did not match any file(s) known to git