Added international spelling for Metre/Meter

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.Decimal (fromNumber)
import Data.StrMap (insert, keys)
import Data.Either(Either(..))
import Data.Foldable (traverse_, for_, intercalate)

import Test.Unit (suite, test, failure)
import Test.Unit.Assert (equal)
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,
                   day, tonne)

import Insect.Language (Func(..), BinOp(..), Expression(..), Statement(..))
import Insect.Parser (Dictionary(..), DictEntry, (==>), siPrefixDict,
                      normalUnitDict, imperialUnitDict, parseInsect)
import Insect.Environment (Environment, initialEnvironment)
import Insect.Format (format, fmtPlain)
import Insect.PrettyPrint (pretty)
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 fmtPlain env inp
      out = res.msg
  in
    unless (out == expected) do
      failure $ "Unexpected result:\n" <>
                "Input:    '" <> inp <> "'\n" <>
                "Output:   '" <> out <> "'\n" <>
                "Expected: '" <> expected <> "'\n"

prettyPrintCheck ∷ ∀ eff. String → Aff eff Unit
prettyPrintCheck 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 →
      case output of
        Expression expr →
          -- Pretty print the AST, parse it again and check against the
          -- original AST.
          shouldParseAs output (format fmtPlain (pretty expr))
        _ →
          failure $ "Input is not an expression"

main ∷ Eff (console ∷ CONSOLE, testOutput ∷ TESTOUTPUT, avar ∷ AVAR) Unit
main = runTest do
  -- Helper to construct scalars
  let scalar n = Scalar (fromNumber n)

  -- 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 "123e+"
      shouldFail "123e-"

  suite "Parser - Units (this may take some time)" do
    test "Simple" do
      allParseAs (Expression (Unit meter))
        [ "m"
        , "      m "
        , "meter"
        , "meters"
        , "metre"
        , "metres"
        ]

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

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

    let
      unp ∷ ∀ a. Dictionary a → Array (DictEntry a)
      unp (Dictionary dict) = dict

    test "All imperial units" do
      for_ (unp imperialUnitDict) $ \(unit ==> unitStrs) → do
        allParseAs (Expression (Unit  unit))
                   unitStrs

    test "All normal units" do
      for_ (unp normalUnitDict) $ \(unit ==> unitStrs) → do
        allParseAs (Expression (Unit  unit))
                   unitStrs

    for_ (unp siPrefixDict) $ \(siPrefix ==> prefixStrs) → do
      test ("Testing all units with prefix: " <> intercalate ", " prefixStrs) do
        for_ (unp normalUnitDict) $ \(unit ==> unitStrs) → do
          let allCombinations = do
                p <- prefixStrs
                u <- unitStrs
                pure (p <> u)
          allParseAs (Expression (Unit (siPrefix unit)))
                     allCombinations

    test "Special cases" do
      allParseAs (Expression (Unit day))
        [ "d"
        , " d "
        ]

      allParseAs (Expression (Unit tonne))
        [ "t"
        , " t "
        ]

  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"
        , "2.3 metre"
        , "2.3metres"
        ]

      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 minute))
        [ "10minutes"
        , "10minute"
        , "10min"
        ]

      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 "
        , "  2.3 kmetre "
        , "  2.3 kmetres "
        ]

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

      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 Div (q 2.3 (kilo meter)) (Unit hour)))
        [ "2.3km/h"
        , "2.30km/h"
        , "2.30km÷h"
        , "2.30 kilometer per hour"
        , "2.30 kilometre per hour"
        , "2.30km per h"
        ]

  suite "Parser - Operators" do
    test "Factorial" do
      allParseAs (Expression (Factorial (scalar 4.0))) $
        [ "4!"
        , "4.0!"
        , "4 !"
        , " 4 ! "
        , "(4)!"
        ]

      allParseAs (Expression (BinOp Pow (Factorial (scalar 5.0)) (scalar 3.0))) $
        [ "5!^3"
        , "5!³"
        , "(5!)^3"
        ]

      allParseAs (Expression (Negate (Factorial (scalar 5.0)))) $
        [ "-5!"
        , "-(5!)"
        ]

    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 per 3"
        , " 5 / 3 "
        , " ( 5 ) / ( 3 ) "
        , " ( ( 5 ) / ( 3 ) ) "
        , " ( 5 / 3 ) "
        ]

      shouldFail "5/"
      shouldFail "5 per"

    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)"
        , "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"
        , "42 per 7 per 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²"
        , "3×m²"
        , "3·m^(2.0)"
        ]

      allParseAs (Expression (BinOp Div (q 3.0 meter) (Unit second))) $
        [ "3m/s"
        , "3 meter / second"
        , "3 meter per second"
        , "3 metre / second"
        , "3 metre per second"
        , "(3m)/s"
        ]

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

      allParseAs (Expression (BinOp Pow (Unit meter) (Negate $ scalar 1.0))) $
        [ "m^(-1)"
        , "m^(-1.0)"
        , "meter^(-1.0)"
        , "metre^(-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 "
        , "2.3m→in"
        , "  2.3 m  →  in "
        , "2.3m to in"
        , "  2.3 m  to  in "
        ]

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

      shouldFail "2.3m->"
      shouldFail "-> km"
      shouldFail "2.3m →"
      shouldFail "2.3m to"
      shouldFail "to km"
      shouldFail "to"

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

      allParseAs (Expression (BinOp ConvertTo (BinOp Div (q 36.0 (kilo meter)) (Unit hour)) (Unit (mile ./ hour))))
        [ "36km/h -> mph"
        , " 36km / hour->mph "
        ]

  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''"
      shouldParseAs (Expression (Variable "to_")) "to_"

      shouldFail "xs,as"
      shouldFail "hello$"

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

    test "Variables which begin with 'e'" do
      allParseAs (Expression (BinOp Mul (scalar 2.0) (Variable "ex")))
        [ "2ex"
        , "2.0ex"
        , "2 ex"
        ]

      allParseAs (Expression (BinOp Mul (scalar 2.0) (Variable "e")))
        [ "2e"
        , "2.0e"
        , "2 e"
        ]

    test "Initial environment" do
      for_ (keys initialEnvironment) \ident →
        shouldParseAs (Expression (Variable ident)) ident

  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="
      shouldFail "x=3+"

    test "Reserved names" do
      shouldFail "m=2" -- 'm' is reserved unit
      shouldFail "meter=2" -- 'meter' is a reserved unit
      shouldFail "metre=2" -- 'meter' is a reserved unit
      shouldFail "list=4" -- 'list' is a reserved keyword
      shouldFail "sin=3" -- 'sin is a reserved keyword

  let pretty' str =
        case parseInsect str of
          Right (Expression expr) → format fmtPlain (pretty expr)
          _ → "Error"

  let equalPretty out inp =
        equal out (pretty' inp)

  suite "Pretty printer" do
    test "Consistency" do
      prettyPrintCheck "-2.3e-12387"
      prettyPrintCheck "2.3e-12387"
      prettyPrintCheck "18379173"
      prettyPrintCheck "2+3"
      prettyPrintCheck "2+3*5"
      prettyPrintCheck "-3^4+2/(4+2*3)"
      prettyPrintCheck "1-2-3-4-(5-6-7)"
      prettyPrintCheck "1/2/3/4/(5/6/7)"
      prettyPrintCheck "kg"
      prettyPrintCheck "2m/s"
      prettyPrintCheck "a+b*c^d-e*f"
      prettyPrintCheck "sin(x)^3"
      prettyPrintCheck "sin(cos(atanh(x)+2))^3"
      prettyPrintCheck "2^3^4^5"
      prettyPrintCheck "(2^3)^(4^5)"
      prettyPrintCheck "sqrt(1.4^2 + 1.5^2) * cos(pi/3)^2"
      prettyPrintCheck "40kg * 9.8m/s^2 * 150cm"
      prettyPrintCheck "4/3 * pi * r³"
      prettyPrintCheck "vol * density -> kg"
      prettyPrintCheck "atan(30cm / 2m)"
      prettyPrintCheck "500km/day -> km/h"
      prettyPrintCheck "1mrad -> °"
      prettyPrintCheck "52weeks -> days"
      prettyPrintCheck "5in + 2ft -> cm"
      prettyPrintCheck "6Mbit/s * 1.5h -> GB"
      prettyPrintCheck "2d"
      prettyPrintCheck "5t"
      prettyPrintCheck "länge * x_2 * µ * _prefixed"
      prettyPrintCheck "2m^3"
      prettyPrintCheck "(2m)^3"
      prettyPrintCheck "(2m)^(3kg)"
      prettyPrintCheck "(2m)^(3kg)^((4in)^(5ft))^(6s)"
      prettyPrintCheck "-sqrt(-30m^3)"
      prettyPrintCheck "-3^4"
      prettyPrintCheck "(-3)^4"
      prettyPrintCheck "5!³"
      prettyPrintCheck "2^3!"
      prettyPrintCheck "-3!"
      prettyPrintCheck "(-3)!"

    test "Format" do
      equalPretty "2 + 3" "2+3"
      equalPretty "2 × 3" "2*3"
      equalPretty "2^3" "2^3"
      equalPretty "2 km" "2km"
      equalPretty "sin(30°)" "sin(30°)"
      equalPretty "2 × 3 × 4" "2*3*4"
      equalPretty "2 × 3 × 4" "2*(3*4)"
      equalPretty "2 + 3 + 4" "2+3+4"
      equalPretty "2 + 3 + 4" "2+(3+4)"
      equalPretty "atan(30 cm / 2 m)" "atan(30cm / 2m)"
      equalPretty "1 mrad -> °" "1mrad -> °"
      equalPretty "2 km + 2 cm -> in" "2km+2cm -> in"
      equalPretty "2^3 + 4^5" "2^3 + 4^5"
      equalPretty "2^3 - 4^5" "2^3 - 4^5"
      equalPretty "2^3 × 4^5" "2^3 * 4^5"
      equalPretty "2 × 3 + 4 × 5" "2 * 3 + 4 * 5"
      equalPretty "2 × (3 / 4)" "2 * 3 / 4"
      equalPretty "123.123 × km^2 / s^2" "123.123 km^2 / s^2"

  let expectOutput' = expectOutput initialEnvironment

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

    test "Square and cube operators" do
      expectOutput' "18" "3²*2"
      expectOutput' "18" "3² 2"
      expectOutput' "18" "3²·2"
      expectOutput' "54" "3³*2"
      expectOutput' "54" "3³(2)"
      expectOutput' "9" "(1+2)²"
      expectOutput' "12.5664" "2²pi"
      expectOutput' "12.5664" "2² pi"
      expectOutput' "12.5664" "2²·pi"
      expectOutput' "500 cm·m" "5m² to cm·m"

    test "Conversions" do
      expectOutput' "5.08 cm" "2in to cm"
      expectOutput' "500 m·cm" "5m^2 -> m*cm"
      expectOutput' "500 cm·m" "5m^2 -> cm*m"

    test "Implicit multiplication" do
      let myEnv = insert "x" (5.0 .* meter) initialEnvironment
      expectOutput myEnv "5 m" "x"
      expectOutput myEnv "10 m" "2x"
      expectOutput myEnv "10 m" "2 x"
      expectOutput myEnv "25 m²" "x x"
      expectOutput myEnv "25 m²" "x²"
      expectOutput myEnv "Unknown identifier: x2" "x2"

    test "Function inverses" do
      expectOutput' "0.1234" "sin(asin(0.1234))"
      expectOutput' "0.1234" "cos(acos(0.1234))"
      expectOutput' "0.1234" "tan(atan(0.1234))"
      expectOutput' "0.1234" "sinh(asinh(0.1234))"
      expectOutput' "1.1234" "cosh(acosh(1.1234))"
      expectOutput' "0.1234" "tanh(atanh(0.1234))"
      expectOutput' "0.1234" "log(exp(0.1234))"

      expectOutput' "0.1234" "asin(sin(0.1234))"
      expectOutput' "0.1234" "acos(cos(0.1234))"
      expectOutput' "0.1234" "atan(tan(0.1234))"
      expectOutput' "0.1234" "asinh(sinh(0.1234))"
      expectOutput' "1.1234" "acosh(cosh(1.1234))"
      expectOutput' "0.1234" "atanh(tanh(0.1234))"
      expectOutput' "0.1234" "exp(log(0.1234))"

    test "Other functions" do
      expectOutput' "2" "sqrt(4)"
      expectOutput' "5" "log10(100000)"
      expectOutput' "15" "log(e^15)"
      expectOutput' "15" "ln(e^15)"
      expectOutput' "4" "ceil(3.1)"
      expectOutput' "3" "floor(3.9)"
      expectOutput' "4" "round(3.9)"
      expectOutput' "3" "round(3.1)"

    test "Unit simplification" do
      expectOutput' "36000 Mbit" "5Mbit/s * 2h"
      expectOutput' "2500 cm²" "5cm · 5m"
      expectOutput' "0.2 km" "120km/h*6s"

    test "Examples" do
      expectOutput' "1080" "1920/16*9"
      expectOutput' "4294967296" "2^32"
      expectOutput' "0.512957" "sqrt(1.4^2 + 1.5^2) * cos(pi/3)^2"

      expectOutput' "2.5 min" "2min + 30s"
      expectOutput' "150 s" "2min + 30s -> sec"
      expectOutput' "904779000000 km³" "4/3 * pi * (6000km)³"
      expectOutput' "588 m²·kg/s²" "40kg * 9.8m/s^2 * 150cm"
      expectOutput' "0.5" "sin(30°)"

      expectOutput' "26.8224 m/s" "60mph -> m/s"
      expectOutput' "10 km/h" "240km/day -> km/h"
      expectOutput' "0.0572958°" "1mrad -> °"
      expectOutput' "364 d" "52weeks -> days"
      expectOutput' "73.66 cm" "5in + 2ft -> cm"
      expectOutput' "8.53077°" "atan(30cm / 2m) -> °"
      expectOutput' "4.05 GB" "6Mbit/s * 1.5h -> GB"

      expectOutput' "0.75" "3m/4m"
      expectOutput' "4" "4/2*2"
      expectOutput' "0.5 s" "1/2 Hz -> s"

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

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

    test "Pendulum" do
      let env1 = initialEnvironment
          env2 = (repl fmtPlain env1 "len = 20cm").newEnv

      expectOutput env2 "897.294 ms" "2pi*sqrt(len/g0) -> ms"

    test "Unicode" do
      expectOutput' "6.62607e-34 J·s" "2π×ℏ"

      let env1 = initialEnvironment
          env2 = (repl fmtPlain env1 "λ = 2 × 300µm").newEnv
      expectOutput env2 "499.654 GHz" "ν = c/λ → GHz"

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.Decimal (fromNumber)
import Data.StrMap (insert, keys)
import Data.Either(Either(..))
import Data.Foldable (traverse_, for_, intercalate)

import Test.Unit (suite, test, failure)
import Test.Unit.Assert (equal)
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,
                   day, tonne)

