Update tests

Update tests

module Test.Main where

import Prelude hiding (degree)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      allParseAs (Expression (q 10.0 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"
        ]

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

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

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

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

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

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

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

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

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

      shouldFail "5*"

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

      shouldFail "5/"

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

      shouldFail "3 + "
      shouldFail "3 + @"

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

      shouldFail "3 - "

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

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

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

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

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

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

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

      allParseAs (Expression (BinOp Div (q 3.0 meter) (Unit second))) $
        [ "3m/s"
        , "3 meter / 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 "
        ]

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

      shouldFail "2.3m->"

    test "Complex units" do
      allParseAs (Expression (BinOp ConvertTo (BinOp Mul (Scalar 36.0) (BinOp Div (Unit (kilo meter)) (Unit hour))) (Unit (mile ./ hour))))
        [ "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''"

      shouldFail "xs,as"
      shouldFail "hello$"

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

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

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

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

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

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

  let expectOutput' = expectOutput initialEnvironment

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

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

    test "Simple" do
      expectOutput' "1080.0" "1920/16*9"
      expectOutput' "4294967296.0" "2^32"
      expectOutput' "0.51295711321708" "sqrt(1.4^2 + 1.5^2) * cos(pi/3)^2"

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

      expectOutput' "26.8224m/s" "60mph -> m/s"
      expectOutput' "10.0km/h" "240km/day -> km/h"
      expectOutput' "0.057295779513082325°" "1mrad -> °"
      expectOutput' "364.0d" "52weeks -> days"
      expectOutput' "73.66cm" "5in + 2ft -> cm"
      expectOutput' "8.530765609948133°" "atan(30cm / 2m) -> °"

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

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

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

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

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

module Test.Main where

import Prelude hiding (degree)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      allParseAs (Expression (q 10.0 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"
        ]

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

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

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

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

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

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

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

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

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

      shouldFail "5*"

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

      shouldFail "5/"

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

      shouldFail "3 + "
      shouldFail "3 + @"

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

      shouldFail "3 - "

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

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

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

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

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

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

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

      allParseAs (Expression (BinOp Div (q 3.0 meter) (Unit second))) $
        [ "3m/s"
        , "3 meter / 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 "
        ]

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

      shouldFail "2.3m->"

    test "Complex units" do
      allParseAs (Expression (BinOp ConvertTo (BinOp Mul (Scalar 36.0) (BinOp Div (Unit (kilo meter)) (Unit hour))) (Unit (mile ./ hour))))
        [ "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''"

      shouldFail "xs,as"
      shouldFail "hello$"

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

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

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

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

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

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

  let expectOutput' = expectOutput initialEnvironment

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

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

    test "Simple" do
      expectOutput' "1080.0" "1920/16*9"
      expectOutput' "4294967296.0" "2^32"
      expectOutput' "36.316811075498" "pi(1.4+2)²"

      expectOutput' "2.5min" "2min + 30s"
      expectOutput' "150.0s" "2min + 30s -> sec"
      expectOutput' "904778684233.8604km³" "4/3 * pi (6000km)³"
      expectOutput' "58800.0kg·m·cm/s²" "40kg * 9.8m/s² * 150cm"

      expectOutput' "26.8224m/s" "60mph -> m/s"
      expectOutput' "10.0km/h" "240km/day -> km/h"
      expectOutput' "0.057295779513082325°" "1mrad -> °"
      expectOutput' "364.0d" "52weeks -> days"
      expectOutput' "73.66cm" "5in + 2ft -> cm"

      expectOutput' "0.7071067811865476" "cos(pi/4)"
      expectOutput' "0.49999999999999994" "sin(30°)"
      expectOutput' "8.530765609948133°" "atan(30cm / 2m) -> °"

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

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

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

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

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


Add type to notebook app

Add type to notebook app

module Entries.Notebook where

import App.Notebook (app)
import Control.Monad.Eff (Eff())
import Data.Tuple (Tuple(..))
import EffectTypes (NotebookAppEff())
import Halogen (runUI)
import Utils (onLoad, mountUI)
import qualified Driver.Notebook as D

main :: Eff (NotebookAppEff ()) Unit
main = onLoad $ void $ do
  Tuple node driver <- runUI app
  mountUI node
  D.driver driver

module Entries.Notebook where

import App.Notebook (app)
import Data.Tuple (Tuple(..))
import Halogen (runUI)
import Utils (onLoad, mountUI)
import qualified Driver.Notebook as D

main = onLoad $ void $ do
  Tuple node driver <- runUI app
  mountUI node
  D.driver driver


Send current module with queries

Send current module with queries

module IdePurescript.VSCode.Main where

import Prelude
import PscIde as P
import VSCode.Notifications as Notify
import Control.Monad.Aff (Aff, runAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Ref (REF, Ref, readRef, newRef, writeRef)
import Control.Promise (Promise, fromAff)
import Data.Array (uncons, head, length)
import Data.Either (Either, either)
import Data.Foldable (traverse_)
import Data.Function.Eff (EffFn4, EffFn3, EffFn2, EffFn1, runEffFn4, mkEffFn3, mkEffFn2, mkEffFn1)
import Data.Functor ((<$))
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.Nullable (toNullable, Nullable)
import Data.String (trim, null)
import Data.String.Regex (Regex, noFlags, regex, split)
import IdePurescript.Build (Command(Command), build, rebuild)
import IdePurescript.Modules (State, initialModulesState, getQualModule, getUnqualActiveModules, getModulesForFile, getMainModule)
import IdePurescript.PscErrors (PscError(PscError))
import IdePurescript.PscIde (getType, getTypeInfo, getCompletion, loadDeps)
import IdePurescript.PscIdeServer (ServerStartResult(..), startServer, stopServer)
import IdePurescript.Regex (match')
import IdePurescript.VSCode.Assist (addClause, caseSplit)
import IdePurescript.VSCode.Imports (addModuleImportCmd, addIdentImportCmd)
import IdePurescript.VSCode.Types (MainEff)
import Node.Process (lookupEnv)
import PscIde (NET)
import PscIde.Command as Command
import PscIde.Server (findBins, Executable(Executable))
import VSCode.Command (register)
import VSCode.Diagnostic (Diagnostic, mkDiagnostic)
import VSCode.Position (mkPosition, Position)
import VSCode.Range (mkRange, Range)
import VSCode.Location (Location, mkLocation)
import VSCode.Window (setStatusBarMessage, WINDOW)

ignoreError :: forall a eff. a -> Eff eff Unit
ignoreError _ = pure unit

useEditor :: forall eff. Int -> (Ref State) -> String -> String -> Eff (net :: NET, ref :: REF | eff) Unit
useEditor port modulesStateRef path text = do
  let mainModule = getMainModule text
  case mainModule of
    Just m -> void $ runAff ignoreError ignoreError $ do
      loadDeps port m
      state <- getModulesForFile port path text
      liftEff $ writeRef modulesStateRef state
      pure unit
    Nothing -> pure unit

type GetText eff = Int -> Int -> Int -> Int -> Eff eff String -- TODO eff

moduleRegex :: Either String Regex
moduleRegex = regex """(?:^|[^A-Za-z_.])(?:((?:[A-Z][A-Za-z0-9]*\.)*(?:[A-Z][A-Za-z0-9]*))\.)?([a-zA-Z][a-zA-Z0-9_']*)?$""" noFlags

type Completion =
  { type:: String
  , identifier :: String
  , "module" :: String
  }

getCompletions :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Array Completion))
getCompletions port state line char getTextInRange = do
  line <- getTextInRange line 0 line char
  let getQualifiedModule = (flip getQualModule) state
  let parsed = case match' moduleRegex line of
        Just [ Just _, mod, tok ] | mod /= Nothing || tok /= Nothing ->
          Just { mod: fromMaybe "" mod , token: fromMaybe "" tok}
        _ -> Nothing
  let moduleCompletion = false
  case parsed of
    Just { mod, token } -> fromAff $ do
      -- TODO currentModule
      getCompletion port token state.main mod moduleCompletion (getUnqualActiveModules state $ Just token) getQualifiedModule
    _ -> fromAff $ pure []

convPosition :: Command.Position -> Position
convPosition { line, column } = mkPosition (line-1) (column-1)

getDefinition :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Nullable Location))
getDefinition port state line char getTextInRange = do
  let beforeRegex = regex "[a-zA-Z_0-9']*$" noFlags
      afterRegex = regex "^[a-zA-Z_0-9']*" noFlags
  textBefore <- getTextInRange line 0    line char
  textAfter  <- getTextInRange line char line (char + 100)
  let word = case { before: match' beforeRegex textBefore, after: match' afterRegex textAfter } of
              { before: Just [Just s], after: Just [Just s'] } -> s<>s'
              _ -> ""
  let prefix = ""
  fromAff $ do
    info <- getTypeInfo port word Nothing prefix (getUnqualActiveModules state $ Just word) (flip getQualModule $ state)
    pure $ toNullable $ case info of
      Just { position: Just (Command.TypePosition { name, start }) } -> Just $ mkLocation name $ convPosition start
      _ -> Nothing

type MarkedString = { language :: String, value :: String }

markedString :: String -> MarkedString
markedString s = { language: "purescript", value: s }

getTooltips :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Nullable MarkedString))
getTooltips port state line char getTextInRange = do
    let beforeRegex = regex "[a-zA-Z_0-9']*$" noFlags
        afterRegex = regex "^[a-zA-Z_0-9']*" noFlags
    textBefore <- getTextInRange line 0    line char
    textAfter  <- getTextInRange line char line (char + 100)
    let word = case { before: match' beforeRegex textBefore, after: match' afterRegex textAfter } of
                { before: Just [Just s], after: Just [Just s'] } -> s<>s'
                _ -> ""
    let prefix = ""
    fromAff do
      -- TODO current module for opened idents
      ty <- getType port word state.main prefix (getUnqualActiveModules state $ Just word) (flip getQualModule $ state)
      let marked = if null ty then Nothing else Just $ markedString $ word <> " :: " <> ty
      pure $ toNullable marked

data ErrorLevel = Success | Info | Warning | Error
type Notify eff = ErrorLevel -> String -> Eff (MainEff eff) Unit

startServer' :: forall eff. String -> Int -> String -> Notify eff -> Aff (MainEff eff) (Maybe { port:: Int, quit:: Eff (MainEff eff) Unit })
startServer' server port root cb = do
  serverBins <- findBins server
  case head serverBins of
    Nothing -> do
      processPath <- liftEffS $ lookupEnv "PATH"
      liftEffS $ cb Info $ "Couldn't find psc-ide-server, check PATH. Looked for: "
        <> server <> " in PATH: " <> fromMaybe "" processPath
      pure Nothing
    Just (Executable bin _) -> do
      -- TODO: Configure globs
      -- TODO: add port config override
      res <- startServer bin root ["src/**/*.purs", "bower_components/purescript-*/src/**/*.purs"]
      liftEff $ log $ "Resolved psc-ide-server:"
      traverse_ (\(Executable x vv) -> do
        liftEff $ log $ x <> ": " <> fromMaybe "ERROR" vv) serverBins
      liftEff $ when (length serverBins > 1) $ cb Warning $ "Found multiple psc-ide-server executables; using " <> bin

      liftEff $ case res of
        CorrectPath port -> Just { port, quit: pure unit } <$ cb Info ("Found existing psc-ide-server with correct path on port " <> show port)
        WrongPath port wrongPath -> Nothing <$ (cb Error $ "Found existing psc-ide-server on port " <> show port <> " with wrong path: '" <>wrongPath<>"'. Correct, kill or configure a different port, and restart.")
        Started port cp -> do
          cb Success ("Started psc-ide-server on " <> show port)
          pure $ Just { port, quit: void $ runAff (\_ -> pure unit) (\_ -> pure unit) $ stopServer port root cp }
        Closed -> Nothing <$ cb Info "psc-ide-server exited with success code"
        StartError err -> Nothing <$ (cb Error $ "Could not start psc-ide-server process. Check the configured port number is valid.\n" <>err)

  where
    liftEffS :: forall a. Eff (MainEff eff) a -> Aff (MainEff eff) a
    liftEffS = liftEff

toDiagnostic :: Boolean -> PscError -> FileDiagnostic
toDiagnostic isError (PscError { message, filename, position, suggestion }) =
  { filename: fromMaybe "" filename
  , diagnostic: mkDiagnostic (range position) message (if isError then 0 else 1)
  , quickfix: conv suggestion
  }
  where
  range (Just { startLine, startColumn, endLine, endColumn}) =
    mkRange
      (mkPosition (startLine-1) (startColumn-1))
      (mkPosition (endLine-1) (endColumn-1))
  range _ = mkRange (mkPosition 0 0) (mkPosition 0 0)

  conv (Just { replacement, replaceRange }) = { suggest: true, replacement, range: range replaceRange }
  conv _ = { suggest: false, replacement: "", range: range Nothing }

type FileDiagnostic =
  { filename :: String
  , diagnostic :: Diagnostic
  , quickfix :: { suggest :: Boolean, replacement :: String, range :: Range }
  }
type VSBuildResult =
  { success:: Boolean
  , diagnostics :: Array FileDiagnostic
  }

data Status = Building | BuildFailure | BuildErrors | BuildSuccess

showStatus :: forall eff. Status -> Eff (window :: WINDOW | eff) Unit
showStatus status = do
  let icon = case status of
              Building -> "$(beaker)"
              BuildFailure -> "$(bug)"
              BuildErrors -> "$(check)"
              BuildSuccess -> "$(check)"
  setStatusBarMessage $ icon <> " PureScript"

quickBuild :: forall eff. Int -> String -> Eff (MainEff eff) (Promise VSBuildResult)
quickBuild port filename = fromAff $ do
  liftEff $ showStatus Building
  { errors, success } <- rebuild port filename
  liftEff $ showStatus BuildSuccess
  pure $ { success, diagnostics: toDiagnostic' errors }

toDiagnostic' :: { warnings :: Array PscError, errors :: Array PscError } -> Array FileDiagnostic
toDiagnostic' { warnings, errors } = map (toDiagnostic true) errors <> map (toDiagnostic false) warnings

build' :: forall eff. Notify eff -> String -> String -> Eff (MainEff eff) (Promise VSBuildResult)
build' notify command directory = fromAff $ do
  liftEff $ log "Building"
  let buildCommand = either (const []) (\reg -> (split reg <<< trim) command) (regex "\\s+" noFlags)
  case uncons buildCommand of
    Just { head: cmd, tail: args } -> do
      liftEff $ log "Parsed build command"
      liftEff $ showStatus Building
      res <- build { command: Command cmd args, directory }
      liftEff $ if res.success then showStatus BuildSuccess
                else showStatus BuildErrors
      pure $ { success: true, diagnostics: toDiagnostic' res.errors }
    Nothing -> do
      liftEff $ notify Error "Error parsing PureScript build command"
      liftEff $ showStatus BuildFailure
      pure { success: false, diagnostics: [] }

main :: forall eff. Eff (MainEff eff)
  { activate :: EffFn3 (MainEff eff) String Int String (Promise Unit)
  , deactivate :: Eff (MainEff eff) Unit
  , build :: EffFn2 (MainEff eff) String String (Promise VSBuildResult)
  , quickBuild :: EffFn1 (MainEff eff) String (Promise VSBuildResult)
  , updateFile :: EffFn2 (MainEff eff) String String Unit
  , getTooltips :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Nullable MarkedString))
  , getCompletions :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Array Completion))
  , provideDefinition :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Nullable Location))
  }
