add few tests about semantic verification

module Test.Main where

import Prelude

import Control.Monad.Aff.AVar(AVAR)
import Control.Monad.Eff(Eff)
import Control.Monad.Eff.Console(CONSOLE)
import Control.Monad.State(evalStateT)
import Data.Argonaut.Parser(jsonParser)
import Data.Decimal(fromNumber, fromInt)
import Data.Either(Either(..))
import Data.List(fromFoldable)
import Data.Maybe(Maybe(..))
import Test.Unit (suite, test)
import Test.Unit.Assert as Assert
import Test.Unit.Console(TESTOUTPUT)
import Test.Unit.Main (runTest)

import Ifrit.Driver.MongoDB(compile)
import Ifrit.Lexer as L
import Ifrit.Parser as P
import Ifrit.Semantic as S

main :: Eff (avar :: AVAR, console :: CONSOLE, testOutput :: TESTOUTPUT) Unit
main = runTest do
  --  _
  -- | |    _____  _____ _ __
  -- | |   / _ \ \/ / _ \ '__|
  -- | |__|  __/>  <  __/ |
  -- |_____\___/_/\_\___|_|
  --
  suite "lexer" do
    test "Nil" do
      Assert.equal
        (Right $ fromFoldable [L.EOF])
        (evalStateT L.tokenize
          { pos: 0
          , str: ""
          })

    test "[0] SELECT patate" do
      Assert.equal
        (Right $ fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.EOF
          ])
        (evalStateT L.tokenize
          { pos: 0
          , str: "SELECT patate"
          })

    test "[0] SELECT (patate)" do
      Assert.equal
        (Right $ fromFoldable
          [ L.Keyword L.Select
          , L.Parenthesis L.Open
          , L.Word "patate"
          , L.Parenthesis L.Close
          , L.EOF
          ])
        (evalStateT L.tokenize
          { pos: 0
          , str: "SELECT (patate)"
          })

    test "[0] patate     GROUP BY patate" do
      Assert.equal
        (Right $ fromFoldable
          [ L.Word "patate"
          , L.Keyword  L.GroupBy
          , L.Word "patate"
          , L.EOF
          ])
        (evalStateT L.tokenize
          { pos: 0
          , str: "patate     GROUP BY patate"
          })

    test "[2] - NULL patate AS alias" do
      Assert.equal
        (Right $ fromFoldable
          [ L.Keyword L.Null
          , L.Word "patate"
          , L.Keyword L.As
          , L.Word "alias"
          , L.EOF
          ])
        (evalStateT L.tokenize
          { pos: 2
          , str: "- NULL patate AS alias"
          })

    test "[0] WHERE ? = patate" do
      Assert.equal
        (Left "invalid token '?' at position 6")
        (evalStateT L.tokenize
          { pos: 0
          , str: "WHERE ? = patate"
          })

    test "[0] FROM AVG(patate) > 14 OR .42 != 1.14" do
      Assert.equal
        (Right $ fromFoldable
          [ L.Keyword L.From
          , L.Function L.Avg
          , L.Parenthesis L.Open
          , L.Word "patate"
          , L.Parenthesis L.Close
          , L.Binary L.Gt
          , L.Number (fromNumber 14.0)
          , L.Keyword L.Or
          , L.Number (fromNumber 0.42)
          , L.Binary L.Neq
          , L.Number (fromNumber 1.14)
          , L.EOF
          ])
        (evalStateT L.tokenize
          { pos: 0
          , str: "FROM AVG(patate) > 14 OR .42 != 1.14"
          })

    test "[0] WHERE patate = NULL" do
      Assert.equal
        (Right $ fromFoldable
          [ L.Keyword L.Where
          , L.Word "patate"
          , L.Binary L.Eq
          , L.Keyword L.Null
          , L.EOF
          ])
        (evalStateT L.tokenize
          { pos: 0
          , str: "WHERE patate = NULL"
          })

  --  ____
  -- |  _ \ __ _ _ __ ___  ___ _ __
  -- | |_) / _` | '__/ __|/ _ \ '__|
  -- |  __/ (_| | |  \__ \  __/ |
  -- |_|   \__,_|_|  |___/\___|_|
  --
  suite "parser" do
    test "SELECT patate" do
      Assert.equal
        (Right $ P.Select
          (fromFoldable
            [ P.Projection $ P.Selector "patate" Nothing
            ])
          Nothing
          Nothing
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.EOF
          ]))

    test "SELECT patate AS autruche" do
      Assert.equal
        (Right $ P.Select
          (fromFoldable
            [ P.Projection $ P.Selector "patate" (Just "autruche")
            ])
          Nothing
          Nothing
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.Keyword L.As
          , L.Word "autruche"
          , L.EOF
          ]))

    test "SELECT (patate), autruche" do
      Assert.equal
        (Right $ P.Select
          (fromFoldable
            [ P.Projection $ P.Selector "patate" Nothing
            , P.Projection $ P.Selector "autruche" Nothing
            ])
          Nothing
          Nothing
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Parenthesis L.Open
          , L.Word "patate"
          , L.Parenthesis L.Close
          , L.Comma
          , L.Word "autruche"
          , L.EOF
          ]))

    test "SELECT patate WHERE autruche > 14" do
      Assert.equal
        (Right $ P.Select
          (fromFoldable
            [ P.Projection $ P.Selector "patate" Nothing
            ])
          Nothing
          (Just $ P.Term $ P.Factor $ P.Binary
            L.Gt (P.Field "autruche") (P.Number (fromInt 14)
          ))
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.Keyword L.Where
          , L.Word "autruche"
          , L.Binary L.Gt
          , L.Number (fromInt 14)
          , L.EOF
          ]))

    test "SELECT patate FROM (SELECT autruche)" do
      Assert.equal
        (Right $ P.Select
          (fromFoldable
            [ P.Projection $ P.Selector "patate" Nothing
            ])
          (Just $ P.Select
            (fromFoldable
              [ P.Projection $ P.Selector "autruche" Nothing
              ])
            Nothing
            Nothing
          )
          Nothing
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.Keyword L.From
          , L.Parenthesis L.Open
          , L.Keyword L.Select
          , L.Word "autruche"
          , L.Parenthesis L.Close
          , L.EOF
          ]))

    test "SELECT patate GROUP BY NULL" do
      Assert.equal
        (Right $ P.Group
          P.IdxNull
          (fromFoldable
            [ P.Aggregation $ P.Selector "patate" Nothing
            ])
          Nothing
          Nothing
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.Keyword L.GroupBy
          , L.Keyword L.Null
          , L.EOF
          ]))

    test "SELECT patate GROUP BY NULL (no EOF)" do
      Assert.equal
        (Left "parsing error: invalid end of input" :: Either String P.Statement)
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.Keyword L.GroupBy
          , L.Keyword L.Null
          ]))

    test "SELECT patate GROUP BY NULL WHERE 14.0 > 42.0" do
      Assert.equal
        (Left "parsing error: invalid end of input" :: Either String P.Statement)
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.Keyword L.GroupBy
          , L.Keyword L.Null
          , L.Keyword L.Where
          , L.Number (fromNumber 14.0)
          , L.Binary L.Gt
          , L.Number (fromNumber 42.0)
          , L.EOF
          ]))

    test "SELECT patate WHERE 14.0 = 42.0 GROUP BY autruche" do
      Assert.equal
        (Right $ P.Group
          (P.IdxField "autruche")
          (fromFoldable
            [ P.Aggregation $ P.Selector "patate" Nothing
            ])
          Nothing
          (Just $ P.Term $ P.Factor $ P.Binary
            L.Eq (P.Number (fromNumber 14.0)) (P.Number (fromNumber 42.0))
          )
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.Keyword L.Where
          , L.Number (fromNumber 14.0)
          , L.Binary L.Eq
          , L.Number (fromNumber 42.0)
          , L.Keyword L.GroupBy
          , L.Word "autruche"
          , L.EOF
          ]))

    test "SELECT AVG(patate), COUNT(things) AS c WHERE autruche != \"banana\"" do
      Assert.equal
        (Right $ P.Select
          (fromFoldable
            [ P.Projection $ P.Function L.Avg "patate" Nothing
            , P.Projection $ P.Function L.Count "things" (Just "c")
            ])
          Nothing
          (Just $ P.Term $ P.Factor $ P.Binary
            L.Neq (P.Field "autruche") (P.String "banana")
          )
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Function L.Avg
          , L.Parenthesis L.Open
          , L.Word "patate"
          , L.Parenthesis L.Close
          , L.Comma
          , L.Function L.Count
          , L.Parenthesis L.Open
          , L.Word "things"
          , L.Parenthesis L.Close
          , L.Keyword L.As
          , L.Word "c"
          , L.Keyword L.Where
          , L.Word "autruche"
          , L.Binary L.Neq
          , L.String "banana"
          , L.EOF
          ]))

    test "SELECT (patate, autruche" do
      Assert.equal
        (Left "parsing error: unbalanced parenthesis expression" :: Either String P.Statement)
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Parenthesis L.Open
          , L.Word "patate"
          , L.Comma
          , L.Word "autruche"
          , L.EOF
          ]))

    test "SELECT AVG(14)" do
      Assert.equal
        (Left "parsing error: unexpected token: 14" :: Either String P.Statement)
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Function L.Avg
          , L.Parenthesis L.Open
          , L.Number $ fromInt 14
          , L.Parenthesis L.Close
          , L.EOF
          ]))

    test "SELECT AVG(patate, autruche)" do
      Assert.equal
        (Left "parsing error: invalid argument(s) for function AVG" :: Either String P.Statement)
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Function L.Avg
          , L.Parenthesis L.Open
          , L.Word "patate"
          , L.Comma
          , L.Word "autruche"
          , L.Parenthesis L.Close
          , L.EOF
          ]))

    test "SELECT (((((patate)))))" do
      Assert.equal
        (Right $ P.Select
          (fromFoldable
            [ P.Projection $ P.Selector "patate" Nothing
            ])
          Nothing
          Nothing
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Parenthesis L.Open
          , L.Parenthesis L.Open
          , L.Parenthesis L.Open
          , L.Parenthesis L.Open
          , L.Parenthesis L.Open
          , L.Word "patate"
          , L.Parenthesis L.Close
          , L.Parenthesis L.Close
          , L.Parenthesis L.Close
          , L.Parenthesis L.Close
          , L.Parenthesis L.Close
          , L.EOF
          ]))

    test "SELECT patate WHERE patate = NULL" do
      Assert.equal
        (Right $ P.Select
          (fromFoldable
            [ P.Projection $ P.Selector "patate" Nothing
            ])
          Nothing
          (Just $ P.Term $ P.Factor $ P.Binary
            L.Eq (P.Field "patate") P.Null
          )
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.Keyword L.Where
          , L.Word "patate"
          , L.Binary L.Eq
          , L.Keyword L.Null
          , L.EOF
          ]))

  --  ____       _
  -- |  _ \ _ __(_)_   _____ _ __
  -- | | | | '__| \ \ / / _ \ '__|
  -- | |_| | |  | |\ V /  __/ |
  -- |____/|_|  |_| \_/ \___|_|
  --
  suite "driver - MongoDB" do
    test "SELECT SUM(lvl) GROUP BY age" do
      Assert.equal
        (jsonParser
          """
          [
            {
              "$group": {
                "_id": "$age",
                "lvl": {
                  "$sum": "$lvl"
                }
              }
            }
          ]
          """)
        (compile "SELECT SUM(lvl) GROUP BY age")

    test "SELECT MAX(spells.power) AS max_power" do
      Assert.equal
        (jsonParser
          """
          [
            {
              "$project": {
                "max_power": {
                  "$reduce": {
                    "input": "$spells",
                    "in": {
                      "$cond": {
                        "if": {
                          "$or": [
                            { "$eq": ["$$value", null] },
                            { "$gt": ["$power", "$$value"] }
                          ]
                        },
                        "then": "$power",
                        "else": "$$value"
                      }
                    },
                    "initialValue": null
                  }
                }
              }
            }
          ]
          """)
          (compile "SELECT MAX(spells.power) AS max_power")

    test "SELECT AVG(power) FROM (SELECT class, AVG(spells.power) AS power) GROUP BY class" do
      Assert.equal
        (jsonParser
          """
          [
            {
              "$project": {
                "class": "$class",
                "power": {
                  "$divide": [
                    {
                      "$reduce": {
                        "input": "$spells",
                        "initialValue": 0,
                        "in": {
                          "$add": ["$$value", "$power"]
                        }
                      }
                    },
                    {
                      "$size": "$spells"
                    }
                  ]
                }
              }
            },
            {
              "$group": {
                "_id": "$class",
                "power": {
                  "$avg": "$power"
                }
              }
            }
          ]
          """)
          (compile "SELECT AVG(power) FROM (SELECT class, AVG(spells.power) AS power) GROUP BY class")

    test "SELECT name WHERE age < 16" do
      Assert.equal
        (jsonParser
          """
          [
            {
              "$match": {
                "$lt": ["$age", 16]
              }
            },
            {
              "$project": {
                "name": "$name"
              }
            }
          ]
          """)
          (compile "SELECT name WHERE age < 16")

    test "SELECT AVG(power) AS pwr WHERE age < 16 AND class = \"necromancer\"" do
      Assert.equal
        (jsonParser
          """
          [
            {
              "$match": {
                "$and": [
                  { "$lt": ["$age", 16] },
                  { "$eq": ["$class", "necromancer"] }
                ]
              }
            },
            {
              "$project": {
                "pwr": {
                  "$avg": "$power"
                }
              }
            }
          ]
          """)
          (compile "SELECT AVG(power) AS pwr WHERE age < 16 AND class = \"necromancer\"")

    test "SELECT power WHERE parent = NULL" do
      Assert.equal
        (jsonParser
          """
          [
            {
              "$match": {
                "$eq": ["$parent", null]
              }
            },
            {
              "$project": {
                "power": "$power"
              }
            }
          ]
          """)
          (compile "SELECT power WHERE parent = NULL")

  --  ____                             _   _
  -- / ___|  ___ _ __ ___   __ _ _ __ | |_(_) ___
  -- \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __|
  --  ___) |  __/ | | | | | (_| | | | | |_| | (__
  -- |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|
  --
  suite "semantic" do
    test "invalid index (aggregation) - unexpected field" do
      Assert.equal
        (Left "unexisting field: 'patate'")
        (do
          schema <- S.fromString
            """
            {
              "autruche": "number"
            }
            """
          S.analyze schema (P.Group
              (P.IdxField "patate")
              (fromFoldable
                [ P.Aggregation $ P.Selector "autruche" Nothing
                ])
              Nothing
              Nothing
            )
          )

    test "invalid condition (projection) - unexpected field" do
      Assert.equal
        (Left "unexisting field: 'patate'")
        (do
          schema <- S.fromString
            """
            {
              "autruche": "number"
            }
            """
          S.analyze schema (P.Select
              (fromFoldable
                [ P.Projection $ P.Selector "autruche" Nothing
                ])
              Nothing
              (Just $ P.Term $ P.Factor $ P.Binary
                L.Eq (P.Field "patate") (P.String "banana")
              )
            )
          )

    test "invalid condition (projection) - type mismatch Lt" do
      Assert.equal
        (Left "invalid combination of types for '<' operator")
        (do
          schema <- S.fromString
            """
            {
              "autruche": "number"
            }
            """
          S.analyze schema (P.Select
              (fromFoldable
                [ P.Projection $ P.Selector "autruche" Nothing
                ])
              Nothing
              (Just $ P.Term $ P.Factor $ P.Binary
                L.Lt (P.Field "autruche") (P.String "banana")
              )
            )
          )

    test "invalid condition (projection) - type mismatch Lt (2)" do
      Assert.equal
        (Left "invalid combination of types for '<' operator")
        (do
          schema <- S.fromString
            """
            {
              "autruche": "string"
            }
            """
          S.analyze schema (P.Select
              (fromFoldable
                [ P.Projection $ P.Selector "autruche" Nothing
                ])
              Nothing
              (Just $ P.Term $ P.Factor $ P.Binary
                L.Lt (P.Field "autruche") (P.Number $ fromInt 14)
              )
            )
          )

    test "invalid condition (projection) - type mismatch Eq" do
      Assert.equal
        (Left "invalid combination of types for '=' operator")
        (do
          schema <- S.fromString
            """
            {
              "autruche": "string"
            }
            """
          S.analyze schema (P.Select
              (fromFoldable
                [ P.Projection $ P.Selector "autruche" Nothing
                ])
              Nothing
              (Just $ P.Term $ P.Factor $ P.Binary
                L.Eq (P.Field "autruche") (P.Number $ fromInt 14)
              )
            )
          )

    test "invalid condition (Aggrrgation) - unexpected field (2)" do
      Assert.equal
        (Left "unexisting field: 'patate'")
        (do
          schema <- S.fromString
            """
            {
              "autruche": "boolean"
            }
            """
          S.analyze schema (P.Group
              P.IdxNull
              (fromFoldable
                [ P.Aggregation $ P.Selector "autruche" Nothing
                ])
              Nothing
              (Just $ P.Term $ P.Factor $ P.Binary
                L.Neq (P.Field "patate") (P.Boolean true)
              )
            )
          )

    test "invalid condition (aggregation) - type mismatch Neq" do
      Assert.equal
        (Left "invalid combination of types for '!=' operator")
        (do
          schema <- S.fromString
            """
            {
              "autruche": "string"
            }
            """
          S.analyze schema (P.Group
              (P.IdxField "autruche")
              (fromFoldable
                [ P.Aggregation $ P.Selector "autruche" Nothing
                ])
              Nothing
              (Just $ P.Term $ P.Factor $ P.Binary
                L.Neq (P.Field "autruche") (P.Number $ fromInt 14)
              )
            )
          )

    test "invalid selection - unexisting field" do
      Assert.equal
        (Left "unexisting field: 'patate'")
        (do
          schema <- S.fromString
            """
            {
              "autruche": "string"
            }
            """
          S.analyze schema (P.Group
              (P.IdxField "autruche")
              (fromFoldable
                [ P.Aggregation $ P.Selector "patate" Nothing
                ])
              Nothing
              Nothing
            )
          )

    test "invalid selection - group with alias as _id" do
      Assert.equal
        (Left "reserved field's name: _id")
        (do
          schema <- S.fromString
            """
            {
              "autruche": "string"
            }
            """
          S.analyze schema (P.Group
              P.IdxNull
              (fromFoldable
                [ P.Aggregation $ P.Selector "autruche" (Just "_id")
                ])
              Nothing
              Nothing
            )
          )

    test "invalid selection - group with alias as _id (2)" do
      Assert.equal
        (Left "reserved field's name: _id")
        (do
          schema <- S.fromString
            """
            {
              "autruche": "string"
            }
            """
          S.analyze schema (P.Group
              P.IdxNull
              (fromFoldable
                [ P.Aggregation $ P.Selector "_id" Nothing
                ])
              Nothing
              Nothing
            )
          )

    test "invalid function call - (projection) avg on non-array" do
      Assert.equal
        (Left "invalid operation: function 'AVG' applied to non array<number>")
        (do
          schema <- S.fromString
            """
            {
              "autruche": "string"
            }
            """
          S.analyze schema (P.Select
              (fromFoldable
                [ P.Projection $ P.Function L.Avg "autruche" Nothing
                ])
              Nothing
              Nothing
            )
          )

module Test.Main where

import Prelude

import Control.Monad.Aff.AVar(AVAR)
import Control.Monad.Eff(Eff)
import Control.Monad.Eff.Console(CONSOLE)
import Control.Monad.State(evalStateT)
import Data.Argonaut.Parser(jsonParser)
import Data.Decimal(fromNumber, fromInt)
import Data.Either(Either(..))
import Data.List(fromFoldable)
import Data.Maybe(Maybe(..))
import Test.Unit (suite, test)
import Test.Unit.Assert as Assert
import Test.Unit.Console(TESTOUTPUT)
import Test.Unit.Main (runTest)

import Ifrit.Lexer as L
import Ifrit.Parser as P
import Ifrit.Driver.MongoDB(compile)

main :: Eff (avar :: AVAR, console :: CONSOLE, testOutput :: TESTOUTPUT) Unit
main = runTest do
  --  _
  -- | |    _____  _____ _ __
  -- | |   / _ \ \/ / _ \ '__|
  -- | |__|  __/>  <  __/ |
  -- |_____\___/_/\_\___|_|
  --
  suite "lexer" do
    test "Nil" do
      Assert.equal
        (Right $ fromFoldable [L.EOF])
        (evalStateT L.tokenize
          { pos: 0
          , str: ""
          })

    test "[0] SELECT patate" do
      Assert.equal
        (Right $ fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.EOF
          ])
        (evalStateT L.tokenize
          { pos: 0
          , str: "SELECT patate"
          })

    test "[0] SELECT (patate)" do
      Assert.equal
        (Right $ fromFoldable
          [ L.Keyword L.Select
          , L.Parenthesis L.Open
          , L.Word "patate"
          , L.Parenthesis L.Close
          , L.EOF
          ])
        (evalStateT L.tokenize
          { pos: 0
          , str: "SELECT (patate)"
          })

    test "[0] patate     GROUP BY patate" do
      Assert.equal
        (Right $ fromFoldable
          [ L.Word "patate"
          , L.Keyword  L.GroupBy
          , L.Word "patate"
          , L.EOF
          ])
        (evalStateT L.tokenize
          { pos: 0
          , str: "patate     GROUP BY patate"
          })

    test "[2] - NULL patate AS alias" do
      Assert.equal
        (Right $ fromFoldable
          [ L.Keyword L.Null
          , L.Word "patate"
          , L.Keyword L.As
          , L.Word "alias"
          , L.EOF
          ])
        (evalStateT L.tokenize
          { pos: 2
          , str: "- NULL patate AS alias"
          })

    test "[0] WHERE ? = patate" do
      Assert.equal
        (Left "invalid token '?' at position 6")
        (evalStateT L.tokenize
          { pos: 0
          , str: "WHERE ? = patate"
          })

    test "[0] FROM AVG(patate) > 14 OR .42 != 1.14" do
      Assert.equal
        (Right $ fromFoldable
          [ L.Keyword L.From
          , L.Function L.Avg
          , L.Parenthesis L.Open
          , L.Word "patate"
          , L.Parenthesis L.Close
          , L.Binary L.Gt
          , L.Number (fromNumber 14.0)
          , L.Keyword L.Or
          , L.Number (fromNumber 0.42)
          , L.Binary L.Neq
          , L.Number (fromNumber 1.14)
          , L.EOF
          ])
        (evalStateT L.tokenize
          { pos: 0
          , str: "FROM AVG(patate) > 14 OR .42 != 1.14"
          })

  --  ____
  -- |  _ \ __ _ _ __ ___  ___ _ __
  -- | |_) / _` | '__/ __|/ _ \ '__|
  -- |  __/ (_| | |  \__ \  __/ |
  -- |_|   \__,_|_|  |___/\___|_|
  --
  suite "parser" do
    test "SELECT patate" do
      Assert.equal
        (Right $ P.Select
          (fromFoldable
            [ P.Projection $ P.Selector "patate" Nothing
            ])
          Nothing
          Nothing
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.EOF
          ]))

    test "SELECT patate AS autruche" do
      Assert.equal
        (Right $ P.Select
          (fromFoldable
            [ P.Projection $ P.Selector "patate" (Just "autruche")
            ])
          Nothing
          Nothing
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.Keyword L.As
          , L.Word "autruche"
          , L.EOF
          ]))

    test "SELECT (patate), autruche" do
      Assert.equal
        (Right $ P.Select
          (fromFoldable
            [ P.Projection $ P.Selector "patate" Nothing
            , P.Projection $ P.Selector "autruche" Nothing
            ])
          Nothing
          Nothing
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Parenthesis L.Open
          , L.Word "patate"
          , L.Parenthesis L.Close
          , L.Comma
          , L.Word "autruche"
          , L.EOF
          ]))

    test "SELECT patate WHERE autruche > 14" do
      Assert.equal
        (Right $ P.Select
          (fromFoldable
            [ P.Projection $ P.Selector "patate" Nothing
            ])
          Nothing
          (Just $ P.Term $ P.Factor $ P.Binary
            L.Gt (P.Field "autruche") (P.Number (fromInt 14)
          ))
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.Keyword L.Where
          , L.Word "autruche"
          , L.Binary L.Gt
          , L.Number (fromInt 14)
          , L.EOF
          ]))

    test "SELECT patate FROM (SELECT autruche)" do
      Assert.equal
        (Right $ P.Select
          (fromFoldable
            [ P.Projection $ P.Selector "patate" Nothing
            ])
          (Just $ P.Select
            (fromFoldable
              [ P.Projection $ P.Selector "autruche" Nothing
              ])
            Nothing
            Nothing
          )
          Nothing
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.Keyword L.From
          , L.Parenthesis L.Open
          , L.Keyword L.Select
          , L.Word "autruche"
          , L.Parenthesis L.Close
          , L.EOF
          ]))

    test "SELECT patate GROUP BY NULL" do
      Assert.equal
        (Right $ P.Group
          P.IdxNull
          (fromFoldable
            [ P.Aggregation $ P.Selector "patate" Nothing
            ])
          Nothing
          Nothing
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.Keyword L.GroupBy
          , L.Keyword L.Null
          , L.EOF
          ]))

    test "SELECT patate GROUP BY NULL (no EOF)" do
      Assert.equal
        (Left "parsing error: invalid end of input" :: Either String P.Statement)
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.Keyword L.GroupBy
          , L.Keyword L.Null
          ]))

    test "SELECT patate GROUP BY NULL WHERE 14.0 > 42.0" do
      Assert.equal
        (Left "parsing error: invalid end of input" :: Either String P.Statement)
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.Keyword L.GroupBy
          , L.Keyword L.Null
          , L.Keyword L.Where
          , L.Number (fromNumber 14.0)
          , L.Binary L.Gt
          , L.Number (fromNumber 42.0)
          , L.EOF
          ]))

    test "SELECT patate WHERE 14.0 = 42.0 GROUP BY autruche" do
      Assert.equal
        (Right $ P.Group
          (P.IdxField "autruche")
          (fromFoldable
            [ P.Aggregation $ P.Selector "patate" Nothing
            ])
          Nothing
          (Just $ P.Term $ P.Factor $ P.Binary
            L.Eq (P.Number (fromNumber 14.0)) (P.Number (fromNumber 42.0))
          )
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Word "patate"
          , L.Keyword L.Where
          , L.Number (fromNumber 14.0)
          , L.Binary L.Eq
          , L.Number (fromNumber 42.0)
          , L.Keyword L.GroupBy
          , L.Word "autruche"
          , L.EOF
          ]))

    test "SELECT AVG(patate), COUNT(things) AS c WHERE autruche != \"banana\"" do
      Assert.equal
        (Right $ P.Select
          (fromFoldable
            [ P.Projection $ P.Function L.Avg "patate" Nothing
            , P.Projection $ P.Function L.Count "things" (Just "c")
            ])
          Nothing
          (Just $ P.Term $ P.Factor $ P.Binary
            L.Neq (P.Field "autruche") (P.String "banana")
          )
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Function L.Avg
          , L.Parenthesis L.Open
          , L.Word "patate"
          , L.Parenthesis L.Close
          , L.Comma
          , L.Function L.Count
          , L.Parenthesis L.Open
          , L.Word "things"
          , L.Parenthesis L.Close
          , L.Keyword L.As
          , L.Word "c"
          , L.Keyword L.Where
          , L.Word "autruche"
          , L.Binary L.Neq
          , L.String "banana"
          , L.EOF
          ]))

    test "SELECT (patate, autruche" do
      Assert.equal
        (Left "parsing error: unbalanced parenthesis expression" :: Either String P.Statement)
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Parenthesis L.Open
          , L.Word "patate"
          , L.Comma
          , L.Word "autruche"
          , L.EOF
          ]))

    test "SELECT AVG(14)" do
      Assert.equal
        (Left "parsing error: unexpected token: 14" :: Either String P.Statement)
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Function L.Avg
          , L.Parenthesis L.Open
          , L.Number $ fromInt 14
          , L.Parenthesis L.Close
          , L.EOF
          ]))

    test "SELECT AVG(patate, autruche)" do
      Assert.equal
        (Left "parsing error: invalid argument(s) for function AVG" :: Either String P.Statement)
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Function L.Avg
          , L.Parenthesis L.Open
          , L.Word "patate"
          , L.Comma
          , L.Word "autruche"
          , L.Parenthesis L.Close
          , L.EOF
          ]))

    test "SELECT (((((patate)))))" do
      Assert.equal
        (Right $ P.Select
          (fromFoldable
            [ P.Projection $ P.Selector "patate" Nothing
            ])
          Nothing
          Nothing
        )
        (evalStateT P.parse (fromFoldable
          [ L.Keyword L.Select
          , L.Parenthesis L.Open
          , L.Parenthesis L.Open
          , L.Parenthesis L.Open
          , L.Parenthesis L.Open
          , L.Parenthesis L.Open
          , L.Word "patate"
          , L.Parenthesis L.Close
          , L.Parenthesis L.Close
          , L.Parenthesis L.Close
          , L.Parenthesis L.Close
          , L.Parenthesis L.Close
          , L.EOF
          ]))

  --  ____       _
  -- |  _ \ _ __(_)_   _____ _ __
  -- | | | | '__| \ \ / / _ \ '__|
  -- | |_| | |  | |\ V /  __/ |
  -- |____/|_|  |_| \_/ \___|_|
  --
  suite "driver - MongoDB" do
    test "SELECT SUM(lvl) GROUP BY age" do
      Assert.equal
        (jsonParser
          """
          [
            {
              "$group": {
                "_id": "$age",
                "lvl": {
                  "$sum": "$lvl"
                }
              }
            }
          ]
          """)
        (compile "SELECT SUM(lvl) GROUP BY age")

    test "SELECT MAX(spells.power) AS max_power" do
      Assert.equal
        (jsonParser
          """
          [
            {
              "$project": {
                "max_power": {
                  "$reduce": {
                    "input": "$spells",
                    "in": {
                      "$cond": {
                        "if": {
                          "$or": [
                            { "$eq": ["$$value", null] },
                            { "$gt": ["$power", "$$value"] }
                          ]
                        },
                        "then": "$power",
                        "else": "$$value"
                      }
                    },
                    "initialValue": null
                  }
                }
              }
            }
          ]
          """)
          (compile "SELECT MAX(spells.power) AS max_power")

    test "SELECT AVG(power) FROM (SELECT class, AVG(spells.power) AS power) GROUP BY class" do
      Assert.equal
        (jsonParser
          """
          [
            {
              "$project": {
                "class": "$class",
                "power": {
                  "$divide": [
                    {
                      "$reduce": {
                        "input": "$spells",
                        "initialValue": 0,
                        "in": {
                          "$add": ["$$value", "$power"]
                        }
                      }
                    },
                    {
                      "$size": "$spells"
                    }
                  ]
                }
              }
            },
            {
              "$group": {
                "_id": "$class",
                "power": {
                  "$avg": "$power"
                }
              }
            }
          ]
          """)
          (compile "SELECT AVG(power) FROM (SELECT class, AVG(spells.power) AS power) GROUP BY class")

    test "SELECT name WHERE age < 16" do
      Assert.equal
        (jsonParser
          """
          [
            {
              "$match": {
                "$lt": ["$age", 16]
              }
            },
            {
              "$project": {
                "name": "$name"
              }
            }
          ]
          """)
          (compile "SELECT name WHERE age < 16")

    test "SELECT AVG(power) AS pwr WHERE age < 16 AND class = \"necromancer\"" do
      Assert.equal
        (jsonParser
          """
          [
            {
              "$match": {
                "$and": [
                  { "$lt": ["$age", 16] },
                  { "$eq": ["$class", "necromancer"] }
                ]
              }
            },
            {
              "$project": {
                "pwr": {
                  "$avg": "$power"
                }
              }
            }
          ]
          """)
          (compile "SELECT AVG(power) AS pwr WHERE age < 16 AND class = \"necromancer\"")