import Insect.Language (Func(..), BinOp(..), Expression(..), Statement(..))
import Insect.Parser (Dictionary(..), DictEntry, (==>), siPrefixDict,
                      normalUnitDict, imperialUnitDict, parseInsect)
import Insect.Environment (Environment, initialEnvironment)
import Insect.Format (format, fmtPlain)
import Insect.PrettyPrint (pretty)
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 fmtPlain env inp
      out = res.msg
  in
    unless (out == expected) do
      failure $ "Unexpected result:\n" <>
                "Input:    '" <> inp <> "'\n" <>
                "Output:   '" <> out <> "'\n" <>
                "Expected: '" <> expected <> "'\n"

prettyPrintCheck ∷ ∀ eff. String → Aff eff Unit
prettyPrintCheck 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 →
      case output of
        Expression expr →
          -- Pretty print the AST, parse it again and check against the
          -- original AST.
          shouldParseAs output (format fmtPlain (pretty expr))
        _ →
          failure $ "Input is not an expression"

main ∷ Eff (console ∷ CONSOLE, testOutput ∷ TESTOUTPUT, avar ∷ AVAR) Unit
main = runTest do
  -- Helper to construct scalars
  let scalar n = Scalar (fromNumber n)

  -- 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 "123e+"
      shouldFail "123e-"

  suite "Parser - Units (this may take some time)" 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"
        ]

    let
      unp ∷ ∀ a. Dictionary a → Array (DictEntry a)
      unp (Dictionary dict) = dict

    test "All imperial units" do
      for_ (unp imperialUnitDict) $ \(unit ==> unitStrs) → do
        allParseAs (Expression (Unit  unit))
                   unitStrs

    test "All normal units" do
      for_ (unp normalUnitDict) $ \(unit ==> unitStrs) → do
        allParseAs (Expression (Unit  unit))
                   unitStrs

    for_ (unp siPrefixDict) $ \(siPrefix ==> prefixStrs) → do
      test ("Testing all units with prefix: " <> intercalate ", " prefixStrs) do
        for_ (unp normalUnitDict) $ \(unit ==> unitStrs) → do
          let allCombinations = do
                p <- prefixStrs
                u <- unitStrs
                pure (p <> u)
          allParseAs (Expression (Unit (siPrefix unit)))
                     allCombinations

    test "Special cases" do
      allParseAs (Expression (Unit day))
        [ "d"
        , " d "
        ]

      allParseAs (Expression (Unit tonne))
        [ "t"
        , " t "
        ]

  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 minute))
        [ "10minutes"
        , "10minute"
        , "10min"
        ]

      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 Div (q 2.3 (kilo meter)) (Unit hour)))
        [ "2.3km/h"
        , "2.30km/h"
        , "2.30km÷h"
        , "2.30 kilometer per hour"
        , "2.30km per h"
        ]

  suite "Parser - Operators" do
    test "Factorial" do
      allParseAs (Expression (Factorial (scalar 4.0))) $
        [ "4!"
        , "4.0!"
        , "4 !"
        , " 4 ! "
        , "(4)!"
        ]

      allParseAs (Expression (BinOp Pow (Factorial (scalar 5.0)) (scalar 3.0))) $
        [ "5!^3"
        , "5!³"
        , "(5!)^3"
        ]

      allParseAs (Expression (Negate (Factorial (scalar 5.0)))) $
        [ "-5!"
        , "-(5!)"
        ]

    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 per 3"
        , " 5 / 3 "
        , " ( 5 ) / ( 3 ) "
        , " ( ( 5 ) / ( 3 ) ) "
        , " ( 5 / 3 ) "
        ]

      shouldFail "5/"
      shouldFail "5 per"

    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)"
        , "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"
        , "42 per 7 per 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²"
        , "3×m²"
        , "3·m^(2.0)"
        ]

      allParseAs (Expression (BinOp Div (q 3.0 meter) (Unit second))) $
        [ "3m/s"
        , "3 meter / second"
        , "3 meter per second"
        , "(3m)/s"
        ]

      allParseAs (Expression (BinOp Mul (scalar 3.0) (BinOp Div (Unit meter) (Unit second)))) $
        [ "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 "
        , "2.3m→in"
        , "  2.3 m  →  in "
        , "2.3m to in"
        , "  2.3 m  to  in "
        ]

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

      shouldFail "2.3m->"
      shouldFail "-> km"
      shouldFail "2.3m →"
      shouldFail "2.3m to"
      shouldFail "to km"
      shouldFail "to"

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

      allParseAs (Expression (BinOp ConvertTo (BinOp Div (q 36.0 (kilo meter)) (Unit hour)) (Unit (mile ./ hour))))
        [ "36km/h -> mph"
        , " 36km / hour->mph "
        ]

  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''"
      shouldParseAs (Expression (Variable "to_")) "to_"

      shouldFail "xs,as"
      shouldFail "hello$"

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

    test "Variables which begin with 'e'" do
      allParseAs (Expression (BinOp Mul (scalar 2.0) (Variable "ex")))
        [ "2ex"
        , "2.0ex"
        , "2 ex"
        ]

      allParseAs (Expression (BinOp Mul (scalar 2.0) (Variable "e")))
        [ "2e"
        , "2.0e"
        , "2 e"
        ]

    test "Initial environment" do
      for_ (keys initialEnvironment) \ident →
        shouldParseAs (Expression (Variable ident)) ident

  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="
      shouldFail "x=3+"

    test "Reserved names" do
      shouldFail "m=2" -- 'm' is reserved unit
      shouldFail "meter=2" -- 'meter' is a reserved unit
      shouldFail "list=4" -- 'list' is a reserved keyword
      shouldFail "sin=3" -- 'sin is a reserved keyword

  let pretty' str =
        case parseInsect str of
          Right (Expression expr) → format fmtPlain (pretty expr)
          _ → "Error"

  let equalPretty out inp =
        equal out (pretty' inp)

  suite "Pretty printer" do
    test "Consistency" do
      prettyPrintCheck "-2.3e-12387"
      prettyPrintCheck "2.3e-12387"
      prettyPrintCheck "18379173"
      prettyPrintCheck "2+3"
      prettyPrintCheck "2+3*5"
      prettyPrintCheck "-3^4+2/(4+2*3)"
      prettyPrintCheck "1-2-3-4-(5-6-7)"
      prettyPrintCheck "1/2/3/4/(5/6/7)"
      prettyPrintCheck "kg"
      prettyPrintCheck "2m/s"
      prettyPrintCheck "a+b*c^d-e*f"
      prettyPrintCheck "sin(x)^3"
      prettyPrintCheck "sin(cos(atanh(x)+2))^3"
      prettyPrintCheck "2^3^4^5"
      prettyPrintCheck "(2^3)^(4^5)"
      prettyPrintCheck "sqrt(1.4^2 + 1.5^2) * cos(pi/3)^2"
      prettyPrintCheck "40kg * 9.8m/s^2 * 150cm"
      prettyPrintCheck "4/3 * pi * r³"
      prettyPrintCheck "vol * density -> kg"
      prettyPrintCheck "atan(30cm / 2m)"
      prettyPrintCheck "500km/day -> km/h"
      prettyPrintCheck "1mrad -> °"
      prettyPrintCheck "52weeks -> days"
      prettyPrintCheck "5in + 2ft -> cm"
      prettyPrintCheck "6Mbit/s * 1.5h -> GB"
      prettyPrintCheck "2d"
      prettyPrintCheck "5t"
      prettyPrintCheck "länge * x_2 * µ * _prefixed"
      prettyPrintCheck "2m^3"
      prettyPrintCheck "(2m)^3"
      prettyPrintCheck "(2m)^(3kg)"
      prettyPrintCheck "(2m)^(3kg)^((4in)^(5ft))^(6s)"
      prettyPrintCheck "-sqrt(-30m^3)"
      prettyPrintCheck "-3^4"
      prettyPrintCheck "(-3)^4"
      prettyPrintCheck "5!³"
      prettyPrintCheck "2^3!"
      prettyPrintCheck "-3!"
      prettyPrintCheck "(-3)!"

    test "Format" do
      equalPretty "2 + 3" "2+3"
      equalPretty "2 × 3" "2*3"
      equalPretty "2^3" "2^3"
      equalPretty "2 km" "2km"
      equalPretty "sin(30°)" "sin(30°)"
      equalPretty "2 × 3 × 4" "2*3*4"
      equalPretty "2 × 3 × 4" "2*(3*4)"
      equalPretty "2 + 3 + 4" "2+3+4"
      equalPretty "2 + 3 + 4" "2+(3+4)"
      equalPretty "atan(30 cm / 2 m)" "atan(30cm / 2m)"
      equalPretty "1 mrad -> °" "1mrad -> °"
      equalPretty "2 km + 2 cm -> in" "2km+2cm -> in"
      equalPretty "2^3 + 4^5" "2^3 + 4^5"
      equalPretty "2^3 - 4^5" "2^3 - 4^5"
      equalPretty "2^3 × 4^5" "2^3 * 4^5"
      equalPretty "2 × 3 + 4 × 5" "2 * 3 + 4 * 5"
      equalPretty "2 × (3 / 4)" "2 * 3 / 4"
      equalPretty "123.123 × km^2 / s^2" "123.123 km^2 / s^2"

  let expectOutput' = expectOutput initialEnvironment

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

    test "Square and cube operators" do
      expectOutput' "18" "3²*2"
      expectOutput' "18" "3² 2"
      expectOutput' "18" "3²·2"
      expectOutput' "54" "3³*2"
      expectOutput' "54" "3³(2)"
      expectOutput' "9" "(1+2)²"
      expectOutput' "12.5664" "2²pi"
      expectOutput' "12.5664" "2² pi"
      expectOutput' "12.5664" "2²·pi"
      expectOutput' "500 cm·m" "5m² to cm·m"

    test "Conversions" do
      expectOutput' "5.08 cm" "2in to cm"
      expectOutput' "500 m·cm" "5m^2 -> m*cm"
      expectOutput' "500 cm·m" "5m^2 -> cm*m"

    test "Implicit multiplication" do
      let myEnv = insert "x" (5.0 .* meter) initialEnvironment
      expectOutput myEnv "5 m" "x"
      expectOutput myEnv "10 m" "2x"
      expectOutput myEnv "10 m" "2 x"
      expectOutput myEnv "25 m²" "x x"
      expectOutput myEnv "25 m²" "x²"
      expectOutput myEnv "Unknown identifier: x2" "x2"

    test "Function inverses" do
      expectOutput' "0.1234" "sin(asin(0.1234))"
      expectOutput' "0.1234" "cos(acos(0.1234))"
      expectOutput' "0.1234" "tan(atan(0.1234))"
      expectOutput' "0.1234" "sinh(asinh(0.1234))"
      expectOutput' "1.1234" "cosh(acosh(1.1234))"
      expectOutput' "0.1234" "tanh(atanh(0.1234))"
      expectOutput' "0.1234" "log(exp(0.1234))"

      expectOutput' "0.1234" "asin(sin(0.1234))"
      expectOutput' "0.1234" "acos(cos(0.1234))"
      expectOutput' "0.1234" "atan(tan(0.1234))"
      expectOutput' "0.1234" "asinh(sinh(0.1234))"
      expectOutput' "1.1234" "acosh(cosh(1.1234))"
      expectOutput' "0.1234" "atanh(tanh(0.1234))"
      expectOutput' "0.1234" "exp(log(0.1234))"

    test "Other functions" do
      expectOutput' "2" "sqrt(4)"
      expectOutput' "5" "log10(100000)"
      expectOutput' "15" "log(e^15)"
      expectOutput' "15" "ln(e^15)"
      expectOutput' "4" "ceil(3.1)"
      expectOutput' "3" "floor(3.9)"
      expectOutput' "4" "round(3.9)"
      expectOutput' "3" "round(3.1)"

    test "Unit simplification" do
      expectOutput' "36000 Mbit" "5Mbit/s * 2h"
      expectOutput' "2500 cm²" "5cm · 5m"
      expectOutput' "0.2 km" "120km/h*6s"

    test "Examples" do
      expectOutput' "1080" "1920/16*9"
      expectOutput' "4294967296" "2^32"
      expectOutput' "0.512957" "sqrt(1.4^2 + 1.5^2) * cos(pi/3)^2"

      expectOutput' "2.5 min" "2min + 30s"
      expectOutput' "150 s" "2min + 30s -> sec"
      expectOutput' "904779000000 km³" "4/3 * pi * (6000km)³"
      expectOutput' "588 m²·kg/s²" "40kg * 9.8m/s^2 * 150cm"
      expectOutput' "0.5" "sin(30°)"

      expectOutput' "26.8224 m/s" "60mph -> m/s"
      expectOutput' "10 km/h" "240km/day -> km/h"
      expectOutput' "0.0572958°" "1mrad -> °"
      expectOutput' "364 d" "52weeks -> days"
      expectOutput' "73.66 cm" "5in + 2ft -> cm"
      expectOutput' "8.53077°" "atan(30cm / 2m) -> °"
      expectOutput' "4.05 GB" "6Mbit/s * 1.5h -> GB"

      expectOutput' "0.75" "3m/4m"
      expectOutput' "4" "4/2*2"
      expectOutput' "0.5 s" "1/2 Hz -> s"

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

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

    test "Pendulum" do
      let env1 = initialEnvironment
          env2 = (repl fmtPlain env1 "len = 20cm").newEnv

      expectOutput env2 "897.294 ms" "2pi*sqrt(len/g0) -> ms"

    test "Unicode" do
      expectOutput' "6.62607e-34 J·s" "2π×ℏ"

      let env1 = initialEnvironment
          env2 = (repl fmtPlain env1 "λ = 2 × 300µm").newEnv
      expectOutput env2 "499.654 GHz" "ν = c/λ → GHz"


Added initial prototype for WebGL Reader Monad.

module Monad where

import Prelude
import Control.Monad.Reader

data Context = Context Int

instance showContext :: Show Context where
	show (Context id) = "Context " ++ show id

data Buffer = Buffer Int Int Int Int

instance showBuffer :: Show Buffer where
	show (Buffer id x y z) = "Buffer " ++ show id ++ " [" ++ show x ++ ", " ++ show y ++ ", " ++ show z ++ "]"

type WebGL a = Reader Context a

runWebGL :: forall a. Context -> WebGL a -> a
runWebGL ctx x = runReader x ctx

createBuffer :: WebGL Buffer
createBuffer = do
	Context id <- ask
	return (Buffer id 0 0 0)

initContext :: String -> Context
initContext _ = Context 0

testWebGL :: String
testWebGL = runWebGL (initContext "easel") do
	buffer <- createBuffer
	return $ show buffer

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


Adding NgModelController

Adding NgModelController

module Angular.NgModelController
 ( NgModelController(..)
 , NgModelCtrl(..)
 , Parser(..)
 , Formatter(..)
 , ValidationErrorKey(..)
 , render
 , setRender
 , isEmpty
 , setIsEmpty
 , setValidity
 , setPristine
 , setViewValue
 , viewValue
 , modelValue
 , setModelValue
 , appendParsers
 , prependParsers
 , appendFormatters
 , prependFormatters
 , appendViewChangeListeners
 , prependViewChangeListeners
 , error
 , pristine
 , dirty
 , valid
 , invalid
 ) where

import Control.Monad.Eff
import Data.Maybe

foreign import data NgModelController :: * -> *

foreign import data NgModelCtrl :: !

type ValidationErrorKey = String

type Parser a = String -> Maybe a

type Formatter a = a -> String

foreign import render
  " function render($ctrl){ \
  \   return function(){ \
  \     return $ctrl.$render(); \
  \   }; \
  \ } "
  :: forall e a. NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) Unit