main = do
  modulesState <- newRef (initialModulesState)
  deactivateRef <- newRef (pure unit :: Eff (MainEff eff) Unit)
  portRef <- newRef 0

  let cmd s f = register ("purescript." <> s) f

  let deactivate :: Eff (MainEff eff) Unit
      deactivate = join (readRef deactivateRef)

  let showError :: Notify eff
      showError level str = case level of
                             Success -> Notify.showInfo str
                             Info -> Notify.showInfo str
                             Warning -> Notify.showWarning str
                             Error -> Notify.showError str

  let liftEffMM :: forall a. Eff (MainEff eff) a -> Aff (MainEff eff) a
      liftEffMM = liftEff
  let initialise server _port root = fromAff do
        -- TODO pass in port just when explicitly defined
        startRes <- startServer' server _port root showError
        case startRes of
          Just { port, quit } -> do
            P.load port [] []
            liftEffMM $ do
              cmd "addImport" $ readRef portRef >>= addModuleImportCmd modulesState
              cmd "addExplicitImport" $ readRef portRef >>= addIdentImportCmd modulesState
              cmd "caseSplit" $ readRef portRef >>= caseSplit
              cmd "addClause" $ readRef portRef >>= addClause
              writeRef deactivateRef quit
              writeRef portRef port
          Nothing -> pure unit

  pure
    {
      activate: mkEffFn3 initialise
    , deactivate: deactivate
    , build: mkEffFn2 $ build' showError
    , quickBuild: mkEffFn1 \fname -> do
        port <- readRef portRef
        quickBuild port fname
    , updateFile: mkEffFn2 $ \fname text -> do
        port <- readRef portRef
        useEditor port modulesState fname text
    , getTooltips: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getTooltips port state line char (runEffFn4 getText)
    , getCompletions: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getCompletions port state line char (runEffFn4 getText)
    , provideDefinition: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getDefinition port state line char (runEffFn4 getText)
    }