Remove old code in comment

Remove old code in comment

module Test.Spec (
  Name(..),
  Result(..),
  Group(..),
  Spec(..),
  describe,
  pending,
  it,
  collect
  ) where

import Debug.Trace
import Data.Maybe
import Data.Tuple
import Data.Array
import Data.Either
import Data.String (joinWith, split)
import Control.Monad
import Control.Monad.State
import Control.Monad.State.Class
import Control.Monad.State.Trans
import Control.Monad.Trans
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.Extras
import Control.Monad.Aff

type Name = String

data Result = Success
            | Failure Error

data Group = Describe Name [Group]
           | It Name Result
           | Pending Name

instance showResult :: Show Result where
  show Success = "Success"
  show (Failure err) = "Failure (Error ...)"

instance eqResult :: Eq Result where
  (==) Success Success = true
  (==) (Failure _) (Failure _) = true
  (==) _ _ = false
  (/=) r1 r2 = not (r1 == r2)

instance showGroup :: Show Group where
  show (Describe name groups) = "Describe " ++ show name ++ " " ++ show groups
  show (It name result) = "It " ++ show name ++ " " ++ show result
  show (Pending name) = "Describe " ++ show name

instance eqGroup :: Eq Group where
  (==) (Describe n1 g1) (Describe n2 g2) = n1 == n2 && g1 == g2
  (==) (It n1 r1) (It n2 r2) = n1 == n2 && r1 == r2
  (==) (Pending n1) (Pending n2) = n1 == n2
  (==) _ _ = false
  (/=) r1 r2 = not (r1 == r2)