foreign import setRender
  " function setRender(render){ \
  \   return function($ctrl){ \
  \     $ctrl.$render = render; \
  \     return {}; \
  \   }; \
  \ } "
  :: forall e a. Eff (ngmodel :: NgModelCtrl | e) Unit -> NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) Unit

foreign import isEmpty
  " function isEmpty(value){ \
  \   return function($ctrl){ \
  \     return $ctrl.$isEmpty(value); \
  \   }; \
  \ } "
  :: forall e a. a -> NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) Boolean

foreign import setIsEmpty
  " function setIsEmpty(isEmpty){ \
  \   return function($ctrl){ \
  \     $ctrl.$isEmpty = function(a){return isEmpty(a)();}; \
  \     return $ctrl; \
  \   }; \
  \ } "
  :: forall e a b. (b -> Eff (ngmodel :: NgModelCtrl | e) Boolean) -> NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) (NgModelController b)

foreign import setValidity
  " function setValidity(validationErrorKey){ \
  \   return function(isValid){ \
  \     return function($ctrl){ \
  \       return $ctrl.$setValidity(validationErrorKey, isValid); \
  \     }; \
  \   }; \
  \ } "
  :: forall e a. ValidationErrorKey -> Boolean -> NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) Unit

foreign import setPristine
  " function setPristine($ctrl){ \
  \   return function(){ \
  \     return $ctrl.$setPristine(); \
  \   }; \
  \ } "
  :: forall e a. NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) Unit