module IdePurescript.VSCode.Main where

import Prelude
import PscIde as P
import VSCode.Notifications as Notify
import Control.Monad.Aff (Aff, runAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Ref (REF, Ref, readRef, newRef, writeRef)
import Control.Promise (Promise, fromAff)
import Data.Array (uncons, head, length)
import Data.Either (Either, either)
import Data.Foldable (traverse_)
import Data.Function.Eff (EffFn4, EffFn3, EffFn2, EffFn1, runEffFn4, mkEffFn3, mkEffFn2, mkEffFn1)
import Data.Functor ((<$))
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.Nullable (toNullable, Nullable)
import Data.String (trim, null)
import Data.String.Regex (Regex, noFlags, regex, split)
import IdePurescript.Build (Command(Command), build, rebuild)
import IdePurescript.Modules (State, initialModulesState, getQualModule, getUnqualActiveModules, getModulesForFile, getMainModule)
import IdePurescript.PscErrors (PscError(PscError))
import IdePurescript.PscIde (getType, getTypeInfo, getCompletion, loadDeps)
import IdePurescript.PscIdeServer (ServerStartResult(..), startServer, stopServer)
import IdePurescript.Regex (match')
import IdePurescript.VSCode.Assist (addClause, caseSplit)
import IdePurescript.VSCode.Imports (addModuleImportCmd, addIdentImportCmd)
import IdePurescript.VSCode.Types (MainEff)
import Node.Process (lookupEnv)
import PscIde (NET)
import PscIde.Command as Command
import PscIde.Server (findBins, Executable(Executable))
import VSCode.Command (register)
import VSCode.Diagnostic (Diagnostic, mkDiagnostic)
import VSCode.Position (mkPosition, Position)
import VSCode.Range (mkRange, Range)
import VSCode.Location (Location, mkLocation)
import VSCode.Window (setStatusBarMessage, WINDOW)

ignoreError :: forall a eff. a -> Eff eff Unit
ignoreError _ = pure unit

useEditor :: forall eff. Int -> (Ref State) -> String -> String -> Eff (net :: NET, ref :: REF | eff) Unit
useEditor port modulesStateRef path text = do
  let mainModule = getMainModule text
  case mainModule of
    Just m -> void $ runAff ignoreError ignoreError $ do
      loadDeps port m
      state <- getModulesForFile port path text
      liftEff $ writeRef modulesStateRef state
      pure unit
    Nothing -> pure unit

type GetText eff = Int -> Int -> Int -> Int -> Eff eff String -- TODO eff

moduleRegex :: Either String Regex
moduleRegex = regex """(?:^|[^A-Za-z_.])(?:((?:[A-Z][A-Za-z0-9]*\.)*(?:[A-Z][A-Za-z0-9]*))\.)?([a-zA-Z][a-zA-Z0-9_']*)?$""" noFlags

type Completion =
  { type:: String
  , identifier :: String
  , "module" :: String
  }

getCompletions :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Array Completion))
getCompletions port state line char getTextInRange = do
  line <- getTextInRange line 0 line char
  let getQualifiedModule = (flip getQualModule) state
  let parsed = case match' moduleRegex line of
        Just [ Just _, mod, tok ] | mod /= Nothing || tok /= Nothing ->
          Just { mod: fromMaybe "" mod , token: fromMaybe "" tok}
        _ -> Nothing
  let moduleCompletion = false
  case parsed of
    Just { mod, token } -> fromAff $ do
      -- TODO currentModule
      getCompletion port token Nothing mod moduleCompletion (getUnqualActiveModules state $ Just token) getQualifiedModule
    _ -> fromAff $ pure []