type Spec r t = StateT [Group] (Aff r) t

describe :: forall r. String
         -> Spec r Unit
         -> Spec r Unit
describe name its = do
  results <- lift $ collect its
  modify $ \r -> r ++ [Describe name results]
  return unit

pending :: forall r. String
        -> Spec r Unit
pending name = modify $ \p -> p ++ [Pending name]

runCatch :: forall r. String
         -> Aff r Unit
         -> Aff r Group
runCatch name tests = do
  e <- attempt tests
  either onError onSuccess e
  where
  onError e = return $ It name $ Failure e
  onSuccess _ = return $ It name Success

it :: forall r. String
    -> Aff r Unit
    -> Spec r Unit
it description tests =
  do
    result <- lift $ runCatch description tests
    modify $ \p -> p ++ [result]
    return unit

collect :: forall r. Spec r Unit
        -> Aff r [Group]
collect r = do
  c <- runStateT r []
  return $ snd c

module Test.Spec (
  Name(..),
  Result(..),
  Group(..),
  Spec(..),
  describe,
  pending,
  it,
  collect
  ) where

import Debug.Trace
import Data.Maybe
import Data.Tuple
import Data.Array
import Data.Either
import Data.String (joinWith, split)
import Control.Monad
import Control.Monad.State
import Control.Monad.State.Class
import Control.Monad.State.Trans
import Control.Monad.Trans
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.Extras
import Control.Monad.Aff

type Name = String

data Result = Success
            | Failure Error

data Group = Describe Name [Group]
           | It Name Result
           | Pending Name

instance showResult :: Show Result where
  show Success = "Success"
  show (Failure err) = "Failure (Error ...)"

instance eqResult :: Eq Result where
  (==) Success Success = true
  (==) (Failure _) (Failure _) = true
  (==) _ _ = false
  (/=) r1 r2 = not (r1 == r2)

instance showGroup :: Show Group where
  show (Describe name groups) = "Describe " ++ show name ++ " " ++ show groups
  show (It name result) = "It " ++ show name ++ " " ++ show result
  show (Pending name) = "Describe " ++ show name

instance eqGroup :: Eq Group where
  (==) (Describe n1 g1) (Describe n2 g2) = n1 == n2 && g1 == g2
  (==) (It n1 r1) (It n2 r2) = n1 == n2 && r1 == r2
  (==) (Pending n1) (Pending n2) = n1 == n2
  (==) _ _ = false
  (/=) r1 r2 = not (r1 == r2)

type Spec r t = StateT [Group] (Aff r) t

describe :: forall r. String
         -> Spec r Unit
         -> Spec r Unit
describe name its = do
  results <- lift $ collect its
  modify $ \r -> r ++ [Describe name results]
  return unit

pending :: forall r. String
        -> Spec r Unit
pending name = modify $ \p -> p ++ [Pending name]

-- it :: forall r. String
--    -> Eff (err :: Exception | r) Unit
--    -> Spec r Unit
-- it description tests = it' description (return tests)