foreign import setViewValue
  " function setViewValue(value){ \
  \   return function($ctrl){ \
  \     return function(){ \
  \       return $ctrl.$setViewValue(value); \
  \     }; \
  \   }; \
  \ } "
  :: forall e a. String -> NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) Unit

foreign import viewValue
  " function viewValue($ctrl){ \
  \   return function(){ \
  \     return $ctrl.$viewValue; \
  \   }; \
  \ } "
  :: forall e a. NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) String

foreign import modelValue
  " function modelValue($ctrl){ \
  \   return function(){ \
  \     return $ctrl.$modelValue; \
  \   }; \
  \ } "
  :: forall e a. NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) a

foreign import setModelValue
  " function setModelValue(value){ \
  \   return function($ctrl){ \
  \     return function(){ \
  \       $ctrl.$modelValue = value; \
  \       return $ctrl; \
  \     }; \
  \   }; \
  \ } "
  :: forall e a b. b -> NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) (NgModelController b)

foreign import appendParsers
  " function appendParsers(parsers){ \
  \   return function($ctrl){ \
  \     return function(){ \
  \       var as = []; \
  \       angular.forEach(parsers, function(p){ \
  \         as.push(function(v){ \
  \           return p(v).values[0]; \
  \         }); \
  \       }); \
  \       $ctrl.$parsers.push.apply($ctrl.$parsers, as); \
  \       return {}; \
  \     }; \
  \   }; \
  \ } "
  :: forall e a. [Parser a] -> NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) Unit

foreign import prependParsers
  " function prependParsers(parsers){ \
  \   return function($ctrl){ \
  \     return function(){ \
  \       var as = []; \
  \       angular.forEach(parsers, function(p){ \
  \         as.push(function(v){ \
  \           return p(v).values[0]; \
  \         }); \
  \       }); \
  \       $ctrl.$parsers.unshift.apply($ctrl.$parsers, as); \
  \       return {}; \
  \     }; \
  \   }; \
  \ } "
  :: forall e a. [Parser a] -> NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) Unit

foreign import appendFormatters
  " function appendFormatters(formatters){ \
  \   return function($ctrl){ \
  \     return function(){ \
  \       $ctrl.$formatters.push.apply($ctrl.$formatters, formatters); \
  \       return {}; \
  \     }; \
  \   }; \
  \ } "
  :: forall e a. [Formatter a] -> NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) Unit

foreign import prependFormatters
  " function prependFormatters(formatters){ \
  \   return function($ctrl){ \
  \     return function(){ \
  \       $ctrl.$formatters.unshift.apply($ctrl.$formatters, formatters); \
  \       return {}; \
  \     }; \
  \   }; \
  \ } "
  :: forall e a. [Formatter a] -> NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) Unit

foreign import appendViewChangeListeners
  " function appendViewChangeListeners(listeners){ \
  \   return function($ctrl){ \
  \     return function(){ \
  \       $ctrl.$viewChangeListeners.push.apply($ctrl.$viewChangeListeners, listeners); \
  \       return {}; \
  \     }; \
  \   }; \
  \ } "
  :: forall e a. [Eff e Unit] -> NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) Unit

foreign import prependViewChangeListeners
  " function prependViewChangeListeners(listeners){ \
  \   return function($ctrl){ \
  \     return function(){ \
  \       $ctrl.$viewChangeListeners.unshift.apply($ctrl.$viewChangeListeners, listeners); \
  \       return {}; \
  \     }; \
  \   }; \
  \ } "
  :: forall e a. [Eff e Unit] -> NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) Unit

foreign import error
  " function error($ctrl){ \
  \   return function(){ \
  \     return $ctrl.$error; \
  \   }; \
  \ } "
  :: forall e a b. NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) { | b }

foreign import pristine
  " function pristine($ctrl){ \
  \   return function(){ \
  \     return $ctrl.$pristine; \
  \   }; \
  \ } "
  :: forall e a. NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) Boolean

foreign import dirty
  " function dirty($ctrl){ \
  \   return function(){ \
  \     return $ctrl.$dirty; \
  \   }; \
  \ } "
  :: forall e a. NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) Boolean

foreign import valid
  " function valid($ctrl){ \
  \   return function(){ \
  \     return $ctrl.$valid; \
  \   }; \
  \ } "
  :: forall e a. NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) Boolean

foreign import invalid
  " function invalid($ctrl){ \
  \   return function(){ \
  \     return $ctrl.$invalid; \
  \   }; \
  \ } "
  :: forall e a. NgModelController a -> Eff (ngmodel :: NgModelCtrl | e) Boolean

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


Properly enabled turn - hopefully!

Properly enabled turn - hopefully!

module Gonimo.UI.Socket.Channel where