convPosition :: Command.Position -> Position
convPosition { line, column } = mkPosition (line-1) (column-1)

getDefinition :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Nullable Location))
getDefinition port state line char getTextInRange = do
  let beforeRegex = regex "[a-zA-Z_0-9']*$" noFlags
      afterRegex = regex "^[a-zA-Z_0-9']*" noFlags
  textBefore <- getTextInRange line 0    line char
  textAfter  <- getTextInRange line char line (char + 100)
  let word = case { before: match' beforeRegex textBefore, after: match' afterRegex textAfter } of
              { before: Just [Just s], after: Just [Just s'] } -> s<>s'
              _ -> ""
  let prefix = ""
  fromAff $ do
    info <- getTypeInfo port word Nothing prefix (getUnqualActiveModules state $ Just word) (flip getQualModule $ state)
    pure $ toNullable $ case info of
      Just { position: Just (Command.TypePosition { name, start }) } -> Just $ mkLocation name $ convPosition start
      _ -> Nothing

type MarkedString = { language :: String, value :: String }

markedString :: String -> MarkedString
markedString s = { language: "purescript", value: s }

getTooltips :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Nullable MarkedString))
getTooltips port state line char getTextInRange = do
    let beforeRegex = regex "[a-zA-Z_0-9']*$" noFlags
        afterRegex = regex "^[a-zA-Z_0-9']*" noFlags
    textBefore <- getTextInRange line 0    line char
    textAfter  <- getTextInRange line char line (char + 100)
    let word = case { before: match' beforeRegex textBefore, after: match' afterRegex textAfter } of
                { before: Just [Just s], after: Just [Just s'] } -> s<>s'
                _ -> ""
    let prefix = ""
    fromAff do
      -- TODO current module for opened idents
      ty <- getType port word Nothing prefix (getUnqualActiveModules state $ Just word) (flip getQualModule $ state)
      let marked = if null ty then Nothing else Just $ markedString $ word <> " :: " <> ty
      pure $ toNullable marked

data ErrorLevel = Success | Info | Warning | Error
type Notify eff = ErrorLevel -> String -> Eff (MainEff eff) Unit

startServer' :: forall eff. String -> Int -> String -> Notify eff -> Aff (MainEff eff) (Maybe { port:: Int, quit:: Eff (MainEff eff) Unit })
startServer' server port root cb = do
  serverBins <- findBins server
  case head serverBins of
    Nothing -> do
      processPath <- liftEffS $ lookupEnv "PATH"
      liftEffS $ cb Info $ "Couldn't find psc-ide-server, check PATH. Looked for: "
        <> server <> " in PATH: " <> fromMaybe "" processPath
      pure Nothing
    Just (Executable bin _) -> do
      -- TODO: Configure globs
      -- TODO: add port config override
      res <- startServer bin root ["src/**/*.purs", "bower_components/purescript-*/src/**/*.purs"]
      liftEff $ log $ "Resolved psc-ide-server:"
      traverse_ (\(Executable x vv) -> do
        liftEff $ log $ x <> ": " <> fromMaybe "ERROR" vv) serverBins
      liftEff $ when (length serverBins > 1) $ cb Warning $ "Found multiple psc-ide-server executables; using " <> bin

      liftEff $ case res of
        CorrectPath port -> Just { port, quit: pure unit } <$ cb Info ("Found existing psc-ide-server with correct path on port " <> show port)
        WrongPath port wrongPath -> Nothing <$ (cb Error $ "Found existing psc-ide-server on port " <> show port <> " with wrong path: '" <>wrongPath<>"'. Correct, kill or configure a different port, and restart.")
        Started port cp -> do
          cb Success ("Started psc-ide-server on " <> show port)
          pure $ Just { port, quit: void $ runAff (\_ -> pure unit) (\_ -> pure unit) $ stopServer port root cp }
        Closed -> Nothing <$ cb Info "psc-ide-server exited with success code"
        StartError err -> Nothing <$ (cb Error $ "Could not start psc-ide-server process. Check the configured port number is valid.\n" <>err)

  where
    liftEffS :: forall a. Eff (MainEff eff) a -> Aff (MainEff eff) a
    liftEffS = liftEff

toDiagnostic :: Boolean -> PscError -> FileDiagnostic
toDiagnostic isError (PscError { message, filename, position, suggestion }) =
  { filename: fromMaybe "" filename
  , diagnostic: mkDiagnostic (range position) message (if isError then 0 else 1)
  , quickfix: conv suggestion
  }
  where
  range (Just { startLine, startColumn, endLine, endColumn}) =
    mkRange
      (mkPosition (startLine-1) (startColumn-1))
      (mkPosition (endLine-1) (endColumn-1))
  range _ = mkRange (mkPosition 0 0) (mkPosition 0 0)

  conv (Just { replacement, replaceRange }) = { suggest: true, replacement, range: range replaceRange }
  conv _ = { suggest: false, replacement: "", range: range Nothing }

type FileDiagnostic =
  { filename :: String
  , diagnostic :: Diagnostic
  , quickfix :: { suggest :: Boolean, replacement :: String, range :: Range }
  }
type VSBuildResult =
  { success:: Boolean
  , diagnostics :: Array FileDiagnostic
  }

data Status = Building | BuildFailure | BuildErrors | BuildSuccess

showStatus :: forall eff. Status -> Eff (window :: WINDOW | eff) Unit
showStatus status = do
  let icon = case status of
              Building -> "$(beaker)"
              BuildFailure -> "$(bug)"
              BuildErrors -> "$(check)"
              BuildSuccess -> "$(check)"
  setStatusBarMessage $ icon <> " PureScript"

quickBuild :: forall eff. Int -> String -> Eff (MainEff eff) (Promise VSBuildResult)
quickBuild port filename = fromAff $ do
  liftEff $ showStatus Building
  { errors, success } <- rebuild port filename
  liftEff $ showStatus BuildSuccess
  pure $ { success, diagnostics: toDiagnostic' errors }

toDiagnostic' :: { warnings :: Array PscError, errors :: Array PscError } -> Array FileDiagnostic
toDiagnostic' { warnings, errors } = map (toDiagnostic true) errors <> map (toDiagnostic false) warnings

build' :: forall eff. Notify eff -> String -> String -> Eff (MainEff eff) (Promise VSBuildResult)
build' notify command directory = fromAff $ do
  liftEff $ log "Building"
  let buildCommand = either (const []) (\reg -> (split reg <<< trim) command) (regex "\\s+" noFlags)
  case uncons buildCommand of
    Just { head: cmd, tail: args } -> do
      liftEff $ log "Parsed build command"
      liftEff $ showStatus Building
      res <- build { command: Command cmd args, directory }
      liftEff $ if res.success then showStatus BuildSuccess
                else showStatus BuildErrors
      pure $ { success: true, diagnostics: toDiagnostic' res.errors }
    Nothing -> do
      liftEff $ notify Error "Error parsing PureScript build command"
      liftEff $ showStatus BuildFailure
      pure { success: false, diagnostics: [] }

main :: forall eff. Eff (MainEff eff)
  { activate :: EffFn3 (MainEff eff) String Int String (Promise Unit)
  , deactivate :: Eff (MainEff eff) Unit
  , build :: EffFn2 (MainEff eff) String String (Promise VSBuildResult)
  , quickBuild :: EffFn1 (MainEff eff) String (Promise VSBuildResult)
  , updateFile :: EffFn2 (MainEff eff) String String Unit
  , getTooltips :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Nullable MarkedString))
  , getCompletions :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Array Completion))
  , provideDefinition :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Nullable Location))
  }