runCatch :: forall r. String
         -> Aff r Unit
         -> Aff r Group
runCatch name tests = do
  e <- attempt tests
  either onError onSuccess e
  where
  onError e = return $ It name $ Failure e
  onSuccess _ = return $ It name Success

it :: forall r. String
    -> Aff r Unit
    -> Spec r Unit
it description tests =
  do
    result <- lift $ runCatch description tests
    modify $ \p -> p ++ [result]
    return unit

collect :: forall r. Spec r Unit
        -> Aff r [Group]
collect r = do
  c <- runStateT r []
  return $ snd c


Removed Utils.Aff.throw

Removed Utils.Aff.throw

{-
Copyright 2016 SlamData, Inc.

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

throw ∷ ∀ a eff. String → Aff eff a
throw = throwError <<< Exception.error

    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 Utils.Aff where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Rec.Class (Step(..), tailRecM)

-- | Loop until a condition becomes `true`.
-- |
-- | `untilE b` is an effectful computation which repeatedly runs the effectful
-- | computation `b`, until its return value is `true`.
untilA ∷ ∀ eff. Aff eff Boolean → Aff eff Unit
untilA aff =
  tailRecM go unit
  where
  go = const $ (if _ then pure (Done unit) else pure (Loop unit)) =<< aff

{-
Copyright 2016 SlamData, Inc.

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

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

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

module Utils.Aff where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Rec.Class (Step(..), tailRecM)
import Control.Monad.Eff.Exception as Exception
import Control.Monad.Error.Class (throwError)

-- | Loop until a condition becomes `true`.
-- |
-- | `untilE b` is an effectful computation which repeatedly runs the effectful
-- | computation `b`, until its return value is `true`.
untilA ∷ ∀ eff. Aff eff Boolean → Aff eff Unit
untilA aff =
  tailRecM go unit
  where
  go = const $ (if _ then pure (Done unit) else pure (Loop unit)) =<< aff

throw ∷ ∀ a eff. String → Aff eff a
throw = throwError <<< Exception.error


type annotation

type annotation

module Web where

import Prelude
import Data.Foldable (class Foldable, intercalate)
import Data.Unfoldable (fromMaybe)
import Data.List (List(Nil, Cons), snoc, fromFoldable, (:), singleton)
import Data.Set (intersection, size)
import Data.Set as Set
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Tuple (Tuple(..))
import Data.Traversable (for, for_)
import Data.Array as Arr
import Data.String as Str

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.JQuery as J
import DOM (DOM)

import AST (Atom(..), Binding(..), MType, Op, QualTree(..), Tree(..), TypeTree, TypedBinding, Meta(..), Index,
            Type(..), TypeQual, DataConstr(..), pPrintOp, prettyPrintType, prettyPrintTypeError, getMetaMType)

import AST as AST

data RoseTree a = Node a (List (RoseTree a))

type Div = RoseTree { content :: String, classes :: (List String), zipper :: Maybe (Tuple TypeTree (TypeTree -> TypeTree)), exprType :: MType }

type DivHole = TypeTree -> (TypeTree -> TypeTree) -> Div

type OpTuple = Tuple Op Meta

-- Tells, which nodes are to be marked as clicked or evaluated, if any.
type Highlight = { clicked :: Maybe Index, evaluated :: Maybe Index }

-- Given a Highlight value and the Meta information of a node, generated additional classes to highlight the node
highlight :: Highlight -> Meta -> List String
highlight { clicked: mi, evaluated: mj } (Meta m) = case Tuple (cmp mi) (cmp mj) of
  Tuple (Just true) (Just true) -> "clicked" : "evaluated" : Nil
  Tuple (Just true) _           -> singleton "clicked"
  Tuple _           (Just true) -> singleton "evaluated"
  _                             -> Nil
 where
   cmp :: Maybe Int -> Maybe Boolean
   cmp = map (\i -> m.index == i)

nodeHole :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> TypeTree -> (TypeTree -> TypeTree) -> Div
nodeHole content classes children expr hole =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: (Just (Tuple expr hole))
    , exprType: Nothing
    }
    (fromFoldable children)

typedNodeHole :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> MType -> TypeTree -> (TypeTree -> TypeTree) -> Div
typedNodeHole content classes children exprType expr hole =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: (Just (Tuple expr hole))
    , exprType: exprType
    }
    (fromFoldable children)

node :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> Div
node content classes children =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: Nothing
    , exprType: Nothing
    }
    (fromFoldable children)

typedNode :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> MType -> Div
typedNode content classes children exprType =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: Nothing
    , exprType: exprType
    }
    (fromFoldable children)

zipList :: forall a b z. ((a -> z) -> a -> b) -> (List a -> z) -> List a -> List b
zipList zipp hole Nil = Nil
zipList zipp hole (Cons a as) = Cons (zipp (\x -> hole $ Cons x as) a) (zipList zipp (hole <<< Cons a) as)