import Prelude
import Data.Array as Arr
import Data.Tuple as Tuple
import Gonimo.UI.Socket.Message as Message
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream as MediaStream
import WebRTC.RTC as RTC
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Control.Monad.State.Class (get)
import Data.Identity (runIdentity)
import Data.Lens ((^?), _Just, lens, Lens, (.=))
import Data.Maybe (fromMaybe, isJust, maybe, Maybe(Nothing, Just))
import Data.Tuple (Tuple(Tuple))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (noEffects, runGonimo, Component, Update, onlyModify, ComponentType)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.State.Types (MessageNumber(MessageNumber))
import Gonimo.Server.Types.Lenses (_Baby)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Channel.Types (Action, Action(..), State, Props)
import Gonimo.UI.Socket.Lenses (mediaStream)
import Gonimo.UI.Socket.Message (runMaybeIceCandidate, MaybeIceCandidate(JustIceCandidate, NoIceCandidate), encodeToString, decodeFromString, Message)
import Gonimo.Util (coerceEffects)
import Gonimo.WebAPI (deleteSocketByFamilyIdByFromDeviceByToDeviceByChannelIdMessagesByMessageNumber, putSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Subscriber (getSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Pux.Html (text, Html)
import Pux.Html.Attributes (offset)
import Servant.Subscriber (Subscriptions)
import Unsafe.Coerce (unsafeCoerce)
import WebRTC.MediaStream (createObjectURL, mediaStreamToBlob, stopStream, getUserMedia, MediaStreamConstraints(MediaStreamConstraints), MediaStream)
import WebRTC.RTC (onnegotiationneeded, closeRTCPeerConnection, MediaStreamEvent, setLocalDescription, createAnswer, iceEventCandidate, IceEvent, onicecandidate, onaddstream, addIceCandidate, setRemoteDescription, fromRTCSessionDescription, createOffer, addStream, RTCIceCandidateInit, RTCPeerConnection, Ice, newRTCPeerConnection)

init :: Maybe MediaStream -> IO State
init stream = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ { urls : [ "turn:gonimo.com:3478" ]
                                                                  , username : "gonimo"
                                                                  , credential : "Aeloh5chai2eil1"
                                                                  , credentialType : "password"
                                                                  }
                                                                ]
                                                 }
                           )
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ stream
    liftEff $ MediaStream.clone origStream
  pure $  { mediaStream : ourStream
          , remoteStream : Nothing
          , rtcConnection : rtcConnection
          , isBabyStation : isJust stream
          }

remoteStream :: forall a b r. Lens { "remoteStream" :: a | r } { "remoteStream" :: b | r } a b
remoteStream = lens _."remoteStream" (_ { "remoteStream" = _ })

update :: forall ps. Update (Props ps) State Action
update action = case action of
  InitConnection                     -> handleInit -- Things we can't do in init already.
  StartStreaming constraints         -> handleStartStreaming constraints
  StartNegotiation                   -> handleStartNegotiation
  SetMediaStream stream              -> handleSetMediaStream stream
  StopStreaming                      -> closeConnection
  CloseConnection                    -> handleCloseConnection
  AcceptMessage num message          -> handleAcceptMessage num message
  OnIceCandidate iceEvent            -> handleOnIceCandidate iceEvent
  OnAddStream streamEvent            -> handleOnAddStream streamEvent
  SetRemoteStream stream             -> remoteStream .= Just stream *> pure []
  ReportError _                      -> noEffects
  Nop                                -> noEffects

handleInit :: forall ps. ComponentType (Props ps) State Action
handleInit = do
  props <- ask :: Component (Props ps) State (Props ps)
  state <- get :: Component (Props ps) State State
  sendMessage <- getSendMessage
  pure
    [ do
         liftEff $ onaddstream (coerceEffects <<< props.sendAction <<< OnAddStream ) state.rtcConnection
         liftEff $ onicecandidate (coerceEffects <<< props.sendAction <<< OnIceCandidate ) state.rtcConnection
         liftEff $ onnegotiationneeded (coerceEffects <<< props.sendAction $ StartNegotiation) state.rtcConnection
         if state.isBabyStation
           then pure Nop
           else sendMessage Message.StartStreaming
    ]

handleStartStreaming :: forall ps.
                        MediaStreamConstraints
                        -> ComponentType (Props ps) State Action
handleStartStreaming constraints =
  pure [ liftAff $ SetMediaStream <$> coerceEffects (getUserMedia constraints) ]

handleSendStartStreaming :: forall ps. ComponentType (Props ps) State Action
handleSendStartStreaming = do
  sendMessage <- getSendMessage
  pure [ sendMessage Message.StartStreaming ]

handleSetMediaStream :: forall ps. MediaStream -> ComponentType (Props ps) State Action
handleSetMediaStream stream = do
  mediaStream .= Just stream
  startStreaming stream

startStreaming :: forall ps. MediaStream -> ComponentType (Props ps) State Action
startStreaming stream = do
  state <- get
  sendMessage <- getSendMessage
  pure [ do
            liftEff $ addStream stream state.rtcConnection
            pure Nop
       ]

handleStartNegotiation :: forall ps. ComponentType (Props ps) State Action
handleStartNegotiation = do
  state <- get
  sendMessage <- getSendMessage
  pure [ do
            offer <- liftAff $ createOffer state.rtcConnection
            liftAff $ setLocalDescription offer state.rtcConnection
            sendMessage $ Message.SessionDescriptionOffer offer
            pure Nop
       ]

handleOnIceCandidate :: forall ps. IceEvent -> ComponentType (Props ps) State Action
handleOnIceCandidate event = do
  let candidate = iceEventCandidate event
  let mCandidate = maybe NoIceCandidate JustIceCandidate candidate
  sendMessage <- getSendMessage
  pure [ sendMessage $ Message.IceCandidate mCandidate ]

handleOnAddStream :: forall ps. MediaStreamEvent  -> ComponentType (Props ps) State Action
handleOnAddStream event = do
  pure [ do
            url <- liftEff <<< createObjectURL <<< mediaStreamToBlob $ event.stream
            pure $ SetRemoteStream $ { stream : event.stream, objectURL : url }
       ]

getSendMessage :: forall ps. Component (Props ps) State (Message -> IO Action)
getSendMessage = do
  let sendString = putSocketByFamilyIdByFromDeviceByToDeviceByChannelId
  props <- ask
  let familyId' = props.familyId
  let fromDevice' = props.ourId
  let toDevice' = props.theirId
  let channelId' = props.cSecret
  pure $ toIO props.settings <<< ( \msg ->  do
    let strMsg = encodeToString msg
    sendString strMsg familyId' fromDevice' toDevice' channelId'
    pure Nop)

handleAcceptMessage :: forall ps. MessageNumber -> Message -> ComponentType (Props ps) State Action
handleAcceptMessage msgNumber msg = do
    props <- ask
    actions <- handleMessage
    let deleteMessage = deleteSocketByFamilyIdByFromDeviceByToDeviceByChannelIdMessagesByMessageNumber
    deleteActions <- runGonimo $ do
      deleteMessage props.familyId props.theirId props.ourId props.cSecret msgNumber
      pure Nop
    pure $ deleteActions <> actions
  where
    handleMessage :: ComponentType (Props ps) State Action
    handleMessage = do
      state <- get
      sendMessage <- getSendMessage
      case msg of
        Message.StartStreaming -> fromMaybe (pure []) $ startStreaming <$> state.mediaStream
        Message.SessionDescriptionOffer description ->
          pure [ do
                  liftAff $ setRemoteDescription description state.rtcConnection
                  answer <- liftAff $ createAnswer state.rtcConnection
                  liftAff $ setLocalDescription answer state.rtcConnection
                  sendMessage $ Message.SessionDescriptionAnswer answer
              ]
        Message.SessionDescriptionAnswer description ->
          pure [ do
                  liftAff $ setRemoteDescription description state.rtcConnection
                  pure Nop
              ]
        Message.IceCandidate candidate ->
          pure [ do
                  let test = runMaybeIceCandidate candidate
                  case test of
                    Nothing -> pure unit -- let's see whether this helps
                    Just c -> liftAff $ addIceCandidate (runMaybeIceCandidate candidate) state.rtcConnection
                  pure Nop
              ]
        Message.CloseConnection -> closeConnection

closeConnection :: forall ps. ComponentType (Props ps) State Action
closeConnection = do
  state <- get
  let conn = state.rtcConnection
  pure $ fromMaybe [] $ do
    stream <- state.mediaStream
    pure [ liftEff $ do
              stopStream stream
              closeRTCPeerConnection conn
              pure Nop
         ]

handleCloseConnection :: forall ps. ComponentType (Props ps) State Action
handleCloseConnection = do
  sendMessage <- getSendMessage
  closeActions <- closeConnection
  pure $ closeActions <> [ sendMessage Message.CloseConnection ]

view :: forall ps. Props ps -> State -> Html Action
view props state =
  let
    mBabyDevice = Tuple.lookup props.theirId props.onlineDevices
    babyName = fromMaybe "unknown baby" $ mBabyDevice ^? _Just <<< _Baby
  in
    H.div [ A.className "panel panel-default" ]
            [ H.div [ A.className "panel-heading" ]
              [
                H.text babyName
              ]
            , viewVideo state
            ]

viewVideo :: State -> Html Action
viewVideo state =
   case state.remoteStream of
       Nothing -> H.text $ "Sorry - no video there yet, please check that your camera/microphone "
                  <> "are enabled on the baby station and your browser allows us to access it."
       Just stream ->
         H.video [ A.src stream.objectURL
                 , A.autoPlay "true"
                 , A.controls true
                 , A.width "100%"
                 ] []