main = do
  modulesState <- newRef (initialModulesState)
  deactivateRef <- newRef (pure unit :: Eff (MainEff eff) Unit)
  portRef <- newRef 0

  let cmd s f = register ("purescript." <> s) f

  let deactivate :: Eff (MainEff eff) Unit
      deactivate = join (readRef deactivateRef)

  let showError :: Notify eff
      showError level str = case level of
                             Success -> Notify.showInfo str
                             Info -> Notify.showInfo str
                             Warning -> Notify.showWarning str
                             Error -> Notify.showError str

  let liftEffMM :: forall a. Eff (MainEff eff) a -> Aff (MainEff eff) a
      liftEffMM = liftEff
  let initialise server _port root = fromAff do
        -- TODO pass in port just when explicitly defined
        startRes <- startServer' server _port root showError
        case startRes of
          Just { port, quit } -> do
            P.load port [] []
            liftEffMM $ do
              cmd "addImport" $ readRef portRef >>= addModuleImportCmd modulesState
              cmd "addExplicitImport" $ readRef portRef >>= addIdentImportCmd modulesState
              cmd "caseSplit" $ readRef portRef >>= caseSplit
              cmd "addClause" $ readRef portRef >>= addClause
              writeRef deactivateRef quit
              writeRef portRef port
          Nothing -> pure unit

  pure
    {
      activate: mkEffFn3 initialise
    , deactivate: deactivate
    , build: mkEffFn2 $ build' showError
    , quickBuild: mkEffFn1 \fname -> do
        port <- readRef portRef
        quickBuild port fname
    , updateFile: mkEffFn2 $ \fname text -> do
        port <- readRef portRef
        useEditor port modulesState fname text
    , getTooltips: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getTooltips port state line char (runEffFn4 getText)
    , getCompletions: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getCompletions port state line char (runEffFn4 getText)
    , provideDefinition: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getDefinition port state line char (runEffFn4 getText)
    }


Auto-dismiss dialogs

Auto-dismiss dialogs

{-
Copyright 2017 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.Dialog.Component
  ( Query(..)
  , Message(..)
  , ChildSlot
  , component
  , module SlamData.Workspace.Deck.Dialog.Types
  ) where

import SlamData.Prelude

import Halogen as H
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import SlamData.Dialog.Error.Component as Error
import SlamData.Monad (Slam)
import SlamData.Workspace.Deck.Dialog.Confirm.Component as Confirm
import SlamData.Workspace.Deck.Dialog.Export.Component as Export
import SlamData.Workspace.Deck.Dialog.Reason.Component as Reason
import SlamData.Workspace.Deck.Dialog.Rename.Component as Rename
import SlamData.Workspace.Deck.Dialog.Share.Component as Share
import SlamData.Workspace.Deck.Dialog.Types (Dialog(..))
import SlamData.Workspace.Deck.Dialog.Unshare.Component as Unshare
import SlamData.Workspace.Deck.Options (DeckOptions)

type State = Maybe Dialog

data Query a
  = Show Dialog a
  | Raise Message a

data Message
  = Dismissed
  | Confirm DeckOptions Dialog Boolean

type ChildQuery =
  Rename.Query
  ⨁ Error.Query
  ⨁ Confirm.Query
  ⨁ Export.Query
  ⨁ Export.Query
  ⨁ Share.Query
  ⨁ Unshare.Query
  ⨁ Reason.Query
  ⨁ Const Void

type ChildSlot =
  Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Void

type HTML = H.ParentHTML Query ChildQuery ChildSlot Slam

type DSL = H.ParentDSL State Query ChildQuery ChildSlot Message Slam

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.parentComponent
    { render
    , eval
    , initialState: const Nothing
    , receiver: const Nothing
    }

renderDialogBackdrop ∷ HTML
renderDialogBackdrop =
  HH.div
    [ HP.classes $ [ HH.ClassName "deck-dialog-backdrop" ]
    , HE.onClick $ HE.input_ $ Raise Dismissed
    ]
    [ ]

render ∷ State → HTML
render = case _ of
  Nothing ->
    HH.text ""
  Just s ->
    HH.div_
      [ renderDialogBackdrop
      , HH.div [ HP.classes [ HH.ClassName "deck-dialog" ] ] [ dialog s ]
      ]
  where
  dialog dlg = case dlg of
    Rename opts name →
      HH.slot' CP.cp1 unit Rename.component name
        case _ of
          Rename.Dismiss → Just $ H.action $ Raise Dismissed
          Rename.Rename name' → Just $ H.action $ Raise (Confirm opts (Rename opts name') true)

    Error _ str →
      HH.slot' CP.cp2 unit Error.nonModalComponent str
        \Error.Dismiss → Just $ H.action $ Raise Dismissed

    DeleteDeck opts →
      HH.slot' CP.cp3 unit Confirm.component
        { title: "Delete deck"
        , body: "Are you sure you want to delete this deck?"
        , cancel: "Cancel"
        , confirm: "Delete"
        }
        \(Confirm.Confirm bool) → Just $ H.action $ Raise (Confirm opts dlg bool)

    Embed _ sharingInput varMaps →
      HH.slot' CP.cp4 unit Export.component
        { sharingInput
        , presentingAs: Export.Embed
        , varMaps
        }
        \Export.Dismiss → Just $ H.action $ Raise Dismissed

    Publish _ sharingInput varMaps →
      HH.slot' CP.cp5 unit Export.component
        { sharingInput
        , presentingAs: Export.Publish
        , varMaps
        }
        \Export.Dismiss → Just $ H.action $ Raise Dismissed

    Share _ sharingInput →
      HH.slot' CP.cp6 unit Share.component sharingInput
        \Share.Dismiss → Just $ H.action $ Raise Dismissed

    Unshare _ sharingInput →
      HH.slot' CP.cp7 unit Unshare.component sharingInput
        \Unshare.Dismiss → Just $ H.action $ Raise Dismissed

    Reason _ attemptedCardType reason cardPaths →
      HH.slot' CP.cp8 unit Reason.component
        { attemptedCardType
        , reason
        , cardPaths
        }
        \Reason.Dismiss → Just $ H.action $ Raise Dismissed