exprToDiv:: TypeTree -> Div
exprToDiv = go id
  where
    go :: (TypeTree -> TypeTree) -> TypeTree -> Div
    go hole      (Atom meta a)            = atom (getMetaMType meta) a
    go hole expr@(List meta ls)           = case toString ls of
                                           Nothing  -> list (getMetaMType meta) (zipList go (hole <<< List meta) ls) expr hole
                                           Just str -> typedNode ("\"" <> str <> "\"") ["list", "string"] [] (getMetaMType meta)
    go hole expr@(NTuple meta ls)         = ntuple (getMetaMType meta) (zipList go (hole <<< NTuple meta) ls) expr hole
    go hole expr@(Binary meta opTuple e1 e2) = binary (getMetaMType meta) opTuple
                                           (go (\e1 -> hole $ Binary meta opTuple e1 e2) e1)
                                           (go (\e2 -> hole $ Binary meta opTuple e1 e2) e2)
                                           expr hole
    go hole expr@(Unary meta opTuple e)   = unary (getMetaMType meta) opTuple (go (hole <<< Unary meta opTuple) e) expr hole
    go hole expr@(SectL meta e opTuple)   = sectl (getMetaMType meta) (go (\e -> hole $ SectL meta e opTuple) e) opTuple expr hole
    go hole expr@(SectR meta opTuple e)   = sectr (getMetaMType meta) opTuple (go (hole <<< SectR meta opTuple) e) expr hole
    go hole      (PrefixOp meta opTuple)  = prefixOp (getMetaMType meta) opTuple
    go hole expr@(IfExpr meta ce te ee)   = ifexpr (getMetaMType meta)
                                           (go (\ce -> hole $ IfExpr meta ce te ee) ce)
                                           (go (\te -> hole $ IfExpr meta ce te ee) te)
                                           (go (\ee -> hole $ IfExpr meta ce te ee) ee)
                                           expr hole
    go hole expr@(LetExpr meta bes body)  = letexpr (getMetaMType meta)
                                           (zipList
                                              (\listHole (Tuple b e) -> Tuple (binding b) (go (\x -> listHole $ Tuple b x) e))
                                              (\xs -> hole $ LetExpr meta xs body)
                                              bes)
                                           (go (\x -> hole $ LetExpr meta bes x) body)
                                           expr hole
    go hole expr@(Lambda meta binds body) = lambda (getMetaMType meta) (binding <$> binds) (go (hole <<< Lambda meta binds) body) expr hole

    go hole expr@(ArithmSeq meta start next end)
                                       = arithmseq (getMetaMType meta)
                                           (go (\x -> hole $ ArithmSeq meta x next end) start)
                                           (go (\x -> hole $ ArithmSeq meta start (Just x) end) <$> next)
                                           (go (\x -> hole $ ArithmSeq meta start next (Just x)) <$> end)
                                           expr hole

    go hole expr@(ListComp meta e qs)     = listcomp (getMetaMType meta)
                                           (go (\x -> hole $ ListComp meta x qs) e)
                                           (zipList qualToDiv (\xs -> hole $ ListComp meta e xs) qs)
                                           expr hole
      where
        qualToDiv :: (TypeQual -> TypeTree) -> TypeQual -> Div
        qualToDiv hole (Guard meta e) = guardQual (getMetaMType meta)           (go (\x -> hole $ Guard meta x) e)
        qualToDiv hole (Let meta b e) = letQual (getMetaMType meta) (binding b) (go (\x -> hole $ Let meta b x) e)
        qualToDiv hole (Gen meta b e) = genQual (getMetaMType meta) (binding b) (go (\x -> hole $ Gen meta b x) e)

    go hole expr@(App meta func args) = app (getMetaMType meta) (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App meta func args
        argsDivs = zipList go (hole <<< App meta func) args

guardQual :: MType -> Div -> Div
guardQual t guard = typedNode "" ["guard"] [guard] t

letQual :: MType -> Div -> Div -> Div
letQual t bind expr = typedNode "" ["let"] [letDiv, bind, eqDiv, expr] t
  where
    letDiv = node "let" ["keyword"] []
    eqDiv  = node "=" ["comma"] []

genQual :: MType -> Div -> Div -> Div
genQual t bind expr = typedNode "" ["gen"] [bind, arrow, expr] t
  where
    arrow = node "<-" ["separator"] []

atom :: MType -> Atom -> Div
atom t (AInt n) = typedNode (show n) ["atom", "num"] [] t
atom t (Bool b) = typedNode (if b then "True" else "False") ["atom", "bool"] [] t
atom t (Char c) = typedNode ("'" <> c <> "'") ["atom", "char"] [] t
atom t (Name n) = typedNode n ["atom", "name"] [] t
atom t (Constr n) = typedNode n ["atom", "name", "dataConstructor"] [] t

interleave :: forall a. a -> List a -> List a
interleave _ Nil          = Nil
interleave _ (Cons x Nil) = Cons x Nil
interleave a (Cons x xs)  = Cons x $ Cons a $ interleave a xs

listify :: String -> String -> String -> List Div -> List Div
listify b s e ls = (Cons begin (snoc (interleave sep ls) end))
  where
    begin = node b ["brace", "left"] []
    sep = node s ["separator", "comma"] []
    end = node e ["brace", "right"] []

list :: MType -> List Div -> DivHole
list t Nil = typedNodeHole "[]" ["list empty"] [] t
list t ls  = typedNodeHole "" ["list"] (listify "[" "," "]" ls) t

ntuple :: MType -> List Div -> DivHole
ntuple t ls = typedNodeHole "" ["tuple"] (listify "(" "," ")" ls) t

unpackOp :: OpTuple -> Op
unpackOp (Tuple op _) = op

opToDiv :: OpTuple -> Div
opToDiv (Tuple op (Meta meta)) = typedNode (pPrintOp op) ["op"] [] meta.mtype

binary :: MType -> OpTuple -> Div -> Div -> DivHole
binary binType op d1 d2 = typedNodeHole "" ["binary"] [d1, opToDiv op, d2] binType

openBrace :: Div
openBrace = node "(" ["brace", "left"] []

closeBrace :: Div
closeBrace = node ")" ["brace", "right"] []

unary :: MType -> OpTuple -> Div -> DivHole
unary t op div = typedNodeHole "" ["unary"] [openBrace, opToDiv op, div, closeBrace] t

sectl :: MType -> Div -> OpTuple -> DivHole
sectl t div op = typedNodeHole "" ["section"] [openBrace, div, opToDiv op, closeBrace] t

sectr :: MType -> OpTuple -> Div -> DivHole
sectr t op div = typedNodeHole "" ["section"] [openBrace, opToDiv op, div, closeBrace] t

prefixOp :: MType -> OpTuple -> Div
prefixOp binType op = typedNode "" ["prefixOp"] [openBrace, opToDiv op, closeBrace] binType

ifexpr :: MType -> Div -> Div -> Div -> DivHole
ifexpr t cd td ed = typedNodeHole "" ["if"] [ifDiv, cd, thenDiv, td, elseDiv, ed] t
  where
    ifDiv = node "if" ["keyword"] []
    thenDiv = node "then" ["keyword"] []
    elseDiv = node "else" ["keyword"] []

intersperse :: forall a. a -> List a -> List a
intersperse _ Nil          = Nil
intersperse _ (Cons a Nil) = Cons a Nil
intersperse s (Cons a as)  = Cons a $ Cons s $ intersperse s as

letexpr :: MType -> List (Tuple Div Div) -> Div -> DivHole
letexpr t binds expr = typedNodeHole "" ["letexpr"] ([letDiv] <> (intercalate [semi] (bind <$> binds)) <> [inDiv, expr]) t
  where
    letDiv = node "let" ["keyword"] []
    inDiv  = node "in" ["keyword"] []
    semi   = node ";" ["comma"] []
    equal  = node "=" ["comma"] []
    bind :: Tuple Div Div -> Array Div
    bind (Tuple b e) = [node "" [] [b, equal, e]]

listcomp :: MType -> Div -> List Div -> DivHole
listcomp t expr quals = typedNodeHole "" ["listcomp", "list"] ([open, expr, pipe] <> Arr.fromFoldable (intersperse comma quals) <> [close]) t
  where
    open  = node "[" ["brace", "left"] []
    close = node "]" ["brace", "right"] []
    pipe  = node "|" ["brace"] []
    comma = node "," ["comma"] []

lambda :: MType -> List Div -> Div -> DivHole
lambda t params body = typedNodeHole "" ["lambda"] (open : bslash : params <> (arrow : body : close : Nil)) t
  where
    open = node "(" ["brace", "left"] []
    bslash = node "\\" ["backslash", "separator"] []
    arrow = node "->" ["arrow", "separator"] []
    close = node ")" ["brace", "right"] []

app :: MType -> Div -> List Div -> DivHole
app t func args = typedNodeHole "" ["app"] (Cons func args) t

arithmseq :: MType -> Div -> Maybe Div -> Maybe Div -> DivHole
arithmseq t start mnext mend = typedNodeHole "" ["arithmseq", "list"] ([open, start] <> commaNext <> [dots] <> end <> [close]) t
 where
    open      = node "[" ["brace", "left"] []
    comma     = node "," ["comma"] []
    commaNext = maybe [] (\next -> [comma, next]) mnext
    dots      = node ".." ["dots", "comma"] []
    end       = fromMaybe mend
    close     = node "]" ["brace", "right"] []

binding :: TypedBinding -> Div
binding (Lit t a)         = typedNode "" ["binding", "lit"] [atom (getMetaMType t) a] (getMetaMType t)
binding (ConsLit t b1 b2) = typedNode "" ["binding", "conslit"] (listify "(" ":" ")" (binding b1 : binding b2 : Nil)) (getMetaMType t)
binding (ListLit t ls)    = typedNode "" ["binding", "listlit"] (listify "[" "," "]" (binding <$> ls)) (getMetaMType t)
binding (NTupleLit t ls)   = typedNode "" ["binding", "tuplelit"] (listify "(" "," ")" (binding <$> ls)) (getMetaMType t)
binding (ConstrLit t constr) = case constr of
  PrefixDataConstr name _ ls -> typedNode ""
                                  ["binding", "constrlit"]
                                  (atom (getMetaMType t) (Name name) : (binding <$> ls))
                                  (getMetaMType t)
  InfixDataConstr name _ _ b1 b2 -> typedNode ""
                                      ["binding", "constrlit"]
                                      [binding b1, atom (getMetaMType t) (Name name), binding b2]
                                      (getMetaMType t)

type Callback = forall eff. TypeTree -> (TypeTree -> TypeTree) -> (J.JQueryEvent -> J.JQuery -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit)

-- | Create a type div with the pretty printed type as content.
createTypeDiv :: forall eff. MType -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
createTypeDiv (Just (TypeError typeError)) = makeDiv (prettyPrintTypeError typeError) ["typeContainer", "hasTypeError"]
createTypeDiv mType = makeDiv (" :: " <> maybe "" prettyPrintType mType) ["typeContainer"]

-- | Add a type tooltip to the given div.
addTypeTooltip :: forall eff. MType -> J.JQuery -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
addTypeTooltip (Just (TypeError typeError)) div = J.setAttr "title" (prettyPrintTypeError typeError) div
addTypeTooltip mType div = J.setAttr "title" (" :: " <> maybe "" prettyPrintType mType) div

-- | Return true, if the first list of classes contains a class from the second list.
oneOfClasses :: forall f1 f2. (Foldable f1, Foldable f2) => f1 String -> f2 String -> Boolean
oneOfClasses cs1 cs2 = size (set1 `intersection` set2) > 0
  where
  set1 = Set.fromFoldable cs1
  set2 = Set.fromFoldable cs2

-- | Given a list of classes as well as the expression type determine if the expression should have
-- | a type div.
needsTypeContainer :: forall f. Foldable f => f String -> MType -> Boolean
needsTypeContainer _ Nothing = false
needsTypeContainer classes (Just t) = decideByClass classes && decideByType t
    where
    decideByType _ = true
    decideByClass classes = if oneOfClasses ["op", "binding", "num", "char", "bool", "gen", "guard", "let"] classes then false else true

-- | Return true if the given `MType` represents a type error.
isTypeError :: MType -> Boolean
isTypeError (Just (TypeError _)) = true
isTypeError _ = false

divToJQuery :: forall eff. Boolean -> Callback -> Div -> Eff (dom :: DOM, console :: CONSOLE | eff) J.JQuery
divToJQuery isTopLevelDiv callback (Node { content: content, classes: classes, zipper: zipper, exprType: exprType } children) = do
  let needsContainer = needsTypeContainer classes exprType || isTopLevelDiv || isTypeError exprType
  let isTyped = isJust exprType

  container <- makeDiv "" ["container"]
  div <- makeDiv content classes

  -- if needsContainer
  --   then do
  --     typeDiv <- createTypeDiv exprType
  --     J.append typeDiv container
  --     J.append div container
  --     J.addClass "hasTypeContainer" div
  --   else pure unit

  J.append div container

  -- if isTyped
  --   then addTypeTooltip exprType div
  --   else pure unit

  for children (divToJQuery false callback >=> flip J.append div)
  case zipper of
    Nothing                -> pure unit
    Just (Tuple expr hole) -> do
      J.on "click" (callback expr hole) div
      J.on "mouseover" (callback expr hole) div
      J.on "mouseout" (callback expr hole) div
      pure unit

  if needsContainer
    then pure container
    else pure div

toString :: List TypeTree -> Maybe String
toString ls = Str.fromCharArray <$> go [] ls
  where
    go :: Array Char -> List TypeTree -> Maybe (Array Char)
    go acc (Cons (Atom _ (Char c)) rs) = case Str.toChar c of
                                           Just char -> go (Arr.snoc acc char) rs
                                           Nothing   -> Nothing
    go []  Nil                         = Nothing
    go acc Nil                         = Just acc
    go _   _                           = Nothing

type Class = String

makeDiv :: forall f eff. Foldable f => String -> f Class -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for_ classes (flip J.addClass d)
  pure d

module Web where

import Prelude
import Data.Foldable (class Foldable, intercalate)
import Data.Unfoldable (fromMaybe)
import Data.List (List(Nil, Cons), snoc, fromFoldable, (:), singleton)
import Data.Set (intersection, size)
import Data.Set as Set
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Tuple (Tuple(..))
import Data.Traversable (for, for_)
import Data.Array as Arr
import Data.String as Str

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.JQuery as J
import DOM (DOM)

import AST (Atom(..), Binding(..), MType, Op, QualTree(..), Tree(..), TypeTree, TypedBinding, Meta(..), Index,
            Type(..), TypeQual, DataConstr(..), pPrintOp, prettyPrintType, prettyPrintTypeError, getMetaMType)

import AST as AST

data RoseTree a = Node a (List (RoseTree a))

type Div = RoseTree { content :: String, classes :: (List String), zipper :: Maybe (Tuple TypeTree (TypeTree -> TypeTree)), exprType :: MType }

type DivHole = TypeTree -> (TypeTree -> TypeTree) -> Div

type OpTuple = Tuple Op Meta

-- Tells, which nodes are to be marked as clicked or evaluated, if any.
type Highlight = { clicked :: Maybe Index, evaluated :: Maybe Index }

-- Given a Highlight value and the Meta information of a node, generated additional classes to highlight the node
highlight :: Highlight -> Meta -> List String
highlight { clicked: mi, evaluated: mj } (Meta m) = case Tuple (cmp mi) (cmp mj) of
  Tuple (Just true) (Just true) -> "clicked" : "evaluated" : Nil
  Tuple (Just true) _           -> singleton "clicked"
  Tuple _           (Just true) -> singleton "evaluated"
  _                             -> Nil
 where
   cmp = map (\i -> m.index == i)

nodeHole :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> TypeTree -> (TypeTree -> TypeTree) -> Div
nodeHole content classes children expr hole =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: (Just (Tuple expr hole))
    , exprType: Nothing
    }
    (fromFoldable children)

typedNodeHole :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> MType -> TypeTree -> (TypeTree -> TypeTree) -> Div
typedNodeHole content classes children exprType expr hole =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: (Just (Tuple expr hole))
    , exprType: exprType
    }
    (fromFoldable children)

node :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> Div
node content classes children =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: Nothing
    , exprType: Nothing
    }
    (fromFoldable children)

typedNode :: forall f1 f2. (Foldable f1, Foldable f2) => String -> f1 String -> f2 Div -> MType -> Div
typedNode content classes children exprType =
  Node
    { content: content
    , classes: (fromFoldable classes)
    , zipper: Nothing
    , exprType: exprType
    }
    (fromFoldable children)

zipList :: forall a b z. ((a -> z) -> a -> b) -> (List a -> z) -> List a -> List b
zipList zipp hole Nil = Nil
zipList zipp hole (Cons a as) = Cons (zipp (\x -> hole $ Cons x as) a) (zipList zipp (hole <<< Cons a) as)

exprToDiv:: TypeTree -> Div
exprToDiv = go id
  where
    go :: (TypeTree -> TypeTree) -> TypeTree -> Div
    go hole      (Atom meta a)            = atom (getMetaMType meta) a
    go hole expr@(List meta ls)           = case toString ls of
                                           Nothing  -> list (getMetaMType meta) (zipList go (hole <<< List meta) ls) expr hole
                                           Just str -> typedNode ("\"" <> str <> "\"") ["list", "string"] [] (getMetaMType meta)
    go hole expr@(NTuple meta ls)         = ntuple (getMetaMType meta) (zipList go (hole <<< NTuple meta) ls) expr hole
    go hole expr@(Binary meta opTuple e1 e2) = binary (getMetaMType meta) opTuple
                                           (go (\e1 -> hole $ Binary meta opTuple e1 e2) e1)
                                           (go (\e2 -> hole $ Binary meta opTuple e1 e2) e2)
                                           expr hole
    go hole expr@(Unary meta opTuple e)   = unary (getMetaMType meta) opTuple (go (hole <<< Unary meta opTuple) e) expr hole
    go hole expr@(SectL meta e opTuple)   = sectl (getMetaMType meta) (go (\e -> hole $ SectL meta e opTuple) e) opTuple expr hole
    go hole expr@(SectR meta opTuple e)   = sectr (getMetaMType meta) opTuple (go (hole <<< SectR meta opTuple) e) expr hole
    go hole      (PrefixOp meta opTuple)  = prefixOp (getMetaMType meta) opTuple
    go hole expr@(IfExpr meta ce te ee)   = ifexpr (getMetaMType meta)
                                           (go (\ce -> hole $ IfExpr meta ce te ee) ce)
                                           (go (\te -> hole $ IfExpr meta ce te ee) te)
                                           (go (\ee -> hole $ IfExpr meta ce te ee) ee)
                                           expr hole
    go hole expr@(LetExpr meta bes body)  = letexpr (getMetaMType meta)
                                           (zipList
                                              (\listHole (Tuple b e) -> Tuple (binding b) (go (\x -> listHole $ Tuple b x) e))
                                              (\xs -> hole $ LetExpr meta xs body)
                                              bes)
                                           (go (\x -> hole $ LetExpr meta bes x) body)
                                           expr hole
    go hole expr@(Lambda meta binds body) = lambda (getMetaMType meta) (binding <$> binds) (go (hole <<< Lambda meta binds) body) expr hole

    go hole expr@(ArithmSeq meta start next end)
                                       = arithmseq (getMetaMType meta)
                                           (go (\x -> hole $ ArithmSeq meta x next end) start)
                                           (go (\x -> hole $ ArithmSeq meta start (Just x) end) <$> next)
                                           (go (\x -> hole $ ArithmSeq meta start next (Just x)) <$> end)
                                           expr hole

    go hole expr@(ListComp meta e qs)     = listcomp (getMetaMType meta)
                                           (go (\x -> hole $ ListComp meta x qs) e)
                                           (zipList qualToDiv (\xs -> hole $ ListComp meta e xs) qs)
                                           expr hole
      where
        qualToDiv :: (TypeQual -> TypeTree) -> TypeQual -> Div
        qualToDiv hole (Guard meta e) = guardQual (getMetaMType meta)           (go (\x -> hole $ Guard meta x) e)
        qualToDiv hole (Let meta b e) = letQual (getMetaMType meta) (binding b) (go (\x -> hole $ Let meta b x) e)
        qualToDiv hole (Gen meta b e) = genQual (getMetaMType meta) (binding b) (go (\x -> hole $ Gen meta b x) e)

    go hole expr@(App meta func args) = app (getMetaMType meta) (go funcHole func) argsDivs expr hole
      where
        funcHole func = hole $ App meta func args
        argsDivs = zipList go (hole <<< App meta func) args