getSubscriptions :: forall m ps. (MonadReader Settings m) => Props ps -> m (Subscriptions Action)
getSubscriptions props =
  let
    receiveMessage = getSocketByFamilyIdByFromDeviceByToDeviceByChannelId doDecode
    doDecode :: Maybe (Maybe (Tuple MessageNumber String)) -> Action
    doDecode (Just (Just (Tuple num msg))) = fromMaybe Nop
                                             $ AcceptMessage num <$> decodeFromString msg
    doDecode _                             = Nop
  in
    receiveMessage props.familyId props.theirId props.ourId props.cSecret

module Gonimo.UI.Socket.Channel where

import Prelude
import Data.Array as Arr
import Data.Tuple as Tuple
import Gonimo.UI.Socket.Message as Message
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream as MediaStream
import WebRTC.RTC as RTC
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Control.Monad.State.Class (get)
import Data.Identity (runIdentity)
import Data.Lens ((^?), _Just, lens, Lens, (.=))
import Data.Maybe (fromMaybe, isJust, maybe, Maybe(Nothing, Just))
import Data.Tuple (Tuple(Tuple))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (noEffects, runGonimo, Component, Update, onlyModify, ComponentType)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.State.Types (MessageNumber(MessageNumber))
import Gonimo.Server.Types.Lenses (_Baby)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Channel.Types (Action, Action(..), State, Props)
import Gonimo.UI.Socket.Lenses (mediaStream)
import Gonimo.UI.Socket.Message (runMaybeIceCandidate, MaybeIceCandidate(JustIceCandidate, NoIceCandidate), encodeToString, decodeFromString, Message)
import Gonimo.Util (coerceEffects)
import Gonimo.WebAPI (deleteSocketByFamilyIdByFromDeviceByToDeviceByChannelIdMessagesByMessageNumber, putSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Subscriber (getSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Pux.Html (text, Html)
import Pux.Html.Attributes (offset)
import Servant.Subscriber (Subscriptions)
import Unsafe.Coerce (unsafeCoerce)
import WebRTC.MediaStream (createObjectURL, mediaStreamToBlob, stopStream, getUserMedia, MediaStreamConstraints(MediaStreamConstraints), MediaStream)
import WebRTC.RTC (onnegotiationneeded, closeRTCPeerConnection, MediaStreamEvent, setLocalDescription, createAnswer, iceEventCandidate, IceEvent, onicecandidate, onaddstream, addIceCandidate, setRemoteDescription, fromRTCSessionDescription, createOffer, addStream, RTCIceCandidateInit, RTCPeerConnection, Ice, newRTCPeerConnection)

init :: Maybe MediaStream -> IO State
init stream = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ {url : "turn:gonimo.com:3478"} ] })
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ stream
    liftEff $ MediaStream.clone origStream
  pure $  { mediaStream : ourStream
          , remoteStream : Nothing
          , rtcConnection : rtcConnection
          , isBabyStation : isJust stream
          }

remoteStream :: forall a b r. Lens { "remoteStream" :: a | r } { "remoteStream" :: b | r } a b
remoteStream = lens _."remoteStream" (_ { "remoteStream" = _ })

update :: forall ps. Update (Props ps) State Action
update action = case action of
  InitConnection                     -> handleInit -- Things we can't do in init already.
  StartStreaming constraints         -> handleStartStreaming constraints
  StartNegotiation                   -> handleStartNegotiation
  SetMediaStream stream              -> handleSetMediaStream stream
  StopStreaming                      -> closeConnection
  CloseConnection                    -> handleCloseConnection
  AcceptMessage num message          -> handleAcceptMessage num message
  OnIceCandidate iceEvent            -> handleOnIceCandidate iceEvent
  OnAddStream streamEvent            -> handleOnAddStream streamEvent
  SetRemoteStream stream             -> remoteStream .= Just stream *> pure []
  ReportError _                      -> noEffects
  Nop                                -> noEffects

handleInit :: forall ps. ComponentType (Props ps) State Action
handleInit = do
  props <- ask :: Component (Props ps) State (Props ps)
  state <- get :: Component (Props ps) State State
  sendMessage <- getSendMessage
  pure
    [ do
         liftEff $ onaddstream (coerceEffects <<< props.sendAction <<< OnAddStream ) state.rtcConnection
         liftEff $ onicecandidate (coerceEffects <<< props.sendAction <<< OnIceCandidate ) state.rtcConnection
         liftEff $ onnegotiationneeded (coerceEffects <<< props.sendAction $ StartNegotiation) state.rtcConnection
         if state.isBabyStation
           then pure Nop
           else sendMessage Message.StartStreaming
    ]

handleStartStreaming :: forall ps.
                        MediaStreamConstraints
                        -> ComponentType (Props ps) State Action
handleStartStreaming constraints =
  pure [ liftAff $ SetMediaStream <$> coerceEffects (getUserMedia constraints) ]

handleSendStartStreaming :: forall ps. ComponentType (Props ps) State Action
handleSendStartStreaming = do
  sendMessage <- getSendMessage
  pure [ sendMessage Message.StartStreaming ]

handleSetMediaStream :: forall ps. MediaStream -> ComponentType (Props ps) State Action
handleSetMediaStream stream = do
  mediaStream .= Just stream
  startStreaming stream

startStreaming :: forall ps. MediaStream -> ComponentType (Props ps) State Action
startStreaming stream = do
  state <- get
  sendMessage <- getSendMessage
  pure [ do
            liftEff $ addStream stream state.rtcConnection
            pure Nop
       ]

handleStartNegotiation :: forall ps. ComponentType (Props ps) State Action
handleStartNegotiation = do
  state <- get
  sendMessage <- getSendMessage
  pure [ do
            offer <- liftAff $ createOffer state.rtcConnection
            liftAff $ setLocalDescription offer state.rtcConnection
            sendMessage $ Message.SessionDescriptionOffer offer
            pure Nop
       ]

handleOnIceCandidate :: forall ps. IceEvent -> ComponentType (Props ps) State Action
handleOnIceCandidate event = do
  let candidate = iceEventCandidate event
  let mCandidate = maybe NoIceCandidate JustIceCandidate candidate
  sendMessage <- getSendMessage
  pure [ sendMessage $ Message.IceCandidate mCandidate ]

handleOnAddStream :: forall ps. MediaStreamEvent  -> ComponentType (Props ps) State Action
handleOnAddStream event = do
  pure [ do
            url <- liftEff <<< createObjectURL <<< mediaStreamToBlob $ event.stream
            pure $ SetRemoteStream $ { stream : event.stream, objectURL : url }
       ]

getSendMessage :: forall ps. Component (Props ps) State (Message -> IO Action)
getSendMessage = do
  let sendString = putSocketByFamilyIdByFromDeviceByToDeviceByChannelId
  props <- ask
  let familyId' = props.familyId
  let fromDevice' = props.ourId
  let toDevice' = props.theirId
  let channelId' = props.cSecret
  pure $ toIO props.settings <<< ( \msg ->  do
    let strMsg = encodeToString msg
    sendString strMsg familyId' fromDevice' toDevice' channelId'
    pure Nop)

handleAcceptMessage :: forall ps. MessageNumber -> Message -> ComponentType (Props ps) State Action
handleAcceptMessage msgNumber msg = do
    props <- ask
    actions <- handleMessage
    let deleteMessage = deleteSocketByFamilyIdByFromDeviceByToDeviceByChannelIdMessagesByMessageNumber
    deleteActions <- runGonimo $ do
      deleteMessage props.familyId props.theirId props.ourId props.cSecret msgNumber
      pure Nop
    pure $ deleteActions <> actions
  where
    handleMessage :: ComponentType (Props ps) State Action
    handleMessage = do
      state <- get
      sendMessage <- getSendMessage
      case msg of
        Message.StartStreaming -> fromMaybe (pure []) $ startStreaming <$> state.mediaStream
        Message.SessionDescriptionOffer description ->
          pure [ do
                  liftAff $ setRemoteDescription description state.rtcConnection
                  answer <- liftAff $ createAnswer state.rtcConnection
                  liftAff $ setLocalDescription answer state.rtcConnection
                  sendMessage $ Message.SessionDescriptionAnswer answer
              ]
        Message.SessionDescriptionAnswer description ->
          pure [ do
                  liftAff $ setRemoteDescription description state.rtcConnection
                  pure Nop
              ]
        Message.IceCandidate candidate ->
          pure [ do
                  let test = runMaybeIceCandidate candidate
                  case test of
                    Nothing -> pure unit -- let's see whether this helps
                    Just c -> liftAff $ addIceCandidate (runMaybeIceCandidate candidate) state.rtcConnection
                  pure Nop
              ]
        Message.CloseConnection -> closeConnection

closeConnection :: forall ps. ComponentType (Props ps) State Action
closeConnection = do
  state <- get
  let conn = state.rtcConnection
  pure $ fromMaybe [] $ do
    stream <- state.mediaStream
    pure [ liftEff $ do
              stopStream stream
              closeRTCPeerConnection conn
              pure Nop
         ]

handleCloseConnection :: forall ps. ComponentType (Props ps) State Action
handleCloseConnection = do
  sendMessage <- getSendMessage
  closeActions <- closeConnection
  pure $ closeActions <> [ sendMessage Message.CloseConnection ]