eval ∷ Query ~> DSL
eval = case _ of
  Show dialog next → H.put (Just dialog) $> next
  Raise msg next → H.put Nothing *> H.raise msg $> next

{-
Copyright 2017 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.Dialog.Component
  ( Query(..)
  , Message(..)
  , ChildSlot
  , component
  , module SlamData.Workspace.Deck.Dialog.Types
  ) where

import SlamData.Prelude

import Halogen as H
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import SlamData.Dialog.Error.Component as Error
import SlamData.Monad (Slam)
import SlamData.Workspace.Deck.Dialog.Confirm.Component as Confirm
import SlamData.Workspace.Deck.Dialog.Export.Component as Export
import SlamData.Workspace.Deck.Dialog.Reason.Component as Reason
import SlamData.Workspace.Deck.Dialog.Rename.Component as Rename
import SlamData.Workspace.Deck.Dialog.Share.Component as Share
import SlamData.Workspace.Deck.Dialog.Types (Dialog(..))
import SlamData.Workspace.Deck.Dialog.Unshare.Component as Unshare
import SlamData.Workspace.Deck.Options (DeckOptions)

type State = Maybe Dialog

data Query a
  = Show Dialog a
  | Raise Message a
  | Dismiss a

data Message
  = Dismissed
  | Confirm DeckOptions Dialog Boolean

type ChildQuery =
  Rename.Query
  ⨁ Error.Query
  ⨁ Confirm.Query
  ⨁ Export.Query
  ⨁ Export.Query
  ⨁ Share.Query
  ⨁ Unshare.Query
  ⨁ Reason.Query
  ⨁ Const Void

type ChildSlot =
  Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Void

type HTML = H.ParentHTML Query ChildQuery ChildSlot Slam

type DSL = H.ParentDSL State Query ChildQuery ChildSlot Message Slam

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.parentComponent
    { render
    , eval
    , initialState: const Nothing
    , receiver: const Nothing
    }

renderDialogBackdrop ∷ HTML
renderDialogBackdrop =
  HH.div
    [ HP.classes $ [ HH.ClassName "deck-dialog-backdrop" ]
    , HE.onClick $ HE.input_ $ Raise Dismissed
    ]
    [ ]

render ∷ State → HTML
render = case _ of
  Nothing ->
    HH.text ""
  Just s ->
    HH.div_
      [ renderDialogBackdrop
      , HH.div [ HP.classes [ HH.ClassName "deck-dialog" ] ] [ dialog s ]
      ]
  where
  dialog dlg = case dlg of
    Rename opts name →
      HH.slot' CP.cp1 unit Rename.component name
        case _ of
          Rename.Dismiss → Just $ H.action $ Raise Dismissed
          Rename.Rename name' → Just $ H.action $ Raise (Confirm opts (Rename opts name') true)

    Error _ str →
      HH.slot' CP.cp2 unit Error.nonModalComponent str
        \Error.Dismiss → Just $ H.action $ Raise Dismissed

    DeleteDeck opts →
      HH.slot' CP.cp3 unit Confirm.component
        { title: "Delete deck"
        , body: "Are you sure you want to delete this deck?"
        , cancel: "Cancel"
        , confirm: "Delete"
        }
        \(Confirm.Confirm bool) → Just $ H.action $ Raise (Confirm opts dlg bool)

    Embed _ sharingInput varMaps →
      HH.slot' CP.cp4 unit Export.component
        { sharingInput
        , presentingAs: Export.Embed
        , varMaps
        }
        \Export.Dismiss → Just $ H.action $ Raise Dismissed

    Publish _ sharingInput varMaps →
      HH.slot' CP.cp5 unit Export.component
        { sharingInput
        , presentingAs: Export.Publish
        , varMaps
        }
        \Export.Dismiss → Just $ H.action $ Raise Dismissed

    Share _ sharingInput →
      HH.slot' CP.cp6 unit Share.component sharingInput
        \Share.Dismiss → Just $ H.action $ Raise Dismissed

    Unshare _ sharingInput →
      HH.slot' CP.cp7 unit Unshare.component sharingInput
        \Unshare.Dismiss → Just $ H.action $ Raise Dismissed

    Reason _ attemptedCardType reason cardPaths →
      HH.slot' CP.cp8 unit Reason.component
        { attemptedCardType
        , reason
        , cardPaths
        }
        \Reason.Dismiss → Just $ H.action $ Raise Dismissed

eval ∷ Query ~> DSL
eval = case _ of
  Show dialog next → H.put (Just dialog) $> next
  Dismiss next → H.put Nothing *> H.raise Dismissed $> next
  Raise msg next → next <$ case msg of
    Dismissed → H.put Nothing *> H.raise msg
    _ → H.raise msg


fix memory leak problem on MonadRec foldFree