guardQual :: MType -> Div -> Div
guardQual t guard = typedNode "" ["guard"] [guard] t

letQual :: MType -> Div -> Div -> Div
letQual t bind expr = typedNode "" ["let"] [letDiv, bind, eqDiv, expr] t
  where
    letDiv = node "let" ["keyword"] []
    eqDiv  = node "=" ["comma"] []

genQual :: MType -> Div -> Div -> Div
genQual t bind expr = typedNode "" ["gen"] [bind, arrow, expr] t
  where
    arrow = node "<-" ["separator"] []

atom :: MType -> Atom -> Div
atom t (AInt n) = typedNode (show n) ["atom", "num"] [] t
atom t (Bool b) = typedNode (if b then "True" else "False") ["atom", "bool"] [] t
atom t (Char c) = typedNode ("'" <> c <> "'") ["atom", "char"] [] t
atom t (Name n) = typedNode n ["atom", "name"] [] t
atom t (Constr n) = typedNode n ["atom", "name", "dataConstructor"] [] t

interleave :: forall a. a -> List a -> List a
interleave _ Nil          = Nil
interleave _ (Cons x Nil) = Cons x Nil
interleave a (Cons x xs)  = Cons x $ Cons a $ interleave a xs

listify :: String -> String -> String -> List Div -> List Div
listify b s e ls = (Cons begin (snoc (interleave sep ls) end))
  where
    begin = node b ["brace", "left"] []
    sep = node s ["separator", "comma"] []
    end = node e ["brace", "right"] []

list :: MType -> List Div -> DivHole
list t Nil = typedNodeHole "[]" ["list empty"] [] t
list t ls  = typedNodeHole "" ["list"] (listify "[" "," "]" ls) t

ntuple :: MType -> List Div -> DivHole
ntuple t ls = typedNodeHole "" ["tuple"] (listify "(" "," ")" ls) t

unpackOp :: OpTuple -> Op
unpackOp (Tuple op _) = op

opToDiv :: OpTuple -> Div
opToDiv (Tuple op (Meta meta)) = typedNode (pPrintOp op) ["op"] [] meta.mtype

binary :: MType -> OpTuple -> Div -> Div -> DivHole
binary binType op d1 d2 = typedNodeHole "" ["binary"] [d1, opToDiv op, d2] binType

openBrace :: Div
openBrace = node "(" ["brace", "left"] []

closeBrace :: Div
closeBrace = node ")" ["brace", "right"] []

unary :: MType -> OpTuple -> Div -> DivHole
unary t op div = typedNodeHole "" ["unary"] [openBrace, opToDiv op, div, closeBrace] t

sectl :: MType -> Div -> OpTuple -> DivHole
sectl t div op = typedNodeHole "" ["section"] [openBrace, div, opToDiv op, closeBrace] t

sectr :: MType -> OpTuple -> Div -> DivHole
sectr t op div = typedNodeHole "" ["section"] [openBrace, opToDiv op, div, closeBrace] t

prefixOp :: MType -> OpTuple -> Div
prefixOp binType op = typedNode "" ["prefixOp"] [openBrace, opToDiv op, closeBrace] binType

ifexpr :: MType -> Div -> Div -> Div -> DivHole
ifexpr t cd td ed = typedNodeHole "" ["if"] [ifDiv, cd, thenDiv, td, elseDiv, ed] t
  where
    ifDiv = node "if" ["keyword"] []
    thenDiv = node "then" ["keyword"] []
    elseDiv = node "else" ["keyword"] []

intersperse :: forall a. a -> List a -> List a
intersperse _ Nil          = Nil
intersperse _ (Cons a Nil) = Cons a Nil
intersperse s (Cons a as)  = Cons a $ Cons s $ intersperse s as

letexpr :: MType -> List (Tuple Div Div) -> Div -> DivHole
letexpr t binds expr = typedNodeHole "" ["letexpr"] ([letDiv] <> (intercalate [semi] (bind <$> binds)) <> [inDiv, expr]) t
  where
    letDiv = node "let" ["keyword"] []
    inDiv  = node "in" ["keyword"] []
    semi   = node ";" ["comma"] []
    equal  = node "=" ["comma"] []
    bind :: Tuple Div Div -> Array Div
    bind (Tuple b e) = [node "" [] [b, equal, e]]

listcomp :: MType -> Div -> List Div -> DivHole
listcomp t expr quals = typedNodeHole "" ["listcomp", "list"] ([open, expr, pipe] <> Arr.fromFoldable (intersperse comma quals) <> [close]) t
  where
    open  = node "[" ["brace", "left"] []
    close = node "]" ["brace", "right"] []
    pipe  = node "|" ["brace"] []
    comma = node "," ["comma"] []

lambda :: MType -> List Div -> Div -> DivHole
lambda t params body = typedNodeHole "" ["lambda"] (open : bslash : params <> (arrow : body : close : Nil)) t
  where
    open = node "(" ["brace", "left"] []
    bslash = node "\\" ["backslash", "separator"] []
    arrow = node "->" ["arrow", "separator"] []
    close = node ")" ["brace", "right"] []

app :: MType -> Div -> List Div -> DivHole
app t func args = typedNodeHole "" ["app"] (Cons func args) t

arithmseq :: MType -> Div -> Maybe Div -> Maybe Div -> DivHole
arithmseq t start mnext mend = typedNodeHole "" ["arithmseq", "list"] ([open, start] <> commaNext <> [dots] <> end <> [close]) t
 where
    open      = node "[" ["brace", "left"] []
    comma     = node "," ["comma"] []
    commaNext = maybe [] (\next -> [comma, next]) mnext
    dots      = node ".." ["dots", "comma"] []
    end       = fromMaybe mend
    close     = node "]" ["brace", "right"] []

binding :: TypedBinding -> Div
binding (Lit t a)         = typedNode "" ["binding", "lit"] [atom (getMetaMType t) a] (getMetaMType t)
binding (ConsLit t b1 b2) = typedNode "" ["binding", "conslit"] (listify "(" ":" ")" (binding b1 : binding b2 : Nil)) (getMetaMType t)
binding (ListLit t ls)    = typedNode "" ["binding", "listlit"] (listify "[" "," "]" (binding <$> ls)) (getMetaMType t)
binding (NTupleLit t ls)   = typedNode "" ["binding", "tuplelit"] (listify "(" "," ")" (binding <$> ls)) (getMetaMType t)
binding (ConstrLit t constr) = case constr of
  PrefixDataConstr name _ ls -> typedNode ""
                                  ["binding", "constrlit"]
                                  (atom (getMetaMType t) (Name name) : (binding <$> ls))
                                  (getMetaMType t)
  InfixDataConstr name _ _ b1 b2 -> typedNode ""
                                      ["binding", "constrlit"]
                                      [binding b1, atom (getMetaMType t) (Name name), binding b2]
                                      (getMetaMType t)

type Callback = forall eff. TypeTree -> (TypeTree -> TypeTree) -> (J.JQueryEvent -> J.JQuery -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit)

-- | Create a type div with the pretty printed type as content.
createTypeDiv :: forall eff. MType -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
createTypeDiv (Just (TypeError typeError)) = makeDiv (prettyPrintTypeError typeError) ["typeContainer", "hasTypeError"]
createTypeDiv mType = makeDiv (" :: " <> maybe "" prettyPrintType mType) ["typeContainer"]

-- | Add a type tooltip to the given div.
addTypeTooltip :: forall eff. MType -> J.JQuery -> Eff (dom :: DOM , console :: CONSOLE| eff) Unit
addTypeTooltip (Just (TypeError typeError)) div = J.setAttr "title" (prettyPrintTypeError typeError) div
addTypeTooltip mType div = J.setAttr "title" (" :: " <> maybe "" prettyPrintType mType) div

-- | Return true, if the first list of classes contains a class from the second list.
oneOfClasses :: forall f1 f2. (Foldable f1, Foldable f2) => f1 String -> f2 String -> Boolean
oneOfClasses cs1 cs2 = size (set1 `intersection` set2) > 0
  where
  set1 = Set.fromFoldable cs1
  set2 = Set.fromFoldable cs2

-- | Given a list of classes as well as the expression type determine if the expression should have
-- | a type div.
needsTypeContainer :: forall f. Foldable f => f String -> MType -> Boolean
needsTypeContainer _ Nothing = false
needsTypeContainer classes (Just t) = decideByClass classes && decideByType t
    where
    decideByType _ = true
    decideByClass classes = if oneOfClasses ["op", "binding", "num", "char", "bool", "gen", "guard", "let"] classes then false else true

-- | Return true if the given `MType` represents a type error.
isTypeError :: MType -> Boolean
isTypeError (Just (TypeError _)) = true
isTypeError _ = false

divToJQuery :: forall eff. Boolean -> Callback -> Div -> Eff (dom :: DOM, console :: CONSOLE | eff) J.JQuery
divToJQuery isTopLevelDiv callback (Node { content: content, classes: classes, zipper: zipper, exprType: exprType } children) = do
  let needsContainer = needsTypeContainer classes exprType || isTopLevelDiv || isTypeError exprType
  let isTyped = isJust exprType

  container <- makeDiv "" ["container"]
  div <- makeDiv content classes

  -- if needsContainer
  --   then do
  --     typeDiv <- createTypeDiv exprType
  --     J.append typeDiv container
  --     J.append div container
  --     J.addClass "hasTypeContainer" div
  --   else pure unit

  J.append div container

  -- if isTyped
  --   then addTypeTooltip exprType div
  --   else pure unit

  for children (divToJQuery false callback >=> flip J.append div)
  case zipper of
    Nothing                -> pure unit
    Just (Tuple expr hole) -> do
      J.on "click" (callback expr hole) div
      J.on "mouseover" (callback expr hole) div
      J.on "mouseout" (callback expr hole) div
      pure unit

  if needsContainer
    then pure container
    else pure div

toString :: List TypeTree -> Maybe String
toString ls = Str.fromCharArray <$> go [] ls
  where
    go :: Array Char -> List TypeTree -> Maybe (Array Char)
    go acc (Cons (Atom _ (Char c)) rs) = case Str.toChar c of
                                           Just char -> go (Arr.snoc acc char) rs
                                           Nothing   -> Nothing
    go []  Nil                         = Nothing
    go acc Nil                         = Just acc
    go _   _                           = Nothing

type Class = String