view :: forall ps. Props ps -> State -> Html Action
view props state =
  let
    mBabyDevice = Tuple.lookup props.theirId props.onlineDevices
    babyName = fromMaybe "unknown baby" $ mBabyDevice ^? _Just <<< _Baby
  in
    H.div [ A.className "panel panel-default" ]
            [ H.div [ A.className "panel-heading" ]
              [
                H.text babyName
              ]
            , viewVideo state
            ]

viewVideo :: State -> Html Action
viewVideo state =
   case state.remoteStream of
       Nothing -> H.text $ "Sorry - no video there yet, please check that your camera/microphone "
                  <> "are enabled on the baby station and your browser allows us to access it."
       Just stream ->
         H.video [ A.src stream.objectURL
                 , A.autoPlay "true"
                 , A.controls true
                 , A.width "100%"
                 ] []

getSubscriptions :: forall m ps. (MonadReader Settings m) => Props ps -> m (Subscriptions Action)
getSubscriptions props =
  let
    receiveMessage = getSocketByFamilyIdByFromDeviceByToDeviceByChannelId doDecode
    doDecode :: Maybe (Maybe (Tuple MessageNumber String)) -> Action
    doDecode (Just (Just (Tuple num msg))) = fromMaybe Nop
                                             $ AcceptMessage num <$> decodeFromString msg
    doDecode _                             = Nop
  in
    receiveMessage props.familyId props.theirId props.ourId props.cSecret


Readability improvements.

Readability improvements.

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/0dB/cats-utils.git/'


Don't show video stuff if camera is disabled

module Gonimo.UI.Socket.Views (view, viewParentChannelThumb) where

import Prelude
import Data.Array as Arr
import Data.Map as Map
import Gonimo.Client.Effects as Console
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Channel.Types as ChannelC
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream.Track as Track
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask, runReader)
import Control.Monad.Reader.Class (class MonadReader, ask)
import Control.Monad.State.Class (gets, modify, put, get, class MonadState)
import Data.Array (concat, fromFoldable)
import Data.Foldable (foldl)
import Data.Lens (use, to, (^?), (^.), _Just, (.=))
import Data.Map (Map)
import Data.Maybe (isNothing, isJust, maybe, fromMaybe, Maybe(Nothing, Just))
import Data.Monoid (mempty)
import Data.Profunctor (lmap)
import Data.Traversable (traverse_)
import Data.Tuple (uncurry, snd, Tuple(Tuple))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (wrapAction, noEffects, runGonimo, Component, liftChild, toParent, ComponentType, makeChildData, ToChild, onlyModify, Update, class MonadComponent)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.Db.Entities.Helpers (runFamily)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Internal (mkChannelProps, getParentChannels)
import Gonimo.UI.Socket.Lenses (video, _MediaStreamConstraints, constraints, streamURL, isAvailable, mediaStream, babyName, currentFamily, localStream, authData, newBabyName)
import Gonimo.UI.Socket.Message (decodeFromString)
import Gonimo.UI.Socket.Types (makeChannelId, toCSecret, toTheirId, ChannelId(ChannelId), channel, Props, State, Action(..))
import Gonimo.WebAPI.Lenses (deviceId, _AuthData)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Pux.Html (Html)
import Servant.Subscriber (Subscriptions)
import WebRTC.MediaStream (mediaStreamToBlob, createObjectURL, stopStream, MediaStreamConstraints(MediaStreamConstraints), getUserMedia, MediaStream, getTracks)
import WebRTC.RTC (RTCPeerConnection)

view :: forall ps. Props ps -> State -> Html Action
view props state =
    H.div [ A.className "container"
          , A.style [Tuple "width" "100%"]]
      [ H.h3 [] [ H.text "Baby Station Management"
                , H.br [] []
                , H.small []
                  [ H.text $ "Here you can promote a device to a baby station,"
                          <> " which means that this device can send video and"
                          <> " audio data, (if enabled) otherwise you need to"
                          <> " allow your browser to access the hardware."
                  ]
                ]
      , if haveVideo
          then viewPreviewVideo props state
          else H.div [] []
      , if state.isAvailable
          then viewOnline props state
          else viewOffline props state
      ]
  where
    haveVideo = fromMaybe true $ state^?constraints<<<_MediaStreamConstraints<<<video

viewOffline :: forall ps. Props ps -> State -> Html Action
viewOffline props state =
    H.div []
    [ H.div [ A.className "videoContainer" ]
      [ H.div [ A.className "checkbox" ]
        [ H.label []
          [ H.input [ A.type_ "checkbox", A.value ""
                    , A.defaultChecked haveVideo
                    , E.onInput (\e -> EnableCamera e.target.checked)
                    ]
            []
          , H.text "Enable Video"
          ]
        ]
      , viewStartButton state
      ]
    , viewBabyNameSelect props state
    ]
  where
    haveVideo = fromMaybe true $ state^?constraints<<<_MediaStreamConstraints<<<video

viewOnline :: forall ps. Props ps -> State -> Html Action
viewOnline props state =
  H.div []
    [ viewStopButton state
    ]

viewPreviewVideo :: forall ps. Props ps -> State -> Html Action
viewPreviewVideo props state =
  H.div [ A.className "videoContainer" ]
        [ if state.previewEnabled
          then H.div [ A.className "closableBox"]
              [ H.a [ A.className "boxclose"
                      , E.onClick $ const $ EnablePreview false
                    ] []
              , viewVideo props state
              ]
          else H.div [ A.className "btn-group" ]
              [ H.button [ A.className "btn btn-default btn-block"
                          , E.onClick $ const $ EnablePreview true
                          , A.type_ "button" ]
                [ H.text "Adjust camera" ]
              ]
        ]

viewVideo :: forall ps. Props ps -> State -> Html Action
viewVideo props state =
  H.div [ A.className "videoContainer" ]
  [ case state.streamURL of
        Nothing -> H.span [] []
        Just url -> H.video [ A.src url
                            , A.autoPlay "true"
                            , A.controls true
                            , A.muted true
                            , A.width "100%"
                            ] []
  ]

viewBabyNameSelect :: forall ps. Props ps -> State -> Html Action
viewBabyNameSelect props state =
  let
    lastBabies = concat
                 <<< fromFoldable -- Maybe Array -> Array Array
                 <<< map (_.familyLastUsedBabyNames <<< runFamily)
                 $ props.family

   in
     H.div [ A.role "group" ]
       [ H.h3 [] [ H.text "Select a name for your baby station"
                 , H.br [][]
                 , H.small [] [H.text "the last few names you used were:"]]
       , H.div [ A.className "videoContainer list-group", A.role "group" ]
         $ (viewBabyButton state <$> lastBabies) <>
         [ H.a [ A.className $ "list-group-item "
                                   <> if state.newBabyName == state.babyName
                                       then "active"
                                       else "list-group-item-action"
               , E.onClick $ const (SetBabyName state.newBabyName) ]
             [ H.div [] [H.text "Or select a new name for this baby station "]
             , H.input [ A.type_ "text", A.className "form-control", A.placeholder "New baby name"
                   , E.onInput $ \ev -> SetNewBabyName ev.target.value
                   , A.value state.newBabyName ] []
             ]
         ]
       ]

viewBabyButton :: State -> String -> Html Action
viewBabyButton state baby =
   H.a [ A.className $ "list-group-item " <> if baby == state.babyName
                                               then "active"
                                               else "list-group-item-action"
       , E.onClick $ const $ SetBabyName baby
       ] [ H.text baby ]

viewStopButton :: State -> Html Action
viewStopButton state =
  H.div []
  [ H.h3 [] [ H.text $ "Baby monitor running for cute " <> state.babyName <> " …"]
  , H.div [A.className "videoContainer"]
    [ H.button [ A.className "btn btn-block btn-danger"
              , A.style [ Tuple "margin-left" "0px" ]
              , A.type_ "button"
              , E.onClick $ const $ StopBabyStation
              ]
      [ H.text "Stop Baby Monitor "
      , H.span [A.className "glyphicon glyphicon-off"] []
      ]
    ]
  ]

viewStartButton :: State -> Html Action
viewStartButton state =
  H.div []
  [
    H.button [ A.className "btn btn-block btn-success"
             , A.style [ Tuple "margin-left" "0px" ]
             , A.disabled $ isNothing state.localStream
             , A.type_ "button"
             , E.onClick $ const $ StartBabyStation
             ]
    [ H.text $ "Start Baby Station for cute " <> state.babyName <> " "
    , H.span [A.className "glyphicon glyphicon-transfer"] []
    ]
  , H.div []
    $ if isNothing state.localStream
      then [ H.div [ A.className "alert alert-danger" ]
             [ H.p [] [ H.text "We need to enable your camera/microphone first." ]
             , H.button [ A.className "btn btn-block btn-default"
                        , A.style [ Tuple "margin-left" "0px" ]
                        , A.type_ "button"
                        , E.onClick $ const $ GetUserMedia
                        ]
               [ H.text "Enable camera/microphone!" ]
             ]
           ]
      else []
  ]

viewParentChannelThumb :: forall ps. Props ps -> State
                          -> Tuple ChannelId ChannelC.State -> Html Action
viewParentChannelThumb props state (Tuple chanId cState) =
  ChannelA chanId <$> ChannelC.view (mkChannelProps props state chanId) cState