-- | This module defines a strict catenable list.
-- |
-- | The implementation is based on a queue where all operations require
-- | `O(1)` amortized time.
-- |
-- | However, any single `uncons` operation may run in `O(n)` time.
-- |
-- | See [Purely Functional Data Structures](http://www.cs.cmu.edu/~rwh/theses/okasaki.pdf) (Okasaki 1996)
module Data.CatList
  ( CatList(..)
  , empty
  , null
  , singleton
  , length
  , append
  , cons
  , snoc
  , uncons
  , fromFoldable
  ) where

import Prelude hiding (append)

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)
import Data.CatQueue as Q
import Data.Foldable (class Foldable, foldMapDefaultL)
import Data.Foldable as Foldable
import Data.List as L
import Data.Maybe (Maybe(..))
import Data.Traversable (sequence, traverse, class Traversable)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable)
import Data.Unfoldable1 (class Unfoldable1)

-- | A strict catenable list.
-- |
-- | `CatList` may be empty, represented by `CatNil`.
-- |
-- | `CatList` may be non-empty, represented by `CatCons`. The `CatCons`
-- | data constructor takes the first element of the list and a queue of
-- | `CatList`.
data CatList a = CatNil | CatCons a (Q.CatQueue (CatList a))

-- | Create an empty catenable list.
-- |
-- | Running time: `O(1)`
empty :: forall a. CatList a
empty = CatNil

-- | Test whether a catenable list is empty.
-- |
-- | Running time: `O(1)`
null :: forall a. CatList a -> Boolean
null CatNil = true
null _ = false

-- | Number of elements in queue.
-- |
-- | Running time: `O(n)` in length of queue.
length :: forall a. CatList a -> Int
length = Foldable.length

-- | Append all elements of a catenable list to the end of another
-- | catenable list, create a new catenable list.
-- |
-- | Running time: `O(1)`
append :: forall a. CatList a -> CatList a -> CatList a
append as CatNil = as
append CatNil as = as
append as bs = link as bs

-- | Append an element to the beginning of the catenable list, creating a new
-- | catenable list.
-- |
-- | Running time: `O(1)`
cons :: forall a. a -> CatList a -> CatList a
cons a cat = append (CatCons a Q.empty) cat

-- | Create a catenable list with a single item.
-- |
-- | Running time: `O(1)`
singleton :: forall a. a -> CatList a
singleton a = cons a CatNil

-- | Append an element to the end of the catenable list, creating a new
-- | catenable list.
-- |
-- | Running time: `O(1)`
snoc :: forall a. CatList a -> a -> CatList a
snoc cat a = append cat (CatCons a Q.empty)

-- | Decompose a catenable list into a `Tuple` of the first element and
-- | the rest of the catenable list.
-- |
-- | Running time: `O(1)`
-- |
-- | Note that any single operation may run in `O(n)`.
uncons :: forall a. CatList a -> Maybe (Tuple a (CatList a))
uncons CatNil = Nothing
uncons (CatCons a q) = Just (Tuple a (if Q.null q then CatNil else (foldr link CatNil q)))

-- | Links two catenable lists by making appending the queue in the
-- | first catenable list to the second catenable list. This operation
-- | creates a new catenable list.
-- |
-- | Running time: `O(1)`
link :: forall a. CatList a -> CatList a -> CatList a
link CatNil cat = cat
link cat CatNil = cat
link (CatCons a q) cat = CatCons a (Q.snoc q cat)

-- | Tail recursive version of foldr on `CatList`.
-- |
-- | Ensures foldl on `List` is tail-recursive.
foldr :: forall a. (CatList a -> CatList a -> CatList a) -> CatList a -> Q.CatQueue (CatList a) -> CatList a
foldr k b q = go q L.Nil
  where
  go :: Q.CatQueue (CatList a) -> L.List (CatList a -> CatList a) -> CatList a
  go xs ys = case Q.uncons xs of
                  Nothing -> foldl (\x i -> i x) b ys
                  Just (Tuple a rest) -> go rest (L.Cons (k a) ys)

  foldl :: forall b c. (c -> b -> c) -> c -> L.List b -> c
  foldl _ c L.Nil = c
  foldl k' c (L.Cons b' as) = foldl k' (k' c b') as

-- | Convert any `Foldable` into a `CatList`.
-- |
-- | Running time: `O(n)`
fromFoldable :: forall f. Foldable f => f ~> CatList
fromFoldable f = Foldable.foldMap singleton f

foldMap :: forall a m. Monoid m => (a -> m) -> CatList a -> m
foldMap f CatNil = mempty
foldMap f (CatCons a q) =
  let d = if Q.null q then CatNil else (foldr link CatNil q)
  in f a <> foldMap f d

-- | Running time: `O(1)`
instance semigroupCatList :: Semigroup (CatList a) where
  append = append

instance monoidCatList :: Monoid (CatList a) where
  mempty = CatNil

instance showCatList :: Show a => Show (CatList a) where
  show CatNil = "CatNil"
  show (CatCons a as) = "(CatList " <> show a <> " " <> show as <> ")"

instance foldableCatList :: Foldable CatList where
  foldMap = foldMapDefaultL
  foldr f s l = Foldable.foldrDefault f s l
  foldl f = go
    where
    go acc q = case uncons q of
       Just (Tuple x xs) -> go (f acc x) xs
       Nothing -> acc

instance unfoldableCatList :: Unfoldable CatList where
  unfoldr f b = go b CatNil
    where
      go source memo = case f source of
        Nothing -> memo
        Just (Tuple one rest) -> go rest (snoc memo one)

instance unfoldable1CatList :: Unfoldable1 CatList where
  unfoldr1 f b = go b CatNil
    where
      go source memo = case f source of
        Tuple one Nothing -> snoc memo one
        Tuple one (Just rest) -> go rest (snoc memo one)