makeDiv :: forall f eff. Foldable f => String -> f Class -> Eff (dom :: DOM , console :: CONSOLE| eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for_ classes (flip J.addClass d)
  pure d


update tests

update tests

module Test.Main where

import Prelude

import Effect.Console (log)
import Effect.Exception (Error, message, stack)
import Effect.Promise as Promise
import Effect.Promise.Console as Console
import Effect.Promise.Nonstandard as NS
import Data.Maybe (fromMaybe)
import Data.Time.Duration (Milliseconds(..))
import Effect (Effect)

type Promise a = Promise.Deferred => Promise.Promise a

print :: String -> Promise Unit
print msg = do
  Console.log "\n"
  Console.log msg
  Console.log "-------------"

main :: Effect Unit
main = Promise.runPromise onSuccess onError promiseTests

promiseTests :: Promise Unit
promiseTests = do
  print "Basic do notation:"
  doTest

  print "Basic promise delay"
  promDelay

  print "Apply test"
  promApply

  print "Nonstandard methods:"
  NS.finally nonstandardTest (log "'finally' called")

doTest :: Promise Unit
doTest = do
  msg <- pure "Now I'm here"
  Console.log "I'm here"
  Promise.delay (Milliseconds 1000.0) unit
  Console.log msg

noopPrep :: Promise String
noopPrep = Promise.promise k
  where
  k onSucc _ = onSucc "this shouldn't be shown on console"

noop :: Promise Unit
noop = do
  msg <- noopPrep
  Console.log msg

promDelay :: Promise Unit
promDelay = do
  p1
  p2
  p3
  where
    p1 :: Promise Unit
    p1 = do
      Console.log "one"
      Promise.delay (Milliseconds 1000.0) unit
      Console.log "two"
    p2 :: Promise Unit
    p2 = do
      Promise.delay (Milliseconds 1000.0) unit
      Console.log "three"
    p3 :: Promise Unit
    p3 = do
      Promise.delay (Milliseconds 1000.0) unit
      Console.log "four"

promApply :: Promise Unit
promApply = p1 *> p2 *> p3
  where
    p1 :: Promise Unit
    p1 = do
      Console.log "<*> is"
      Promise.delay (Milliseconds 1000.0) unit
      Console.log "done"
    p2 :: Promise Unit
    p2 = do
      Promise.delay (Milliseconds 3000.0) unit
      Console.log "parallel"
    p3 :: Promise Unit
    p3 = do
      Promise.delay (Milliseconds 2000.0) unit
      Console.log "in"

nonstandardTest :: Promise Unit
nonstandardTest = Promise.resolve "nonstandard test" # Promise.then' \ a -> Console.log a

onError :: Error -> Effect Unit
onError e
  = log $ "Uh oh, an error happened! " <>
    message e <>
    "\nStack: " <>
    fromMaybe "No stack." (stack e)

onSuccess :: forall a. a -> Effect Unit
onSuccess _ = log "Hello from Eff!"

module Test.Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (Error, message, stack)
import Control.Monad.Promise as Promise
import Control.Monad.Promise.Console as Console
import Control.Monad.Promise.Nonstandard as NS
import Data.Maybe (fromMaybe)
import Data.Time.Duration (Milliseconds(..))

type AppEff = (console :: CONSOLE)

type Promise a = Promise.Deferred => Promise.Promise AppEff a

print :: String -> Promise Unit
print msg = do
  Console.log "\n"
  Console.log msg
  Console.log "-------------"

main :: Eff AppEff Unit
main = Promise.runPromise onSuccess onError promiseTests

promiseTests :: Promise Unit
promiseTests = do
  print "Basic do notation:"
  doTest

  print "Basic promise delay"
  promDelay

  print "Apply test"
  promApply

  print "Nonstandard methods:"
  NS.finally nonstandardTest (log "'finally' called")

doTest :: Promise Unit
doTest = do
  msg <- pure "Now I'm here"
  Console.log "I'm here"
  Promise.delay (Milliseconds 1000.0) unit
  Console.log msg

noopPrep :: Promise String
noopPrep = Promise.promise k
  where
  k onSucc _ = onSucc "this shouldn't be shown on console"

noop :: Promise Unit
noop = do
  msg <- noopPrep
  Console.log msg

promDelay :: Promise Unit
promDelay = do
  p1
  p2
  p3
  where
    p1 :: Promise Unit
    p1 = do
      Console.log "one"
      Promise.delay (Milliseconds 1000.0) unit
      Console.log "two"
    p2 :: Promise Unit
    p2 = do
      Promise.delay (Milliseconds 1000.0) unit
      Console.log "three"
    p3 :: Promise Unit
    p3 = do
      Promise.delay (Milliseconds 1000.0) unit
      Console.log "four"

promApply :: Promise Unit
promApply = p1 *> p2 *> p3
  where
    p1 :: Promise Unit
    p1 = do
      Console.log "<*> is"
      Promise.delay (Milliseconds 1000.0) unit
      Console.log "done"
    p2 :: Promise Unit
    p2 = do
      Promise.delay (Milliseconds 3000.0) unit
      Console.log "parallel"
    p3 :: Promise Unit
    p3 = do
      Promise.delay (Milliseconds 2000.0) unit
      Console.log "in"

nonstandardTest :: Promise Unit
nonstandardTest = Promise.resolve "nonstandard test" # Promise.then' \ a -> Console.log a

onError :: forall a r. Error -> Eff (console :: CONSOLE | r) Unit
onError e
  = log $ "Uh oh, an error happened! " <>
    message e <>
    "\nStack: " <>
    fromMaybe "No stack." (stack e)

onSuccess :: forall a r. a -> Eff (console :: CONSOLE | r) Unit
onSuccess _ = log "Hello from Eff!"


Add Arb/Coarb instances for all data dependencies

module Test.QuickCheck.Arbitrary where

import Prelude

import Data.Char (toCharCode, fromCharCode)
import Data.Either (Either(..))
import Data.Foldable (foldl)
import Data.Identity (Identity(..))
import Data.Int (fromNumber, toNumber)
import Data.Lazy (Lazy(), defer, force)
import Data.List (List(..))
import Data.Maybe (Maybe(..))
import Data.String (charCodeAt, fromCharArray, split)
import Data.Tuple (Tuple(..))
import Test.QuickCheck.Gen

-- | The `Arbitrary` class represents those types whose values can be
-- | _randomly-generated_.
-- |
-- | `arbitrary` uses the `Gen` monad to express a random generator for
-- | the type `t`. Combinators in the `Test.QuickCheck.Gen`
-- | module can be used to construct random generators.
class Arbitrary t where
  arbitrary :: Gen t

-- | The `Coarbitrary` class represents types which appear on the left of
-- | an `Arbitrary` function arrow.
-- |
-- | To construct an `Arbitrary` instance for the type `a -> b`, we need to
-- | use the input of type `a` to _perturb_ a random generator for `b`. This
-- | is the role of the `coarbitrary` function.
-- |
-- | `Coarbitrary` instances can be written using the `perturbGen` function.
class Coarbitrary t where
  coarbitrary :: forall r. t -> Gen r -> Gen r

instance arbBoolean :: Arbitrary Boolean where
  arbitrary = do
    n <- uniform
    return $ (n * 2.0) < 1.0

instance coarbBoolean :: Coarbitrary Boolean where
  coarbitrary true = perturbGen 1.0
  coarbitrary false = perturbGen 2.0

instance arbNumber :: Arbitrary Number where
  arbitrary = uniform

instance coarbNumber :: Coarbitrary Number where
  coarbitrary = perturbGen

instance arbInt :: Arbitrary Int where
  arbitrary = chooseInt (-1000000) 1000000

instance coarbInt :: Coarbitrary Int where
  coarbitrary = perturbGen <<< toNumber

instance arbString :: Arbitrary String where
  arbitrary = fromCharArray <$> arbitrary

instance coarbString :: Coarbitrary String where
  coarbitrary s = coarbitrary $ (charCodeAt zero <$> split "" s)

instance arbChar :: Arbitrary Char where
  arbitrary = fromCharCode <$> chooseInt 0 65536

instance coarbChar :: Coarbitrary Char where
  coarbitrary c = coarbitrary $ toCharCode c

instance arbUnit :: Arbitrary Unit where
  arbitrary = return unit

instance coarbUnit :: Coarbitrary Unit where
  coarbitrary _ = perturbGen 1.0

instance arbOrdering :: Arbitrary Ordering where
  arbitrary = oneOf (pure LT) [pure EQ, pure GT]

instance coarbOrdering :: Coarbitrary Ordering where
  coarbitrary LT = perturbGen 1.0
  coarbitrary EQ = perturbGen 2.0
  coarbitrary GT = perturbGen 3.0

instance arbArray :: (Arbitrary a) => Arbitrary (Array a) where
  arbitrary = arrayOf arbitrary

instance coarbArray :: (Coarbitrary a) => Coarbitrary (Array a) where
  coarbitrary = foldl (\f x -> f <<< coarbitrary x) id

instance arbFunction :: (Coarbitrary a, Arbitrary b) => Arbitrary (a -> b) where
  arbitrary = repeatable (\a -> coarbitrary a arbitrary)

instance coarbFunction :: (Arbitrary a, Coarbitrary b) => Coarbitrary (a -> b) where
  coarbitrary f gen = do
    xs <- arbitrary
    coarbitrary (map f (xs :: Array a)) gen

instance arbTuple :: (Arbitrary a, Arbitrary b) => Arbitrary (Tuple a b) where
  arbitrary = Tuple <$> arbitrary <*> arbitrary

instance coarbTuple :: (Coarbitrary a, Coarbitrary b) => Coarbitrary (Tuple a b) where
  coarbitrary (Tuple a b) = coarbitrary a >>> coarbitrary b

instance arbMaybe :: (Arbitrary a) => Arbitrary (Maybe a) where
  arbitrary = do
    b <- arbitrary
    if b then pure Nothing else Just <$> arbitrary

instance coarbMaybe :: (Coarbitrary a) => Coarbitrary (Maybe a) where
  coarbitrary Nothing = perturbGen 1.0
  coarbitrary (Just a) = coarbitrary a

instance arbEither :: (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where
  arbitrary = do
    b <- arbitrary
    if b then Left <$> arbitrary else Right <$> arbitrary

instance coarbEither :: (Coarbitrary a, Coarbitrary b) => Coarbitrary (Either a b) where
  coarbitrary (Left a)  = coarbitrary a
  coarbitrary (Right b) = coarbitrary b

instance arbitraryList :: (Arbitrary a) => Arbitrary (List a) where
  arbitrary = sized \n -> chooseInt zero n >>= flip listOf arbitrary

instance coarbList :: (Coarbitrary a) => Coarbitrary (List a) where
  coarbitrary = foldl (\f x -> f <<< coarbitrary x) id

instance arbitraryIdentity :: (Arbitrary a) => Arbitrary (Identity a) where
  arbitrary = Identity <$> arbitrary

instance coarbIdentity :: (Coarbitrary a) => Coarbitrary (Identity a) where
  coarbitrary (Identity a) = coarbitrary a

instance arbitraryLazy :: (Arbitrary a) => Arbitrary (Lazy a) where
  arbitrary = arbitrary >>= pure <<< defer <<< const

instance coarbLazy :: (Coarbitrary a) => Coarbitrary (Lazy a) where
  coarbitrary a = coarbitrary (force a)

module Test.QuickCheck.Arbitrary where

import Prelude

import Data.Char (toCharCode, fromCharCode)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.String (charCodeAt, fromCharArray, split)
import Data.Tuple (Tuple(..))
import Data.Int (fromNumber, toNumber)
import Data.Foldable (foldl)
import Test.QuickCheck.Gen

-- | The `Arbitrary` class represents those types whose values can be
-- | _randomly-generated_.
-- |
-- | `arbitrary` uses the `Gen` monad to express a random generator for
-- | the type `t`. Combinators in the `Test.QuickCheck.Gen`
-- | module can be used to construct random generators.
class Arbitrary t where
  arbitrary :: Gen t

-- | The `Coarbitrary` class represents types which appear on the left of
-- | an `Arbitrary` function arrow.
-- |
-- | To construct an `Arbitrary` instance for the type `a -> b`, we need to
-- | use the input of type `a` to _perturb_ a random generator for `b`. This
-- | is the role of the `coarbitrary` function.
-- |
-- | `Coarbitrary` instances can be written using the `perturbGen` function.
class Coarbitrary t where
  coarbitrary :: forall r. t -> Gen r -> Gen r

instance arbBoolean :: Arbitrary Boolean where
  arbitrary = do
    n <- uniform
    return $ (n * 2.0) < 1.0

instance coarbBoolean :: Coarbitrary Boolean where
  coarbitrary true = perturbGen 1.0
  coarbitrary false = perturbGen 2.0

instance arbNumber :: Arbitrary Number where
  arbitrary = uniform

instance coarbNumber :: Coarbitrary Number where
  coarbitrary = perturbGen

instance arbInt :: Arbitrary Int where
  arbitrary = chooseInt (-1000000) 1000000

instance coarbInt :: Coarbitrary Int where
  coarbitrary = perturbGen <<< toNumber

instance arbString :: Arbitrary String where
  arbitrary = fromCharArray <$> arbitrary

instance coarbString :: Coarbitrary String where
  coarbitrary s = coarbitrary $ (charCodeAt zero <$> split "" s)

instance arbChar :: Arbitrary Char where
  arbitrary = fromCharCode <$> chooseInt 0 65536

instance coarbChar :: Coarbitrary Char where
  coarbitrary c = coarbitrary $ toCharCode c

instance arbUnit :: Arbitrary Unit where
  arbitrary = return unit

instance coarbUnit :: Coarbitrary Unit where
  coarbitrary _ = perturbGen 1.0

instance arbOrdering :: Arbitrary Ordering where
  arbitrary = oneOf (pure LT) [pure EQ, pure GT]

instance coarbOrdering :: Coarbitrary Ordering where
  coarbitrary LT = perturbGen 1.0
  coarbitrary EQ = perturbGen 2.0
  coarbitrary GT = perturbGen 3.0

instance arbArray :: (Arbitrary a) => Arbitrary (Array a) where
  arbitrary = arrayOf arbitrary

instance coarbArray :: (Coarbitrary a) => Coarbitrary (Array a) where
  coarbitrary = foldl (\f x -> f <<< coarbitrary x) id

instance arbFunction :: (Coarbitrary a, Arbitrary b) => Arbitrary (a -> b) where
  arbitrary = repeatable (\a -> coarbitrary a arbitrary)

instance coarbFunction :: (Arbitrary a, Coarbitrary b) => Coarbitrary (a -> b) where
  coarbitrary f gen = do
    xs <- arbitrary
    coarbitrary (map f (xs :: Array a)) gen

instance arbTuple :: (Arbitrary a, Arbitrary b) => Arbitrary (Tuple a b) where
  arbitrary = Tuple <$> arbitrary <*> arbitrary

instance coarbTuple :: (Coarbitrary a, Coarbitrary b) => Coarbitrary (Tuple a b) where
  coarbitrary (Tuple a b) = coarbitrary a >>> coarbitrary b

instance arbMaybe :: (Arbitrary a) => Arbitrary (Maybe a) where
  arbitrary = do
    b <- arbitrary
    if b then pure Nothing else Just <$> arbitrary

instance coarbMaybe :: (Coarbitrary a) => Coarbitrary (Maybe a) where
  coarbitrary Nothing = perturbGen 1.0
  coarbitrary (Just a) = coarbitrary a

instance arbEither :: (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where
  arbitrary = do
    b <- arbitrary
    if b then Left <$> arbitrary else Right <$> arbitrary

instance coarbEither :: (Coarbitrary a, Coarbitrary b) => Coarbitrary (Either a b) where
  coarbitrary (Left a)  = coarbitrary a
  coarbitrary (Right b) = coarbitrary b


Initialise shaders function now throws a more meaningful exception when a shader variable is missing.

-- | Functions for loading shader source code from script tags and compiling them into a shader program
module Jundo.Shaders (
  ShaderVariables(..),
  initialiseShaderProgram
  ) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.Either
import Data.Maybe
import Data.Nullable
import Data.Tuple
import qualified DOM as D
import qualified DOM.Node.Node as D
import qualified DOM.Node.NonElementParentNode as D
import qualified DOM.Node.Types as D
import qualified DOM.HTML as D
import qualified DOM.HTML.Types as D
import qualified DOM.HTML.Window as D
import Graphics.Canvas (Canvas())
import Graphics.WebGL.Free
import Graphics.WebGL.Free.Shaders (compileAndLinkProgram)

-- | Where we keep the fragment shader code
fragmentShaderId :: D.ElementId
fragmentShaderId = D.ElementId "fragment-shader"

-- | Where we keep the vertex shader code
vertexShaderId :: D.ElementId
vertexShaderId = D.ElementId "vertex-shader"

-- | Type to contain the locations of variables in the compiled shader program
type ShaderVariables = {
  ambientColour :: WebGLUniformLocation,
  directionalColour :: WebGLUniformLocation,
  lightingDirection :: WebGLUniformLocation,
  mvMatrix :: WebGLUniformLocation,
  pMatrix :: WebGLUniformLocation,
  nMatrix :: WebGLUniformLocation,
  position :: AttributeLocation,
  colour :: AttributeLocation,
  normal :: AttributeLocation
  }

shaderVariables :: WebGLUniformLocation -> WebGLUniformLocation -> WebGLUniformLocation -> WebGLUniformLocation -> WebGLUniformLocation
  -> WebGLUniformLocation -> AttributeLocation -> AttributeLocation -> AttributeLocation -> ShaderVariables
shaderVariables mvMatrix pMatrix nMatrix ambientColour directionalColour lightingDirection position colour normal = {
  ambientColour: ambientColour,
  directionalColour: directionalColour,
  lightingDirection: lightingDirection,
  mvMatrix: mvMatrix,
  pMatrix: pMatrix,
  nMatrix: nMatrix,
  position: position,
  colour: colour,
  normal: normal
  }

loadShaderSourceFromElement :: forall eff. D.ElementId -> Eff (dom :: D.DOM | eff) String
loadShaderSourceFromElement elementId = do
  document <- D.window >>= D.document >>= pure <<< D.htmlDocumentToNonElementParentNode
  Just el <- D.getElementById elementId document >>= pure <<< toMaybe
  D.textContent $ D.elementToNode el

uniformByName :: WebGLProgram -> String -> WebGL (Either String WebGLUniformLocation)
uniformByName program name = do
  maybeLocation <- getUniformLocation program name
  case maybeLocation of
    Nothing -> return $ Left ("Missing uniform location " ++ name)
    Just location -> return $ Right location

attributeByName :: WebGLProgram -> String -> WebGL (Either String AttributeLocation)
attributeByName program name = do
  maybeLocation <- getAttribLocation program name
  case maybeLocation of
    Nothing -> return $ Left ("Missing attribute location " ++ name)
    Just location -> return $ Right location

-- | Load and compile the fragment and vertex shader code from script tags, throwing a JavaScript exception if this fails
initialiseShaderProgram :: forall eff. WebGLContext -> Eff (canvas :: Canvas, dom :: D.DOM, err :: EXCEPTION | eff) (Tuple WebGLProgram ShaderVariables)
initialiseShaderProgram gl = do
  fragmentSource <- loadShaderSourceFromElement fragmentShaderId
  vertexSource <- loadShaderSourceFromElement vertexShaderId
  eitherProgram <- runWebGL gl $ compileAndLinkProgram vertexSource fragmentSource
  case eitherProgram of
    Left err -> throwException $ error err
    Right program -> do
      eitherVariables <- runWebGL gl do
        eitherMVMatrixLocation <- uniformByName program "mvMatrix"
        eitherPMatrixLocation <- uniformByName program "pMatrix"
        eitherNMatrixLocation <- uniformByName program "nMatrix"
        eitherAmbientColourLocation <- uniformByName program "ambientColour"
        eitherDirectionalColourLocation <- uniformByName program "directionalColour"
        eitherLightingDirectionLocation <- uniformByName program "lightingDirection"
        eitherPositionLocation <- attributeByName program "vertexPosition"
        eitherColourLocation <- attributeByName program "vertexColour"
        eitherNormalLocation <- attributeByName program "vertexNormal"
        return $ shaderVariables
          <$> eitherMVMatrixLocation
          <*> eitherPMatrixLocation
          <*> eitherNMatrixLocation
          <*> eitherAmbientColourLocation
          <*> eitherDirectionalColourLocation
          <*> eitherLightingDirectionLocation
          <*> eitherPositionLocation
          <*> eitherColourLocation
          <*> eitherNormalLocation
      case eitherVariables of
        Left err -> throwException $ error err
        Right variables -> do
          runWebGL gl $ programOperation program do
            enableVertexAttribArray variables.position
            enableVertexAttribArray variables.colour
            enableVertexAttribArray variables.normal
          return $ Tuple program variables

-- | Functions for loading shader source code from script tags and compiling them into a shader program
module Jundo.Shaders (
  ShaderVariables(..),
  initialiseShaderProgram
  ) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.Either
import Data.Maybe
import Data.Nullable
import Data.Tuple
import qualified DOM as D
import qualified DOM.Node.Node as D
import qualified DOM.Node.NonElementParentNode as D
import qualified DOM.Node.Types as D
import qualified DOM.HTML as D
import qualified DOM.HTML.Types as D
import qualified DOM.HTML.Window as D
import Graphics.Canvas (Canvas())
import Graphics.WebGL.Free
import Graphics.WebGL.Free.Shaders (compileAndLinkProgram)

-- | Where we keep the fragment shader code
fragmentShaderId :: D.ElementId
fragmentShaderId = D.ElementId "fragment-shader"

-- | Where we keep the vertex shader code
vertexShaderId :: D.ElementId
vertexShaderId = D.ElementId "vertex-shader"

-- | Type to contain the locations of variables in the compiled shader program
type ShaderVariables = {
  ambientColour :: WebGLUniformLocation,
  directionalColour :: WebGLUniformLocation,
  lightingDirection :: WebGLUniformLocation,
  mvMatrix :: WebGLUniformLocation,
  pMatrix :: WebGLUniformLocation,
  nMatrix :: WebGLUniformLocation,
  position :: AttributeLocation,
  colour :: AttributeLocation,
  normal :: AttributeLocation
  }

shaderVariables :: WebGLUniformLocation -> WebGLUniformLocation -> WebGLUniformLocation -> WebGLUniformLocation -> WebGLUniformLocation
  -> WebGLUniformLocation -> AttributeLocation -> AttributeLocation -> AttributeLocation -> ShaderVariables
shaderVariables mvMatrix pMatrix nMatrix ambientColour directionalColour lightingDirection position colour normal = {
  ambientColour: ambientColour,
  directionalColour: directionalColour,
  lightingDirection: lightingDirection,
  mvMatrix: mvMatrix,
  pMatrix: pMatrix,
  nMatrix: nMatrix,
  position: position,
  colour: colour,
  normal: normal
  }

loadShaderSourceFromElement :: forall eff. D.ElementId -> Eff (dom :: D.DOM | eff) String
loadShaderSourceFromElement elementId = do
  document <- D.window >>= D.document >>= pure <<< D.htmlDocumentToNonElementParentNode
  Just el <- D.getElementById elementId document >>= pure <<< toMaybe
  D.textContent $ D.elementToNode el

-- | Load and compile the fragment and vertex shader code from script tags, throwing a JavaScript exception if this fails
initialiseShaderProgram :: forall eff. WebGLContext -> Eff (canvas :: Canvas, dom :: D.DOM, err :: EXCEPTION | eff) (Tuple WebGLProgram ShaderVariables)
initialiseShaderProgram gl = do
  fragmentSource <- loadShaderSourceFromElement fragmentShaderId
  vertexSource <- loadShaderSourceFromElement vertexShaderId
  eitherProgram <- runWebGL gl $ compileAndLinkProgram vertexSource fragmentSource
  case eitherProgram of
    Left err -> throwException $ error err
    Right program -> do
      maybeVariables <- runWebGL gl do
        maybeMVMatrixLocation <- getUniformLocation program "mvMatrix"
        maybePMatrixLocation <- getUniformLocation program "pMatrix"
        maybeNMatrixLocation <- getUniformLocation program "nMatrix"
        maybeAmbientColourLocation <- getUniformLocation program "ambientColour"
        maybeDirectionalColourLocation <- getUniformLocation program "directionalColour"
        maybeLightingDirectionLocation <- getUniformLocation program "lightingDirection"
        maybePositionLocation <- getAttribLocation program "vertexPosition"
        maybeColourLocation <- getAttribLocation program "vertexColour"
        maybeNormalLocation <- getAttribLocation program "vertexNormal"
        return $ shaderVariables
          <$> maybeMVMatrixLocation
          <*> maybePMatrixLocation
          <*> maybeNMatrixLocation
          <*> maybeAmbientColourLocation
          <*> maybeDirectionalColourLocation
          <*> maybeLightingDirectionLocation
          <*> maybePositionLocation
          <*> maybeColourLocation
          <*> maybeNormalLocation
      case maybeVariables of
        Nothing -> throwException $ error "Missing shader program location"
        Just variables -> do
          runWebGL gl $ programOperation program do
            enableVertexAttribArray variables.position
            enableVertexAttribArray variables.colour
            enableVertexAttribArray variables.normal
          return $ Tuple program variables