viewParentChannels :: forall ps. Props ps -> State -> Array (Html Action)
viewParentChannels props state = let
    channels = getParentChannels state
  in
     viewParentChannelThumb props state <$> channels

module Gonimo.UI.Socket.Views (view, viewParentChannelThumb) where

import Prelude
import Data.Array as Arr
import Data.Map as Map
import Gonimo.Client.Effects as Console
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Channel.Types as ChannelC
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream.Track as Track
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask, runReader)
import Control.Monad.Reader.Class (class MonadReader, ask)
import Control.Monad.State.Class (gets, modify, put, get, class MonadState)
import Data.Array (concat, fromFoldable)
import Data.Foldable (foldl)
import Data.Lens (use, to, (^?), (^.), _Just, (.=))
import Data.Map (Map)
import Data.Maybe (isNothing, isJust, maybe, fromMaybe, Maybe(Nothing, Just))
import Data.Monoid (mempty)
import Data.Profunctor (lmap)
import Data.Traversable (traverse_)
import Data.Tuple (uncurry, snd, Tuple(Tuple))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (wrapAction, noEffects, runGonimo, Component, liftChild, toParent, ComponentType, makeChildData, ToChild, onlyModify, Update, class MonadComponent)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.Db.Entities.Helpers (runFamily)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Internal (mkChannelProps, getParentChannels)
import Gonimo.UI.Socket.Lenses (video, _MediaStreamConstraints, constraints, streamURL, isAvailable, mediaStream, babyName, currentFamily, localStream, authData, newBabyName)
import Gonimo.UI.Socket.Message (decodeFromString)
import Gonimo.UI.Socket.Types (makeChannelId, toCSecret, toTheirId, ChannelId(ChannelId), channel, Props, State, Action(..))
import Gonimo.WebAPI.Lenses (deviceId, _AuthData)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Pux.Html (Html)
import Servant.Subscriber (Subscriptions)
import WebRTC.MediaStream (mediaStreamToBlob, createObjectURL, stopStream, MediaStreamConstraints(MediaStreamConstraints), getUserMedia, MediaStream, getTracks)
import WebRTC.RTC (RTCPeerConnection)

view :: forall ps. Props ps -> State -> Html Action
view props state =
    H.div [ A.className "container"
          , A.style [Tuple "width" "100%"]]
      [ H.h3 [] [ H.text "Baby Station Management"
                , H.br [] []
                , H.small []
                  [ H.text $ "Here you can promote a device to a baby station,"
                          <> " which means that this device can send video and"
                          <> " audio data, (if enabled) otherwise you need to"
                          <> " allow your browser to access the hardware."
                  ]
                ]
      , if state.isAvailable
         then viewOnline props state
         else viewOffline props state
      ]

viewOffline :: forall ps. Props ps -> State -> Html Action
viewOffline props state =
    H.div []
    [ viewPreviewVideo props state
    , H.div [ A.className "videoContainer" ]
      [ H.div [ A.className "checkbox" ]
        [ H.label []
          [ H.input [ A.type_ "checkbox", A.value ""
                    , A.defaultChecked (fromMaybe true $ state^?constraints<<<_MediaStreamConstraints<<<video)
                    , E.onInput (\e -> EnableCamera e.target.checked)
                    ]
            []
          , H.text "Enable Video"
          ]
        ]
      , viewStartButton state
      ]
    , viewBabyNameSelect props state
    ]

viewOnline :: forall ps. Props ps -> State -> Html Action
viewOnline props state =
  H.div []
    [ viewPreviewVideo props state
    , viewStopButton state
    ]

viewPreviewVideo :: forall ps. Props ps -> State -> Html Action
viewPreviewVideo props state =
  H.div [ A.className "videoContainer" ]
        [ if state.previewEnabled
          then H.div [ A.className "closableBox"]
              [ H.a [ A.className "boxclose"
                      , E.onClick $ const $ EnablePreview false
                    ] []
              , viewVideo props state
              ]
          else H.div [ A.className "btn-group" ]
              [ H.button [ A.className "btn btn-default btn-block"
                          , E.onClick $ const $ EnablePreview true
                          , A.type_ "button" ]
                [ H.text "Adjust camera" ]
              ]
        ]

viewVideo :: forall ps. Props ps -> State -> Html Action
viewVideo props state =
  H.div [ A.className "videoContainer" ]
  [ case state.streamURL of
        Nothing -> H.span [] []
        Just url -> H.video [ A.src url
                            , A.autoPlay "true"
                            , A.controls true
                            , A.muted true
                            , A.width "100%"
                            ] []
  ]

viewBabyNameSelect :: forall ps. Props ps -> State -> Html Action
viewBabyNameSelect props state =
  let
    lastBabies = concat
                 <<< fromFoldable -- Maybe Array -> Array Array
                 <<< map (_.familyLastUsedBabyNames <<< runFamily)
                 $ props.family

   in
     H.div [ A.role "group" ]
       [ H.h3 [] [ H.text "Select a name for your baby station"
                 , H.br [][]
                 , H.small [] [H.text "the last few names you used were:"]]
       , H.div [ A.className "videoContainer list-group", A.role "group" ]
         $ (viewBabyButton state <$> lastBabies) <>
         [ H.a [ A.className $ "list-group-item "
                                   <> if state.newBabyName == state.babyName
                                       then "active"
                                       else "list-group-item-action"
               , E.onClick $ const (SetBabyName state.newBabyName) ]
             [ H.div [] [H.text "Or select a new name for this baby station "]
             , H.input [ A.type_ "text", A.className "form-control", A.placeholder "New baby name"
                   , E.onInput $ \ev -> SetNewBabyName ev.target.value
                   , A.value state.newBabyName ] []
             ]
         ]
       ]

viewBabyButton :: State -> String -> Html Action
viewBabyButton state baby =
   H.a [ A.className $ "list-group-item " <> if baby == state.babyName
                                               then "active"
                                               else "list-group-item-action"
       , E.onClick $ const $ SetBabyName baby
       ] [ H.text baby ]

viewStopButton :: State -> Html Action
viewStopButton state =
  H.div []
  [ H.h3 [] [ H.text $ "Baby monitor running for cute " <> state.babyName <> " …"]
  , H.div [A.className "videoContainer"]
    [ H.button [ A.className "btn btn-block btn-danger"
              , A.style [ Tuple "margin-left" "0px" ]
              , A.type_ "button"
              , E.onClick $ const $ StopBabyStation
              ]
      [ H.text "Stop Baby Monitor "
      , H.span [A.className "glyphicon glyphicon-off"] []
      ]
    ]
  ]

viewStartButton :: State -> Html Action
viewStartButton state =
  H.div []
  [
    H.button [ A.className "btn btn-block btn-success"
             , A.style [ Tuple "margin-left" "0px" ]
             , A.disabled $ isNothing state.localStream
             , A.type_ "button"
             , E.onClick $ const $ StartBabyStation
             ]
    [ H.text $ "Start Baby Station for cute " <> state.babyName <> " "
    , H.span [A.className "glyphicon glyphicon-transfer"] []
    ]
  , H.div []
    $ if isNothing state.localStream
      then [ H.div [ A.className "alert alert-danger" ]
             [ H.p [] [ H.text "We need to enable your camera/microphone first." ]
             , H.button [ A.className "btn btn-block btn-default"
                        , A.style [ Tuple "margin-left" "0px" ]
                        , A.type_ "button"
                        , E.onClick $ const $ GetUserMedia
                        ]
               [ H.text "Enable camera/microphone!" ]
             ]
           ]
      else []
  ]

viewParentChannelThumb :: forall ps. Props ps -> State
                          -> Tuple ChannelId ChannelC.State -> Html Action
viewParentChannelThumb props state (Tuple chanId cState) =
  ChannelA chanId <$> ChannelC.view (mkChannelProps props state chanId) cState

viewParentChannels :: forall ps. Props ps -> State -> Array (Html Action)
viewParentChannels props state = let
    channels = getParentChannels state
  in
     viewParentChannelThumb props state <$> channels


First version of helper function divideAllEfforts().


Read a location (reference) once with a default value

next: read a snapshot with a default value (move some code around), so
we can read on Value (as we need in app).

module Test.ReadSpec where

import Prelude (Unit, bind, ($))

import Control.Apply ((*>))
import Control.Monad.Aff (attempt)
import Control.Monad.Eff.Exception (EXCEPTION(), message)
import Control.Alt ((<|>))
import Data.Either (either)
import Data.Foreign (toForeign)
import Web.Firebase.Types as FBT
import Web.Firebase (EventType(ChildMoved, ChildChanged, ChildRemoved, ChildAdded))
import Test.Spec                  (describe, it, Spec())
import Test.Spec.Assertions       (shouldEqual)
import Test.Spec.Assertions.Aff (expectError)
import Web.Firebase.Monad.Aff (child, readOnceWithDefault)

-- | Reading from references and snapshots, sometimes with defaults
-- reading, as in also converting from foreign with some form of `read`
readSpec :: forall eff. FBT.Firebase -> Spec (firebase :: FBT.FirebaseEff, err :: EXCEPTION | eff ) Unit
readSpec entries = do
    describe "Reading records and newtypes" do
        describe "with a default value" do
          it "returns default value on non-existant, but allowed location" do
            nodataLocation <- child "/nodata" entries
            nodata <- readOnceWithDefault "no data" nodataLocation
            nodata `shouldEqual` "no data"

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