instance traversableCatList :: Traversable CatList where
  traverse _ CatNil = pure CatNil
  traverse f (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in cons <$> f a <*> traverse f d
  sequence CatNil = pure CatNil
  sequence (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in cons <$> a <*> sequence d

instance functorCatList :: Functor CatList where
  map _ CatNil = CatNil
  map f (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in f a `cons` map f d

instance applyCatList :: Apply CatList where
  apply = ap

instance applicativeCatList :: Applicative CatList where
  pure = singleton

instance bindCatList :: Bind CatList where
  bind = flip foldMap

instance monadCatList :: Monad CatList

instance altCatList :: Alt CatList where
  alt = append

instance plusCatList :: Plus CatList where
  empty = empty

instance alternativeCatList :: Alternative CatList

instance monadZeroCatList :: MonadZero CatList

instance monadPlusCatList :: MonadPlus CatList

-- | This module defines a strict catenable list.
-- |
-- | The implementation is based on a queue where all operations require
-- | `O(1)` amortized time.
-- |
-- | However, any single `uncons` operation may run in `O(n)` time.
-- |
-- | See [Purely Functional Data Structures](http://www.cs.cmu.edu/~rwh/theses/okasaki.pdf) (Okasaki 1996)
module Data.CatList
  ( CatList(..)
  , empty
  , null
  , singleton
  , length
  , append
  , cons
  , snoc
  , uncons
  , fromFoldable
  ) where

import Prelude hiding (append)

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)
import Data.CatQueue as Q
import Data.Foldable (class Foldable, foldMapDefaultL)
import Data.Foldable as Foldable
import Data.List as L
import Data.Maybe (Maybe(..))
import Data.Traversable (sequence, traverse, class Traversable)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable)
import Data.Unfoldable1 (class Unfoldable1)

-- | A strict catenable list.
-- |
-- | `CatList` may be empty, represented by `CatNil`.
-- |
-- | `CatList` may be non-empty, represented by `CatCons`. The `CatCons`
-- | data constructor takes the first element of the list and a queue of
-- | `CatList`.
data CatList a = CatNil | CatCons a (Q.CatQueue (CatList a))

-- | Create an empty catenable list.
-- |
-- | Running time: `O(1)`
empty :: forall a. CatList a
empty = CatNil

-- | Test whether a catenable list is empty.
-- |
-- | Running time: `O(1)`
null :: forall a. CatList a -> Boolean
null CatNil = true
null _ = false

-- | Number of elements in queue.
-- |
-- | Running time: `O(n)` in length of queue.
length :: forall a. CatList a -> Int
length = Foldable.length

-- | Append all elements of a catenable list to the end of another
-- | catenable list, create a new catenable list.
-- |
-- | Running time: `O(1)`
append :: forall a. CatList a -> CatList a -> CatList a
append as CatNil = as
append CatNil as = as
append as bs = link as bs

-- | Append an element to the beginning of the catenable list, creating a new
-- | catenable list.
-- |
-- | Running time: `O(1)`
cons :: forall a. a -> CatList a -> CatList a
cons a cat = append (CatCons a Q.empty) cat

-- | Create a catenable list with a single item.
-- |
-- | Running time: `O(1)`
singleton :: forall a. a -> CatList a
singleton a = cons a CatNil

-- | Append an element to the end of the catenable list, creating a new
-- | catenable list.
-- |
-- | Running time: `O(1)`
snoc :: forall a. CatList a -> a -> CatList a
snoc cat a = append cat (CatCons a Q.empty)

-- | Decompose a catenable list into a `Tuple` of the first element and
-- | the rest of the catenable list.
-- |
-- | Running time: `O(1)`
-- |
-- | Note that any single operation may run in `O(n)`.
uncons :: forall a. CatList a -> Maybe (Tuple a (CatList a))
uncons CatNil = Nothing
uncons (CatCons a q) = Just (Tuple a (if Q.null q then CatNil else (foldr link CatNil q)))

-- | Links two catenable lists by making appending the queue in the
-- | first catenable list to the second catenable list. This operation
-- | creates a new catenable list.
-- |
-- | Running time: `O(1)`
link :: forall a. CatList a -> CatList a -> CatList a
link CatNil cat = cat
link (CatCons a q) cat = CatCons a (Q.snoc q cat)

-- | Tail recursive version of foldr on `CatList`.
-- |
-- | Ensures foldl on `List` is tail-recursive.
foldr :: forall a. (CatList a -> CatList a -> CatList a) -> CatList a -> Q.CatQueue (CatList a) -> CatList a
foldr k b q = go q L.Nil
  where
  go :: Q.CatQueue (CatList a) -> L.List (CatList a -> CatList a) -> CatList a
  go xs ys = case Q.uncons xs of
                  Nothing -> foldl (\x i -> i x) b ys
                  Just (Tuple a rest) -> go rest (L.Cons (k a) ys)

  foldl :: forall b c. (c -> b -> c) -> c -> L.List b -> c
  foldl _ c L.Nil = c
  foldl k' c (L.Cons b' as) = foldl k' (k' c b') as

-- | Convert any `Foldable` into a `CatList`.
-- |
-- | Running time: `O(n)`
fromFoldable :: forall f. Foldable f => f ~> CatList
fromFoldable f = Foldable.foldMap singleton f

foldMap :: forall a m. Monoid m => (a -> m) -> CatList a -> m
foldMap f CatNil = mempty
foldMap f (CatCons a q) =
  let d = if Q.null q then CatNil else (foldr link CatNil q)
  in f a <> foldMap f d

-- | Running time: `O(1)`
instance semigroupCatList :: Semigroup (CatList a) where
  append = append

instance monoidCatList :: Monoid (CatList a) where
  mempty = CatNil

instance showCatList :: Show a => Show (CatList a) where
  show CatNil = "CatNil"
  show (CatCons a as) = "(CatList " <> show a <> " " <> show as <> ")"

instance foldableCatList :: Foldable CatList where
  foldMap = foldMapDefaultL
  foldr f s l = Foldable.foldrDefault f s l
  foldl f = go
    where
    go acc q = case uncons q of
       Just (Tuple x xs) -> go (f acc x) xs
       Nothing -> acc

instance unfoldableCatList :: Unfoldable CatList where
  unfoldr f b = go b CatNil
    where
      go source memo = case f source of
        Nothing -> memo
        Just (Tuple one rest) -> go rest (snoc memo one)

instance unfoldable1CatList :: Unfoldable1 CatList where
  unfoldr1 f b = go b CatNil
    where
      go source memo = case f source of
        Tuple one Nothing -> snoc memo one
        Tuple one (Just rest) -> go rest (snoc memo one)

instance traversableCatList :: Traversable CatList where
  traverse _ CatNil = pure CatNil
  traverse f (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in cons <$> f a <*> traverse f d
  sequence CatNil = pure CatNil
  sequence (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in cons <$> a <*> sequence d

instance functorCatList :: Functor CatList where
  map _ CatNil = CatNil
  map f (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in f a `cons` map f d

instance applyCatList :: Apply CatList where
  apply = ap

instance applicativeCatList :: Applicative CatList where
  pure = singleton

instance bindCatList :: Bind CatList where
  bind = flip foldMap

instance monadCatList :: Monad CatList

instance altCatList :: Alt CatList where
  alt = append

instance plusCatList :: Plus CatList where
  empty = empty

instance alternativeCatList :: Alternative CatList

instance monadZeroCatList :: MonadZero CatList

instance monadPlusCatList :: MonadPlus CatList