simplify tests`

simplify tests`

module Test.Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Except (runExcept)
import Data.Either (Either, isRight)
import Data.Foreign (MultipleErrors)
import Simple.JSON (class ReadForeign, readJSON)
import Test.Spec (describe, it)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Reporter (consoleReporter)
import Test.Spec.Runner (RunnerEffects, run)

type E a = Either MultipleErrors a

handleJSON :: forall a. ReadForeign a => String -> E a
handleJSON json = runExcept $ readJSON json

type MyTest =
  { a :: Int
  , b :: String
  , c :: Boolean
  , d :: Array String
  }

main :: Eff (RunnerEffects ()) Unit
main = run [consoleReporter] do
  describe "readJSON" do
    it "works with proper JSON" do
      let result = handleJSON """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"]}
      """
      isRight (result :: E MyTest) `shouldEqual` true
    it "fails with invalid JSON" do
      let result = handleJSON """
        { "c": 1, "d": 2}
      """
      isRight (result :: E MyTest) `shouldEqual` false

module Test.Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Except (runExcept)
import Data.Either (Either, isRight)
import Data.Foreign (MultipleErrors)
import Simple.JSON (class ReadForeign, readJSON)
import Test.Spec (describe, it)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Reporter (consoleReporter)
import Test.Spec.Runner (RunnerEffects, run)
import Type.Proxy (Proxy(..))

handleJSON :: forall a. ReadForeign a => Proxy a -> String -> Either MultipleErrors a
handleJSON _ json = runExcept $ readJSON json

type MyTest =
  { a :: Int
  , b :: String
  , c :: Boolean
  , d :: Array String
  }

main :: Eff (RunnerEffects ()) Unit
main = run [consoleReporter] do
  describe "readJSON" do
    it "works with proper JSON" do
      let result = handleJSON (Proxy :: Proxy MyTest) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"]}
      """
      isRight result `shouldEqual` true
    it "fails with invalid JSON" do
      let result = handleJSON (Proxy :: Proxy MyTest) """
        { "c": 1, "d": 2}
      """
      isRight result `shouldEqual` false


Update Parser.purs

Update Parser.purs

-- | This module defines the parser for the Insect language.
module Insect.Parser
  ( DictEntry(..)
  , (==>)
  , Dictionary(..)
  , commands
  , prefixDict
  , normalUnitDict
  , imperialUnitDict
  , parseInsect
  ) where

import Prelude hiding (degree)

import Control.Alt ((<|>))
import Control.Lazy (fix)

import Quantities (DerivedUnit, (./))
import Quantities as Q

import Data.Array (some, fromFoldable)
import Data.Decimal (Decimal, fromString, fromNumber, isFinite)
import Data.Either (Either, isRight)
import Data.Foldable (foldr, traverse_)
import Data.Foldable as F
import Data.List (List, many, init, last)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.NonEmpty (NonEmpty, (:|), foldl1)
import Data.Map (lookup)
import Data.String (fromCodePointArray, codePointFromChar, singleton)

import Text.Parsing.Parser (ParserT, Parser, ParseError, runParser, fail)
import Text.Parsing.Parser.Combinators (option, optionMaybe, try, (<?>),
                                        notFollowedBy)
import Text.Parsing.Parser.String (string, char, eof, oneOf)
import Text.Parsing.Parser.Token (GenLanguageDef(..), LanguageDef, TokenParser,
                                  digit, letter, makeTokenParser)

import Insect.Language (BinOp(..), Expression(..), Command(..), Statement(..),
                        Identifier)
import Insect.Environment (Environment, StoredFunction(..))

-- | A type synonym for the main Parser type with `String` as input.
type P a = Parser String a

-- | Possible characters for the first character of an identifier.
identStart ∷ P Char
identStart = letter <|> char '_'

-- | Possible characters for identifiers (not for the first character).
identLetter ∷ P Char
identLetter = letter <|> digit <|> char '_' <|> char '\''

-- | A list of allowed commands
commands ∷ Array String
commands = ["help", "?", "list", "ls", "ll", "reset", "clear", "cls", "quit", "exit"]

-- | The language definition.
insectLanguage ∷ LanguageDef
insectLanguage = LanguageDef
  { commentStart: ""
  , commentEnd: ""
  , commentLine: "#"
  , nestedComments: false
  , identStart: identStart
  , identLetter: identLetter
  , opStart: oneOf ['+', '-', '*', '·', '⋅', '×', '/', '÷', '%', '^', '!', '→', '➞', '=']
  , opLetter: oneOf []
  , reservedNames: commands <> ["¹", "²", "³", "⁴", "⁵", "⁻¹", "⁻²", "⁻³", "⁻⁴", "⁻⁵", "to", "per"]
  , reservedOpNames: ["->", "+", "-", "*", "·", "⋅", "×", "/", "÷", "%", "^", "!",
                      "**", "=", ","]
  , caseSensitive: true
}

-- | The actual token parser.
token ∷ TokenParser
token = makeTokenParser insectLanguage

-- | Parse something, inside of parens.
parens ∷ ∀ a. P a → P a
parens = token.parens

-- | Parse one of the reserved operators.
reservedOp ∷ String → P Unit
reservedOp = token.reservedOp

-- | Parse a reserverd keyword.
reserved ∷ String → P Unit
reserved = token.reserved

-- | Parse zero or more whitespace characters.
whiteSpace ∷ P Unit
whiteSpace = token.whiteSpace

-- | Parse a number.
number ∷ P Decimal
number = do
  intPart ← digits

  mFracPart ← optionMaybe (append <$> string "." <*> digits)
  let fracPart = fromMaybe "" mFracPart

  mExpPart ← optionMaybe $ try do
    _ ← string "e"
    notFollowedBy identStart
    sad ← signAndDigits
    pure ("e" <> sad)
  let expPart = fromMaybe "" mExpPart

  whiteSpace

  let floatStr = intPart <> fracPart <> expPart

  case fromString floatStr of
    Just num →
      if isFinite num
      then pure num
      else fail "This number is too large"
    Nothing → fail $ "Parsing of number failed for input '" <> floatStr <> "'"

  where
    digits ∷ P String
    digits = do
      ds ← some $ oneOf ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'] <?> "a digit"
      pure $ fromCharArray (fromFoldable ds)

    fromCharArray = fromCodePointArray <<< map codePointFromChar

    signAndDigits ∷ P String
    signAndDigits = do
      sign ← option '+' (oneOf ['+', '-'])
      intPart ← digits
      pure $ singleton (codePointFromChar sign) <> intPart

-- | A helper type for entries in the dictionary.
data DictEntry a = DictEntry a (Array String)

infix 4 DictEntry as ==>

-- | A dictionary of units and their abbreviations.
data Dictionary a = Dictionary (Array (DictEntry a))

-- | Build a parser from a Dictionary
buildDictParser ∷ ∀ a. Dictionary a → P a
buildDictParser (Dictionary dict) = F.oneOf $ entryParser <$> dict
  where
    entryParser (x ==> abbrevs) = F.oneOf $ abbrevParser x <$> abbrevs
    abbrevParser x abbrev = string abbrev *> pure x

prefixDict ∷ Dictionary (DerivedUnit → DerivedUnit)
prefixDict = Dictionary
  [ Q.kibi ==> ["kibi", "Ki"]
  , Q.mebi ==> ["mebi", "Mi"]
  , Q.gibi ==> ["gibi", "Gi"]
  , Q.tebi ==> ["tebi", "Ti"]
  , Q.pebi ==> ["pebi", "Pi"]
  , Q.exbi ==> ["exbi", "Ei"]
  , Q.zebi ==> ["zebi", "Zi"]
  , Q.yobi ==> ["yobi", "Yi"]
  , Q.atto ==> ["atto", "a"]
  , Q.femto ==> ["femto", "f"]
  -- peta and mega have to be up here (before pico and milli) in order for the
  -- prefixes ('p' and 'm') not to be parsed as 'pico' or 'milli'.
  , Q.peta ==> ["peta"]
  , Q.mega ==> ["mega"]
  , Q.pico ==> ["pico", "p"]
  , Q.nano ==> ["nano", "n"]
  , Q.micro ==> [ "micro"
                , "u" -- u for micro
                , "µ" -- Micro sign U+00B5
                , "μ" -- Greek small letter mu U+039C
                ]
  , Q.milli ==> ["milli", "m"]
  , Q.centi ==> ["centi", "c"]
  , Q.deci ==> ["deci", "d"]
  , Q.hecto ==> ["hecto", "h"]
  , Q.kilo ==> ["kilo", "k"]
  , Q.mega ==> ["M"]
  , Q.giga ==> ["giga", "G"]
  , Q.tera ==> ["tera", "T"]
  , Q.peta ==> ["P"]
  , Q.exa ==> ["exa", "E"]
  ]

-- | Parse a SI or IEC prefix like `µ`, `G`, `pico` or `Ki`.
prefix ∷ P (DerivedUnit → DerivedUnit)
prefix = buildDictParser prefixDict <|> pure identity

-- | Normal (SI-conform, non-imperial) units
normalUnitDict ∷ Dictionary DerivedUnit
normalUnitDict = Dictionary
  [ Q.radian ==> ["radians", "radian", "rad"]
  , Q.degree ==> ["degrees", "degree", "deg", "°"]
  , Q.hertz ==> ["hertz", "Hz"]
  , Q.rpm ==> ["RPM", "rpm"]
  , Q.newton ==> ["newton", "N"]
  , Q.joule ==> ["joules", "joule", "J"]
  , Q.pascal ==> ["pascal", "Pa"]
  , Q.volt ==> ["volts", "volt", "V"]
  , Q.farad ==> ["farad", "F"]
  , Q.ohm ==> ["ohms", "ohm", "Ω"]
  , Q.sievert ==> ["sievert", "Sv"]
  , Q.weber ==> ["weber", "Wb"]
  , Q.tesla ==> ["tesla", "T"]
  , Q.henry ==> ["henry", "H"]
  , Q.coulomb ==> ["coulomb", "C"]
  , Q.siemens ==> ["siemens", "S"]
  , Q.lumen ==> ["lumen", "lm"]
  , Q.lux ==> ["lux", "lx"]
  , Q.becquerel ==> ["becquerel", "Bq"]
  , Q.gray ==> ["gray", "Gy"]
  , Q.katal ==> ["katal", "kat"]
  , Q.hectare ==> ["hectare", "ha"]
  , Q.tonne ==> ["tonnes", "tonne", "tons", "ton"]
  , Q.electronvolt ==> ["electronvolt", "eV"]
  , Q.calorie ==> ["calories", "calorie", "cal"]
  , Q.bel ==> ["bel"]
  , Q.astronomicalUnit ==> ["AU","au","astronomicalunit","Astronomicalunit"]
  , Q.parsec ==> ["parsecs", "parsec", "pc"]
  , Q.lightyear ==> ["lightyears", "lightyear", "ly"]
  , Q.barn ==> ["barn"]
  , Q.bar ==> ["bar"]
  , Q.angstrom ==> ["angstrom", "Å"]
  , Q.gauss ==> ["gauss"]
  , Q.ampere ==> ["amperes", "ampere", "A"]
  , Q.mole ==> ["mole", "mol"]
  , Q.kelvin ==> ["kelvin", "K"]
  , Q.candela ==> ["candela", "cd"]
  , Q.watt <> Q.hour ==> ["Wh"]
  , Q.watt ==> ["watts", "watt", "W"]
  , Q.byte ==> ["Bytes", "bytes", "Byte", "byte", "B", "Octets", "octets", "Octet", "octet"]
  , Q.bit ==> ["bits", "bit"]
  , Q.bit ./ Q.second ==> ["bps"]
  , Q.second ==> ["seconds", "second", "sec", "s"]
  , Q.minute ==> ["minutes", "minute", "min"]
  , Q.hour ==> ["hours", "hour", "h"]
  , Q.day ==> ["days", "day"]
  , Q.week ==> ["weeks", "week"]
  , Q.fortnight ==> ["fortnights", "fortnight"]
  , Q.month ==> ["months", "month"]
  , Q.year ==> ["years", "year"]
  , Q.gram ==> ["grammes", "gramme", "grams", "gram", "g"]
  , Q.meter ==> ["metres", "metre", "meters", "meter", "m"]
  , Q.liter ==> ["liters", "liter", "litres", "litre", "L", "l"]
  , Q.atm ==> ["atm"]
  , Q.pixel ==> ["pixels", "pixel", "px"]
  , Q.frame ==> ["frames", "frame"]
  , Q.frame ./ Q.second ==> ["fps"]
  , Q.dot ==> ["dots", "dot"]
  ]

-- | Parse a normal (SI-conform, non-imperical) unit, like `N` or `watt`.
normalUnit ∷ P DerivedUnit
normalUnit = buildDictParser normalUnitDict <?> "normal unit"

-- | Imperial units
imperialUnitDict ∷ Dictionary DerivedUnit
imperialUnitDict = Dictionary
  [ Q.mile ==> ["miles", "mile"]
  , Q.mile ./ Q.hour ==> ["mph"]
  , Q.inch ==> ["inches", "inch", "in"]
  , Q.yard ==> ["yards", "yard", "yd"]
  , Q.foot ==> ["feet", "foot", "ft"]
  , Q.ounce ==> ["ounces", "ounce", "oz"]
  , Q.lbf ==> ["pound_force", "lbf"]
  , Q.pound ==> ["pounds", "pound", "lb"]
  , Q.gallon ==> ["gallons", "gallon", "gal"]
  , Q.pint ==> ["pints", "pint"]
  , Q.cup ==> ["cups", "cup"]
  , Q.tablespoon ==> ["tablespoons", "tablespoon", "tbsp"]
  , Q.teaspoon ==> ["teaspoons", "teaspoon", "tsp"]
  , Q.fluidounce ==> ["fluidounces", "fluidounce", "floz"]
  , Q.furlong ==> ["furlong"]
  , Q.btu ==> ["BTU"]
  , Q.psi ==> ["psi"]
  , Q.mmHg ==> ["mmHg"]
  , Q.hogshead ==> ["hogsheads", "hogshead"]
  , Q.rod ==> ["rods", "rod"]
  , Q.pixel ./ Q.inch ==> ["ppi"]
  , Q.dot ./ Q.inch ==> ["dpi"]
  , Q.piece ==> ["pieces", "piece"]
  , Q.person ==> ["persons", "person", "people"]
  , Q.dollar ==> ["dollars", "dollar", "USD", "$"]
  , Q.euro ==> ["euros", "euro", "EUR", "€"]
  ]

-- | Parse an imperial unit like `ft` of `mile`.
imperialUnit ∷ P DerivedUnit
imperialUnit = buildDictParser imperialUnitDict <?> "imperial unit"

-- | Parse a 'normal' unit with SI prefix, like `km` or `Gb`.
unitWithSIPrefix ∷ P DerivedUnit
unitWithSIPrefix = do
  p ← prefix
  u ← normalUnit
  pure $ p u

specialCases ∷ P DerivedUnit
specialCases =
  -- The abbreviation 'd' for 'day' needs to be treated separately. Otherwise,
  -- 'cd' will be parsed as 'centi day' instead of 'candela'.
      string "d" *> pure Q.day
  -- Similarly, the abbreviation 't' for 'tonne' needs special treatment.
  -- Otherwise, 'ft' will be parsed as 'femto tonne' instead of 'feet'.
  <|> string "t" *> pure Q.tonne

-- | Parse a derived unit, like `km`, `ft`, or `s`.
derivedUnit ∷ P DerivedUnit
derivedUnit =
  (
        try (augment unitWithSIPrefix)
    <|> augment imperialUnit
    <|> augment normalUnit
    <|> augment specialCases
  ) <* whiteSpace
  where
    augment p = p <* notFollowedBy identLetter

-- | Parse the name of a variable, like `my_variable'`.
variable ∷ P Expression
variable = Variable <$> token.identifier

-- | A version of `sepBy1` that returns a `NonEmpty List`.
sepBy1 ∷ ∀ m s a sep. Monad m ⇒ ParserT s m a → ParserT s m sep → ParserT s m (NonEmpty List a)
sepBy1 p sep = do
  a ← p
  as ← many $ sep *> p
  pure (a :| as)

-- | Fold a non-empty structure, collecting results using a binary operation.
foldr1 ∷ ∀ a. (a → a → a) → NonEmpty List a → a
foldr1 f (a :| xs) =
  case init xs, last xs of
    Just bs, Just b → f a (foldr f b bs)
    _, _ → a

-- | Parse a function name and fail if it's not in the environment
function ∷ Environment → P Identifier
function env = do
  name ← token.identifier
  if name == "sum" || name == "product"
    then
      pure name
    else
      case lookup name env.functions of
        Just (StoredFunction _ fn) → pure name
        Nothing → fail ("Unknown function '" <> name <> "'")

-- | Parse a full mathematical expression.
expression ∷ Environment → P Expression
expression env =
  fix \p →
    let
      atomic ∷ P Expression
      atomic = whiteSpace *> (
              parens p
          <|> (Scalar <$> number)
          <|> try (Unit <$> derivedUnit)
          <|> try (Apply <$> function env <*> parens (sepBy1 p commaOp))
          <|> variable
          )

      suffixFac ∷ P Expression
      suffixFac = do
        a ← atomic
        mf ← optionMaybe (facOp *> pure Factorial)
        case mf of
          Just f → pure $ f a
          Nothing → pure a

      suffixPow ∷ P Expression
      suffixPow = do
        x ← suffixFac
        mFn ← optionMaybe (     reservedOp "¹" *>  pure (powPos 1.0)
                            <|> reservedOp "²" *>  pure (powPos 2.0)
                            <|> reservedOp "³" *>  pure (powPos 3.0)
                            <|> reservedOp "⁴" *>  pure (powPos 4.0)
                            <|> reservedOp "⁵" *>  pure (powPos 5.0)
                            <|> reservedOp "⁻¹" *> pure (powNeg 1.0)
                            <|> reservedOp "⁻²" *> pure (powNeg 2.0)
                            <|> reservedOp "⁻³" *> pure (powNeg 3.0)
                            <|> reservedOp "⁻⁴" *> pure (powNeg 4.0)
                            <|> reservedOp "⁻⁵" *> pure (powNeg 5.0)
                          )
        case mFn of
          Just fn → pure $ fn x
          Nothing → pure x

      -- The power operator needs special treatment
      -- 1) it is right-associative => use foldr1 instead of foldl1
      -- 2) the unary minus on the *left* side of the power operator has
      --    a lower precedence, i.e. -2^3 = -(2^3). However, unary minus
      --    on the *right* side has a higher precedence: 2^-3 = 2^(-3).
      sepByPow ∷ P Expression
      sepByPow = fix \e → foldr1 (BinOp Pow) <$> list e
        where
          list e = do
            a ← suffixPow
            as ← many do
              powOp
              func ← (subOp *> pure Negate) <|> (addOp *> pure identity) <|> pure identity
              expr ← e
              pure (func expr)
            pure (a :| as)

      sepByMulImplicit ∷ P Expression
      sepByMulImplicit = foldl1 (BinOp Mul) <$> sepByPow `sepBy1` pure unit

      prefixed ∷ P Expression
      prefixed = fix \e →
            (subOp *> (Negate <$> e))
        <|> (addOp *> e)
        <|> sepByMulImplicit

      sepByMod ∷ P Expression
      sepByMod = foldl1 (BinOp Mod) <$> prefixed `sepBy1` modOp

      sepByPer ∷ P Expression
      sepByPer = foldl1 (BinOp Div) <$> sepByMod `sepBy1` perOp

      sepByDiv ∷ P Expression
      sepByDiv = foldl1 (BinOp Div) <$> sepByPer `sepBy1` divOp

      sepByMul ∷ P Expression
      sepByMul = foldl1 (BinOp Mul) <$> sepByDiv `sepBy1` mulOp

      sepBySub ∷ P Expression
      sepBySub = foldl1 (BinOp Sub) <$> sepByMul `sepBy1` subOp

      sepByAdd ∷ P Expression
      sepByAdd = foldl1 (BinOp Add) <$> sepBySub `sepBy1` addOp

      sepByConv ∷ P Expression
      sepByConv = foldl1 (BinOp ConvertTo) <$> sepByAdd `sepBy1` arrOp

    in sepByConv

  where

    commaOp = reservedOp ","
    facOp = reservedOp "!"
    powOp = reservedOp "^" <|> reservedOp "**"
    modOp = reservedOp "%"
    perOp = reserved "per"
    divOp = reservedOp "/" <|> reservedOp "÷"
    mulOp = reservedOp "*" <|> reservedOp "·" <|> reservedOp "⋅"
                           <|> reservedOp "×"
    subOp = reservedOp "-"
    addOp = reservedOp "+"
    arrOp = reservedOp "->" <|> reservedOp "→" <|> reservedOp "➞" <|> reserved "to"

    powPos s q | s == 1.0  = q
               | otherwise = BinOp Pow q (Scalar $ fromNumber s)
    powNeg s q = BinOp Pow q (Negate $ Scalar $ fromNumber s)

-- | Parse a mathematical expression (or conversion) like `3m+2in -> cm`.
fullExpression ∷ Environment → P Expression
fullExpression env = do
  whiteSpace
  expr ← expression env
  eof <?> "end of input"

  pure $ expr

-- | Parse an Insect command.
command ∷ P Command
command =
  (
        (reserved "help" <|> reserved "?") *> pure Help
    <|> (reserved "list" <|> reserved "ls" <|> reserved "ll") *> pure List
    <|> (reserved "reset") *> pure Reset
    <|> (reserved "clear" <|> reserved "cls") *> pure Clear
    <|> (reserved "quit" <|> reserved "exit") *> pure Quit
  ) <* eof

-- | Parse a variable- or function assignment.
assignment ∷ Environment → P Statement
assignment env = do
  { name, args, expr } ←
    try do
      whiteSpace
      name ← token.identifier
      args ← optionMaybe (parens (sepBy1 token.identifier (reservedOp ",")))
      reservedOp "="
      expr ← expression env
      eof

      pure { name: name, args: args, expr: expr }

  -- Fail if the name can be parsed as a physical unit
  failIfUnit name

  case args of
    Nothing → pure (VariableAssignment name expr)
    Just xs → do
      traverse_ failIfUnit xs
      pure (FunctionAssignment name xs expr)

  where
    failIfUnit n =
      when (isRight $ runParser n (derivedUnit <* eof)) $
        fail ("'" <> n <> "' is reserved for a physical unit")

-- | Parse a statement in the Insect language.
statement ∷ Environment → P Statement
statement env =
      (Command <$> command)
  <|> assignment env
  <|> (Expression <$> fullExpression env)

-- | Run the Insect-parser on a `String` input.
parseInsect ∷ Environment → String → Either ParseError Statement
parseInsect env inp = runParser inp (statement env)

-- | This module defines the parser for the Insect language.
module Insect.Parser
  ( DictEntry(..)
  , (==>)
  , Dictionary(..)
  , commands
  , prefixDict
  , normalUnitDict
  , imperialUnitDict
  , parseInsect
  ) where

import Prelude hiding (degree)

import Control.Alt ((<|>))
import Control.Lazy (fix)

import Quantities (DerivedUnit, (./))
import Quantities as Q

import Data.Array (some, fromFoldable)
import Data.Decimal (Decimal, fromString, fromNumber, isFinite)
import Data.Either (Either, isRight)
import Data.Foldable (foldr, traverse_)
import Data.Foldable as F
import Data.List (List, many, init, last)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.NonEmpty (NonEmpty, (:|), foldl1)
import Data.Map (lookup)
import Data.String (fromCodePointArray, codePointFromChar, singleton)

import Text.Parsing.Parser (ParserT, Parser, ParseError, runParser, fail)
import Text.Parsing.Parser.Combinators (option, optionMaybe, try, (<?>),
                                        notFollowedBy)
import Text.Parsing.Parser.String (string, char, eof, oneOf)
import Text.Parsing.Parser.Token (GenLanguageDef(..), LanguageDef, TokenParser,
                                  digit, letter, makeTokenParser)

import Insect.Language (BinOp(..), Expression(..), Command(..), Statement(..),
                        Identifier)
import Insect.Environment (Environment, StoredFunction(..))

-- | A type synonym for the main Parser type with `String` as input.
type P a = Parser String a

-- | Possible characters for the first character of an identifier.
identStart ∷ P Char
identStart = letter <|> char '_'

-- | Possible characters for identifiers (not for the first character).
identLetter ∷ P Char
identLetter = letter <|> digit <|> char '_' <|> char '\''

-- | A list of allowed commands
commands ∷ Array String
commands = ["help", "?", "list", "ls", "ll", "reset", "clear", "cls", "quit", "exit"]

-- | The language definition.
insectLanguage ∷ LanguageDef
insectLanguage = LanguageDef
  { commentStart: ""
  , commentEnd: ""
  , commentLine: "#"
  , nestedComments: false
  , identStart: identStart
  , identLetter: identLetter
  , opStart: oneOf ['+', '-', '*', '·', '⋅', '×', '/', '÷', '%', '^', '!', '→', '➞', '=']
  , opLetter: oneOf []
  , reservedNames: commands <> ["¹", "²", "³", "⁴", "⁵", "⁻¹", "⁻²", "⁻³", "⁻⁴", "⁻⁵", "to", "per"]
  , reservedOpNames: ["->", "+", "-", "*", "·", "⋅", "×", "/", "÷", "%", "^", "!",
                      "**", "=", ","]
  , caseSensitive: true
}

-- | The actual token parser.
token ∷ TokenParser
token = makeTokenParser insectLanguage

-- | Parse something, inside of parens.
parens ∷ ∀ a. P a → P a
parens = token.parens

-- | Parse one of the reserved operators.
reservedOp ∷ String → P Unit
reservedOp = token.reservedOp

-- | Parse a reserverd keyword.
reserved ∷ String → P Unit
reserved = token.reserved

-- | Parse zero or more whitespace characters.
whiteSpace ∷ P Unit
whiteSpace = token.whiteSpace

-- | Parse a number.
number ∷ P Decimal
number = do
  intPart ← digits

  mFracPart ← optionMaybe (append <$> string "." <*> digits)
  let fracPart = fromMaybe "" mFracPart

  mExpPart ← optionMaybe $ try do
    _ ← string "e"
    notFollowedBy identStart
    sad ← signAndDigits
    pure ("e" <> sad)
  let expPart = fromMaybe "" mExpPart

  whiteSpace

  let floatStr = intPart <> fracPart <> expPart

  case fromString floatStr of
    Just num →
      if isFinite num
      then pure num
      else fail "This number is too large"
    Nothing → fail $ "Parsing of number failed for input '" <> floatStr <> "'"

  where
    digits ∷ P String
    digits = do
      ds ← some $ oneOf ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'] <?> "a digit"
      pure $ fromCharArray (fromFoldable ds)

    fromCharArray = fromCodePointArray <<< map codePointFromChar

    signAndDigits ∷ P String
    signAndDigits = do
      sign ← option '+' (oneOf ['+', '-'])
      intPart ← digits
      pure $ singleton (codePointFromChar sign) <> intPart

-- | A helper type for entries in the dictionary.
data DictEntry a = DictEntry a (Array String)

infix 4 DictEntry as ==>

-- | A dictionary of units and their abbreviations.
data Dictionary a = Dictionary (Array (DictEntry a))

-- | Build a parser from a Dictionary
buildDictParser ∷ ∀ a. Dictionary a → P a
buildDictParser (Dictionary dict) = F.oneOf $ entryParser <$> dict
  where
    entryParser (x ==> abbrevs) = F.oneOf $ abbrevParser x <$> abbrevs
    abbrevParser x abbrev = string abbrev *> pure x

prefixDict ∷ Dictionary (DerivedUnit → DerivedUnit)
prefixDict = Dictionary
  [ Q.kibi ==> ["kibi", "Ki"]
  , Q.mebi ==> ["mebi", "Mi"]
  , Q.gibi ==> ["gibi", "Gi"]
  , Q.tebi ==> ["tebi", "Ti"]
  , Q.pebi ==> ["pebi", "Pi"]
  , Q.exbi ==> ["exbi", "Ei"]
  , Q.zebi ==> ["zebi", "Zi"]
  , Q.yobi ==> ["yobi", "Yi"]
  , Q.atto ==> ["atto", "a"]
  , Q.femto ==> ["femto", "f"]
  -- peta and mega have to be up here (before pico and milli) in order for the
  -- prefixes ('p' and 'm') not to be parsed as 'pico' or 'milli'.
  , Q.peta ==> ["peta"]
  , Q.mega ==> ["mega"]
  , Q.pico ==> ["pico", "p"]
  , Q.nano ==> ["nano", "n"]
  , Q.micro ==> [ "micro"
                , "u" -- u for micro
                , "µ" -- Micro sign U+00B5
                , "μ" -- Greek small letter mu U+039C
                ]
  , Q.milli ==> ["milli", "m"]
  , Q.centi ==> ["centi", "c"]
  , Q.deci ==> ["deci", "d"]
  , Q.hecto ==> ["hecto", "h"]
  , Q.kilo ==> ["kilo", "k"]
  , Q.mega ==> ["M"]
  , Q.giga ==> ["giga", "G"]
  , Q.tera ==> ["tera", "T"]
  , Q.peta ==> ["P"]
  , Q.exa ==> ["exa", "E"]
  ]

-- | Parse a SI or IEC prefix like `µ`, `G`, `pico` or `Ki`.
prefix ∷ P (DerivedUnit → DerivedUnit)
prefix = buildDictParser prefixDict <|> pure identity

-- | Normal (SI-conform, non-imperial) units
normalUnitDict ∷ Dictionary DerivedUnit
normalUnitDict = Dictionary
  [ Q.radian ==> ["radians", "radian", "rad"]
  , Q.degree ==> ["degrees", "degree", "deg", "°"]
  , Q.hertz ==> ["hertz", "Hz"]
  , Q.rpm ==> ["RPM", "rpm"]
  , Q.newton ==> ["newton", "N"]
  , Q.joule ==> ["joules", "joule", "J"]
  , Q.pascal ==> ["pascal", "Pa"]
  , Q.volt ==> ["volts", "volt", "V"]
  , Q.farad ==> ["farad", "F"]
  , Q.ohm ==> ["ohms", "ohm", "Ω"]
  , Q.sievert ==> ["sievert", "Sv"]
  , Q.weber ==> ["weber", "Wb"]
  , Q.tesla ==> ["tesla", "T"]
  , Q.henry ==> ["henry", "H"]
  , Q.coulomb ==> ["coulomb", "C"]
  , Q.siemens ==> ["siemens", "S"]
  , Q.lumen ==> ["lumen", "lm"]
  , Q.lux ==> ["lux", "lx"]
  , Q.becquerel ==> ["becquerel", "Bq"]
  , Q.gray ==> ["gray", "Gy"]
  , Q.katal ==> ["katal", "kat"]
  , Q.hectare ==> ["hectare", "ha"]
  , Q.tonne ==> ["tonnes", "tonne", "tons", "ton"]
  , Q.electronvolt ==> ["electronvolt", "eV"]
  , Q.calorie ==> ["calories", "calorie", "cal"]
  , Q.bel ==> ["bel"]
  , Q.astronomicalUnit ==> ["AU","Astronomical unit","au","astronomical unit"]
  , Q.parsec ==> ["parsecs", "parsec", "pc"]
  , Q.lightyear ==> ["lightyears", "lightyear", "ly"]
  , Q.barn ==> ["barn"]
  , Q.bar ==> ["bar"]
  , Q.angstrom ==> ["angstrom", "Å"]
  , Q.gauss ==> ["gauss"]
  , Q.ampere ==> ["amperes", "ampere", "A"]
  , Q.mole ==> ["mole", "mol"]
  , Q.kelvin ==> ["kelvin", "K"]
  , Q.candela ==> ["candela", "cd"]
  , Q.watt <> Q.hour ==> ["Wh"]
  , Q.watt ==> ["watts", "watt", "W"]
  , Q.byte ==> ["Bytes", "bytes", "Byte", "byte", "B", "Octets", "octets", "Octet", "octet"]
  , Q.bit ==> ["bits", "bit"]
  , Q.bit ./ Q.second ==> ["bps"]
  , Q.second ==> ["seconds", "second", "sec", "s"]
  , Q.minute ==> ["minutes", "minute", "min"]
  , Q.hour ==> ["hours", "hour", "h"]
  , Q.day ==> ["days", "day"]
  , Q.week ==> ["weeks", "week"]
  , Q.fortnight ==> ["fortnights", "fortnight"]
  , Q.month ==> ["months", "month"]
  , Q.year ==> ["years", "year"]
  , Q.gram ==> ["grammes", "gramme", "grams", "gram", "g"]
  , Q.meter ==> ["metres", "metre", "meters", "meter", "m"]
  , Q.liter ==> ["liters", "liter", "litres", "litre", "L", "l"]
  , Q.atm ==> ["atm"]
  , Q.pixel ==> ["pixels", "pixel", "px"]
  , Q.frame ==> ["frames", "frame"]
  , Q.frame ./ Q.second ==> ["fps"]
  , Q.dot ==> ["dots", "dot"]
  ]

-- | Parse a normal (SI-conform, non-imperical) unit, like `N` or `watt`.
normalUnit ∷ P DerivedUnit
normalUnit = buildDictParser normalUnitDict <?> "normal unit"

-- | Imperial units
imperialUnitDict ∷ Dictionary DerivedUnit
imperialUnitDict = Dictionary
  [ Q.mile ==> ["miles", "mile"]
  , Q.mile ./ Q.hour ==> ["mph"]
  , Q.inch ==> ["inches", "inch", "in"]
  , Q.yard ==> ["yards", "yard", "yd"]
  , Q.foot ==> ["feet", "foot", "ft"]
  , Q.ounce ==> ["ounces", "ounce", "oz"]
  , Q.lbf ==> ["pound_force", "lbf"]
  , Q.pound ==> ["pounds", "pound", "lb"]
  , Q.gallon ==> ["gallons", "gallon", "gal"]
  , Q.pint ==> ["pints", "pint"]
  , Q.cup ==> ["cups", "cup"]
  , Q.tablespoon ==> ["tablespoons", "tablespoon", "tbsp"]
  , Q.teaspoon ==> ["teaspoons", "teaspoon", "tsp"]
  , Q.fluidounce ==> ["fluidounces", "fluidounce", "floz"]
  , Q.furlong ==> ["furlong"]
  , Q.btu ==> ["BTU"]
  , Q.psi ==> ["psi"]
  , Q.mmHg ==> ["mmHg"]
  , Q.hogshead ==> ["hogsheads", "hogshead"]
  , Q.rod ==> ["rods", "rod"]
  , Q.pixel ./ Q.inch ==> ["ppi"]
  , Q.dot ./ Q.inch ==> ["dpi"]
  , Q.piece ==> ["pieces", "piece"]
  , Q.person ==> ["persons", "person", "people"]
  , Q.dollar ==> ["dollars", "dollar", "USD", "$"]
  , Q.euro ==> ["euros", "euro", "EUR", "€"]
  ]

-- | Parse an imperial unit like `ft` of `mile`.
imperialUnit ∷ P DerivedUnit
imperialUnit = buildDictParser imperialUnitDict <?> "imperial unit"

-- | Parse a 'normal' unit with SI prefix, like `km` or `Gb`.
unitWithSIPrefix ∷ P DerivedUnit
unitWithSIPrefix = do
  p ← prefix
  u ← normalUnit
  pure $ p u

specialCases ∷ P DerivedUnit
specialCases =
  -- The abbreviation 'd' for 'day' needs to be treated separately. Otherwise,
  -- 'cd' will be parsed as 'centi day' instead of 'candela'.
      string "d" *> pure Q.day
  -- Similarly, the abbreviation 't' for 'tonne' needs special treatment.
  -- Otherwise, 'ft' will be parsed as 'femto tonne' instead of 'feet'.
  <|> string "t" *> pure Q.tonne

-- | Parse a derived unit, like `km`, `ft`, or `s`.
derivedUnit ∷ P DerivedUnit
derivedUnit =
  (
        try (augment unitWithSIPrefix)
    <|> augment imperialUnit
    <|> augment normalUnit
    <|> augment specialCases
  ) <* whiteSpace
  where
    augment p = p <* notFollowedBy identLetter

-- | Parse the name of a variable, like `my_variable'`.
variable ∷ P Expression
variable = Variable <$> token.identifier

-- | A version of `sepBy1` that returns a `NonEmpty List`.
sepBy1 ∷ ∀ m s a sep. Monad m ⇒ ParserT s m a → ParserT s m sep → ParserT s m (NonEmpty List a)
sepBy1 p sep = do
  a ← p
  as ← many $ sep *> p
  pure (a :| as)

-- | Fold a non-empty structure, collecting results using a binary operation.
foldr1 ∷ ∀ a. (a → a → a) → NonEmpty List a → a
foldr1 f (a :| xs) =
  case init xs, last xs of
    Just bs, Just b → f a (foldr f b bs)
    _, _ → a

-- | Parse a function name and fail if it's not in the environment
function ∷ Environment → P Identifier
function env = do
  name ← token.identifier
  if name == "sum" || name == "product"
    then
      pure name
    else
      case lookup name env.functions of
        Just (StoredFunction _ fn) → pure name
        Nothing → fail ("Unknown function '" <> name <> "'")

-- | Parse a full mathematical expression.
expression ∷ Environment → P Expression
expression env =
  fix \p →
    let
      atomic ∷ P Expression
      atomic = whiteSpace *> (
              parens p
          <|> (Scalar <$> number)
          <|> try (Unit <$> derivedUnit)
          <|> try (Apply <$> function env <*> parens (sepBy1 p commaOp))
          <|> variable
          )

      suffixFac ∷ P Expression
      suffixFac = do
        a ← atomic
        mf ← optionMaybe (facOp *> pure Factorial)
        case mf of
          Just f → pure $ f a
          Nothing → pure a

      suffixPow ∷ P Expression
      suffixPow = do
        x ← suffixFac
        mFn ← optionMaybe (     reservedOp "¹" *>  pure (powPos 1.0)
                            <|> reservedOp "²" *>  pure (powPos 2.0)
                            <|> reservedOp "³" *>  pure (powPos 3.0)
                            <|> reservedOp "⁴" *>  pure (powPos 4.0)
                            <|> reservedOp "⁵" *>  pure (powPos 5.0)
                            <|> reservedOp "⁻¹" *> pure (powNeg 1.0)
                            <|> reservedOp "⁻²" *> pure (powNeg 2.0)
                            <|> reservedOp "⁻³" *> pure (powNeg 3.0)
                            <|> reservedOp "⁻⁴" *> pure (powNeg 4.0)
                            <|> reservedOp "⁻⁵" *> pure (powNeg 5.0)
                          )
        case mFn of
          Just fn → pure $ fn x
          Nothing → pure x

      -- The power operator needs special treatment
      -- 1) it is right-associative => use foldr1 instead of foldl1
      -- 2) the unary minus on the *left* side of the power operator has
      --    a lower precedence, i.e. -2^3 = -(2^3). However, unary minus
      --    on the *right* side has a higher precedence: 2^-3 = 2^(-3).
      sepByPow ∷ P Expression
      sepByPow = fix \e → foldr1 (BinOp Pow) <$> list e
        where
          list e = do
            a ← suffixPow
            as ← many do
              powOp
              func ← (subOp *> pure Negate) <|> (addOp *> pure identity) <|> pure identity
              expr ← e
              pure (func expr)
            pure (a :| as)

      sepByMulImplicit ∷ P Expression
      sepByMulImplicit = foldl1 (BinOp Mul) <$> sepByPow `sepBy1` pure unit

      prefixed ∷ P Expression
      prefixed = fix \e →
            (subOp *> (Negate <$> e))
        <|> (addOp *> e)
        <|> sepByMulImplicit

      sepByMod ∷ P Expression
      sepByMod = foldl1 (BinOp Mod) <$> prefixed `sepBy1` modOp

      sepByPer ∷ P Expression
      sepByPer = foldl1 (BinOp Div) <$> sepByMod `sepBy1` perOp

      sepByDiv ∷ P Expression
      sepByDiv = foldl1 (BinOp Div) <$> sepByPer `sepBy1` divOp

      sepByMul ∷ P Expression
      sepByMul = foldl1 (BinOp Mul) <$> sepByDiv `sepBy1` mulOp

      sepBySub ∷ P Expression
      sepBySub = foldl1 (BinOp Sub) <$> sepByMul `sepBy1` subOp

      sepByAdd ∷ P Expression
      sepByAdd = foldl1 (BinOp Add) <$> sepBySub `sepBy1` addOp

      sepByConv ∷ P Expression
      sepByConv = foldl1 (BinOp ConvertTo) <$> sepByAdd `sepBy1` arrOp

    in sepByConv

  where

    commaOp = reservedOp ","
    facOp = reservedOp "!"
    powOp = reservedOp "^" <|> reservedOp "**"
    modOp = reservedOp "%"
    perOp = reserved "per"
    divOp = reservedOp "/" <|> reservedOp "÷"
    mulOp = reservedOp "*" <|> reservedOp "·" <|> reservedOp "⋅"
                           <|> reservedOp "×"
    subOp = reservedOp "-"
    addOp = reservedOp "+"
    arrOp = reservedOp "->" <|> reservedOp "→" <|> reservedOp "➞" <|> reserved "to"

    powPos s q | s == 1.0  = q
               | otherwise = BinOp Pow q (Scalar $ fromNumber s)
    powNeg s q = BinOp Pow q (Negate $ Scalar $ fromNumber s)

-- | Parse a mathematical expression (or conversion) like `3m+2in -> cm`.
fullExpression ∷ Environment → P Expression
fullExpression env = do
  whiteSpace
  expr ← expression env
  eof <?> "end of input"

  pure $ expr

-- | Parse an Insect command.
command ∷ P Command
command =
  (
        (reserved "help" <|> reserved "?") *> pure Help
    <|> (reserved "list" <|> reserved "ls" <|> reserved "ll") *> pure List
    <|> (reserved "reset") *> pure Reset
    <|> (reserved "clear" <|> reserved "cls") *> pure Clear
    <|> (reserved "quit" <|> reserved "exit") *> pure Quit
  ) <* eof

-- | Parse a variable- or function assignment.
assignment ∷ Environment → P Statement
assignment env = do
  { name, args, expr } ←
    try do
      whiteSpace
      name ← token.identifier
      args ← optionMaybe (parens (sepBy1 token.identifier (reservedOp ",")))
      reservedOp "="
      expr ← expression env
      eof

      pure { name: name, args: args, expr: expr }

  -- Fail if the name can be parsed as a physical unit
  failIfUnit name

  case args of
    Nothing → pure (VariableAssignment name expr)
    Just xs → do
      traverse_ failIfUnit xs
      pure (FunctionAssignment name xs expr)

  where
    failIfUnit n =
      when (isRight $ runParser n (derivedUnit <* eof)) $
        fail ("'" <> n <> "' is reserved for a physical unit")

-- | Parse a statement in the Insect language.
statement ∷ Environment → P Statement
statement env =
      (Command <$> command)
  <|> assignment env
  <|> (Expression <$> fullExpression env)

-- | Run the Insect-parser on a `String` input.
parseInsect ∷ Environment → String → Either ParseError Statement
parseInsect env inp = runParser inp (statement env)


Remove unused code in Language.Expr

Remove unused code in Language.Expr

module Language.Expr
  ( Expr(..)
  , Environment(..)
  , syntaxToExpr
  , exprToSyntax
  , freeVars
  , alpha
  ) where

import Prelude

import Data.Array (cons, unsafeIndex)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.Map as Map
import Data.Maybe (maybe)
import Data.Set (Set)
import Data.Set as Set
import Language.Name (Name, next)
import Language.PrettyPrint (class PrettyPrint, parensIf)
import Language.Syntax (Syntax(..))
import Partial.Unsafe (unsafePartial)

data Expr
  = Bound Int
  | Free Name
  | Bind Name Expr
  | App Expr Expr

type Environment a = Map.Map Name a

derive instance genericExpr :: Generic Expr _

instance showExpr :: Show Expr where
  show x = genericShow x

syntaxToExpr :: Syntax -> Expr
syntaxToExpr =
  alpha <<< loop Map.empty
 where
  loop env = case _ of
    Var n ->
      maybe (Free n) Bound (Map.lookup n env)
    Lambda n b ->
      let env' = Map.insert n 0 (map (_ + 1) env)
      in Bind n (loop env' b)
    Apply f a ->
      App (loop env f) (loop env a)

alpha :: Expr -> Expr
alpha e =
  loop (freeVars e) e
 where
  loop env = case _ of
    Bound i ->
      Bound i
    Free n ->
      Free n
    Bind n b ->
      let {used, new} = fresh env n
      in Bind new (loop used b)
    App f a ->
      App (loop env f) (loop env a)

fresh :: Set Name -> Name -> {used :: Set Name, new :: Name}
fresh env n
  | n `Set.member` env = fresh env (next n)
  | otherwise = {used:  Set.insert n env, new: n}

exprToSyntax :: Expr -> Syntax
exprToSyntax =
  loop []
 where
  loop env = case _ of
    Bound i ->
      Var $ unsafePartial $ env `unsafeIndex` i
    Free n ->
      Var n
    Bind n b ->
      Lambda n $ loop (n `cons` env) b
    App f a ->
      Apply (loop env f) (loop env a)

freeVars :: Expr -> Set Name
freeVars =
  walk Set.empty
 where
  walk vars = case _ of
    Bound _ ->
      vars
    Free n ->
      Set.insert n vars
    Bind _ b ->
      walk vars b
    App f a ->
      walk (walk vars f) a

instance prettyPrintExpr :: PrettyPrint Expr where
  prettyPrint =
    walk false
   where
    walk inApp = case _ of
      Bound i ->
        pure $ show i
      Free n ->
        pure $ show n
      Bind _ b ->
        parensIf inApp $ pure "λ. " <> walk false b
      App f a ->
        walk true f <> pure " " <> walk true a

module Language.Expr
  ( Expr(..)
  , Environment(..)
  , syntaxToExpr
  , exprToSyntax
  , freeVars
  , globalNames
  , undefinedNames
  , namesReferencing
  , formatUndefinedError
  , formatUndefinedWarning
  , substitute
  , step
  , alpha
  ) where

import Prelude

import Control.Alt ((<|>))
import Data.Array (cons, unsafeIndex)
import Data.Foldable (intercalate, foldl, fold)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.List (List)
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Set as Set
import Data.Tuple (Tuple(..), fst, snd)
import Language.Name (Name, next)
import Language.PrettyPrint (class PrettyPrint, parensIf)
import Language.Syntax (Syntax(..))
import Partial.Unsafe (unsafePartial)

data Expr
  = Bound Int
  | Free Name
  | Bind Name Expr
  | App Expr Expr

type Environment a = Map.Map Name a

derive instance genericExpr :: Generic Expr _

instance showExpr :: Show Expr where
  show x = genericShow x

syntaxToExpr :: Syntax -> Expr
syntaxToExpr =
  alpha <<< loop Map.empty
 where
  loop env = case _ of
    Var n ->
      maybe (Free n) Bound (Map.lookup n env)
    Lambda n b ->
      let env' = Map.insert n 0 (map (_ + 1) env)
      in Bind n (loop env' b)
    Apply f a ->
      App (loop env f) (loop env a)

alpha :: Expr -> Expr
alpha e =
  loop (freeVars e) e
 where
  loop env = case _ of
    Bound i ->
      Bound i
    Free n ->
      Free n
    Bind n b ->
      let {used, new} = fresh env n
      in Bind new (loop used b)
    App f a ->
      App (loop env f) (loop env a)

fresh :: Set.Set Name -> Name -> {used :: Set.Set Name, new :: Name}
fresh env n
  | n `Set.member` env = fresh env (next n)
  | otherwise = {used:  Set.insert n env, new: n}

exprToSyntax :: Expr -> Syntax
exprToSyntax =
  loop []
 where
  loop env = case _ of
    Bound i ->
      Var $ unsafePartial $ env `unsafeIndex` i
    Free n ->
      Var n
    Bind n b ->
      Lambda n $ loop (n `cons` env) b
    App f a ->
      Apply (loop env f) (loop env a)

freeVars :: Expr -> Set.Set Name
freeVars =
  walk Set.empty
 where
  walk vars = case _ of
    Bound _ ->
      vars
    Free n ->
      Set.insert n vars
    Bind _ b ->
      walk vars b
    App f a ->
      walk (walk vars f) a

globalNames :: forall a. Environment a -> Set.Set Name
globalNames = Set.fromFoldable <<< Map.keys

undefinedNames :: Expr -> Environment Expr -> Set.Set Name
undefinedNames expr env = freeVars expr `Set.difference` globalNames env

namesReferencing :: Name -> Environment Expr -> Set.Set Name
namesReferencing name =
  foldl go Set.empty <<< toList
 where
  toList :: forall a. Environment a -> List (Tuple Name a)
  toList = Map.toUnfoldable

  go keys (Tuple key expr)
    | name `Set.member` freeVars expr = Set.insert key keys
    | otherwise = keys

formatUndefinedError :: String -> Set.Set Name -> String
formatUndefinedError text missing =
  fold
    [ "No top-level definition for "
    , formatNames missing
    , " referenced in\n"
    , text
    ]

formatUndefinedWarning :: Name -> Set.Set Name -> String
formatUndefinedWarning name names =
  fold
    [ "Deleted definition "
    , show name
    , " is still referenced by "
    , formatNames names
    ]

formatNames :: Set.Set Name -> String
formatNames =
  intercalate ", " <<< map show <<< toList
 where
  toList :: forall a. Set.Set a -> List a
  toList = Set.toUnfoldable

instance prettyPrintExpr :: PrettyPrint Expr where
  prettyPrint =
    walk false
   where
    walk inApp = case _ of
      Bound i ->
        pure $ show i
      Free n ->
        pure $ show n
      Bind _ b ->
        parensIf inApp $ pure "λ. " <> walk false b
      App f a ->
        walk true f <> pure " " <> walk true a

step :: Environment Expr -> Expr -> Maybe Expr
step env = case _ of
  App (Bind n b) m ->
    pure $ substitute m b
  App f a ->
    (App <$> step env f <*> pure a) <|> (App <$> pure f <*> step env a)
  Bind n b ->
    -- When walking under a lambda, make the bound var free, then
    -- rebind it since it may have moved
    let env' = Map.delete n env
    in Bind n <$> (rebind n <$> step env' (unbind n b))
  Free n ->
    Map.lookup n env
  Bound i ->
    Nothing

substitute :: Expr -> Expr -> Expr
substitute v = walk 0
 where
  walk index = case _ of
    Bound i
      | i == index -> v
      | otherwise -> Bound i
    Free n ->
      Free n
    Bind n b ->
      Bind n $ walk (index + 1) b
    App f a ->
      App (walk index f) (walk index a)

unbind :: Name -> Expr -> Expr
unbind = substitute <<< Free

rebind :: Name -> Expr -> Expr
rebind m = walk 0
 where
  walk index = case _ of
    Bound i ->
      Bound i
    Free n
      | n == m -> Bound index
      | otherwise -> Free n
    Bind n b ->
      Bind n $ walk (index + 1) b
    App f a ->
      App (walk index f) (walk index a)


general structure done

general structure done

module D3Tagless.AttrNew where

import Control.Monad.Eff (Eff)
import D3.Base (D3, D3Selection)
import Data.Exists (Exists, mkExists, runExists)
import Data.List (List, fromFoldable)
import Data.Traversable (traverse)
import Prelude (Unit, bind, map, pure, unit, ($), (+), (<>))

type D3Effect = ∀ e. Eff (d3 :: D3 | e) Unit

type D3Selection' = Unit -- dummy definition for now

data D3Attr a = D3Attr { value :: a
                       , apply :: D3Selection' -> a -> D3Effect
                    }

dummyD3Op :: ∀ a. D3Selection' -> a -> D3Effect
dummyD3Op s a = pure unit

dummyD3OpF :: ∀ d a. D3Selection' -> (d -> a) -> D3Effect
dummyD3OpF s fa = pure unit

-- constructors to make Attributes for primitive types, used as direct value
mkAttrInt :: Int -> Exists D3Attr
mkAttrInt i = mkExists (D3Attr { value: i, apply: dummyD3Op })

mkAttrChar :: Char -> Exists D3Attr
mkAttrChar c = mkExists (D3Attr { value: c, apply: dummyD3Op })

mkAttrString :: String -> Exists D3Attr
mkAttrString s = mkExists (D3Attr { value: s, apply: dummyD3Op })

-- now constructors for Attributes that are indirect - take a callback from another type
mkAttrIntP :: ∀ d. (d -> Int) -> Exists D3Attr
mkAttrIntP fi = mkExists (D3Attr { value: fi, apply: dummyD3Op })

mkAttrCharP :: ∀ d. (d -> Char) -> Exists D3Attr
mkAttrCharP fc = mkExists (D3Attr { value: fc, apply: dummyD3Op })

mkAttrStringP :: ∀ d. (d -> String) -> Exists D3Attr
mkAttrStringP fs = mkExists (D3Attr { value: fs, apply: dummyD3Op })

-- an example list of attributes and an example main operating on them
attrList :: List (Exists D3Attr)
attrList = fromFoldable $ [ mkAttrInt 1, mkAttrString "foo", mkAttrCharP lp ]

-- an example of a typed callback function
type ExData = { name :: String, age :: Int }
lp :: ExData -> Char
lp { name, age } =
    case name, age of
    "awn", _ -> 'a'
    _, 0     -> 'b'
    _, _     -> 'c'

main2 :: D3Effect
main2 = do
    applyAll unit attrList

applyAll :: D3Selection' -> List (Exists D3Attr) -> D3Effect
applyAll s list = do
    traverse (runExists applyOne) list
    pure unit
  where
    applyOne :: ∀ a. (D3Attr a) -> D3Effect
    applyOne (D3Attr ops) = ops.apply s ops.value

-- updateAll :: List (Exists D3Attr) -> List (Exists D3Attr)
-- updateAll =
--     map (runExists updateOne)
--   where
--     updateOne :: ∀ a. D3Attr a -> Exists D3Attr
--     updateOne (D3Attr ops) = mkExists (D3Attr ( { apply: ops.apply
--                                         , update: ops.update
--                                         , value: ops.update ops.value } ))

module D3Tagless.AttrNew where

import Control.Monad.Eff (Eff)
import D3.Base (D3, D3Selection)
import Data.Exists (Exists, mkExists, runExists)
import Data.List (List, fromFoldable)
import Data.Traversable (traverse)
import Prelude (Unit, bind, map, pure, unit, ($), (+), (<>))

type D3Effect = ∀ e. Eff (d3 :: D3 | e) Unit

main2 :: D3Effect
main2 = do
    applyAll unit attrList

type D3Selection' = Unit -- dummy definition for now

dummyD3Op :: ∀ a. D3Selection' -> a -> D3Effect
dummyD3Op s a = pure unit

data D3Attr a = D3Attr { "data" :: a
                       , apply :: D3Selection' -> a -> D3Effect
                    }

attrList :: List (Exists D3Attr)
attrList = fromFoldable $ [ mkExists (D3Attr { "data": 1
                                              , apply: dummyD3Op
                                              })
                           , mkExists (D3Attr { "data": "foo"
                                              , apply: dummyD3Op
                                              })
                           ]

applyAll :: D3Selection' -> List (Exists D3Attr) -> D3Effect
applyAll s list = do
    traverse (runExists applyOne) list
    pure unit
  where
    applyOne :: ∀ a. (D3Attr a) -> D3Effect
    applyOne (D3Attr ops) = ops.apply s ops."data"

-- updateAll :: List (Exists D3Attr) -> List (Exists D3Attr)
-- updateAll =
--     map (runExists updateOne)
--   where
--     updateOne :: ∀ a. D3Attr a -> Exists D3Attr
--     updateOne (D3Attr ops) = mkExists (D3Attr ( { apply: ops.apply
--                                         , update: ops.update
--                                         , "data": ops.update ops."data" } ))


"Fix" SD-1326

"Fix" SD-1326

I have no idea at all why this fixes SD-1326, but perhaps it has
something to do with some weird DOM thing that I don't understand.

{-
Copyright 2015 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 Notebook.Component
  ( notebookComponent
  , initialState
  , QueryP()
  , StateP()
  , module Notebook.Component.Query
  , module Notebook.Component.State
  ) where

import Prelude

import Control.Bind ((=<<), join)
import Control.Monad (when)
import Control.Monad.Aff.Console (log)
import Control.UI.Browser (newTab, locationObject)

import Data.Argonaut (Json())
import Data.Array (catMaybes, nub)
import Data.BrowserFeatures (BrowserFeatures())
import Data.Either (Either(..), either)
import Data.Foldable (traverse_, for_)
import Data.Traversable (for)
import Data.Functor (($>))
import Data.Functor.Aff (liftAff)
import Data.Functor.Coproduct (Coproduct(), coproduct, left, right)
import Data.Functor.Eff (liftEff)
import Data.Lens (LensP(), view, (.~), (%~), (?~))
import Data.List as List
import Data.Maybe (Maybe(..), maybe)
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as Pathy
import Data.Set as S
import Data.String as Str
import Data.These (These(..), theseRight, theseLeft)
import Data.Time (Milliseconds(..))
import Data.Traversable (for)
import Data.Tuple (Tuple(..), fst, snd)

import DOM.HTML.Location as Location

import Halogen
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Halogen.Themes.Bootstrap3 as B

import Render.Common (glyph, fadeWhen)
import Render.CssClasses as CSS

import Model.AccessType (AccessType(..), isEditable)
import Model.Common (mkNotebookHash, mkNotebookCellHash, mkNotebookURL)
import Model.Notebook.Action as NA
import Model.Resource as R

import Notebook.Cell.CellId (CellId(), cellIdToString)
import Notebook.Cell.CellType (CellType(..), AceMode(..), cellName, cellGlyph, autorun)
import Notebook.Cell.Common.EvalQuery (CellEvalQuery(..))
import Notebook.Cell.Component (CellQueryP(), CellQuery(..), InnerCellQuery(), CellStateP(), AnyCellQuery(..))
import Notebook.Cell.JTable.Component as JTC
import Notebook.Cell.Markdown.Component as MDC
import Notebook.Cell.API.Component as APIC
import Notebook.Cell.Port (Port())
import Notebook.CellSlot (CellSlot(..))
import Notebook.Common (Slam(), forceRerender')
import Notebook.Component.Query
import Notebook.Component.State
import Notebook.FileInput.Component as Fi
import Notebook.Model as Model

import Ace.Halogen.Component as Ace

import Quasar.Aff as Quasar
import Utils.Debounced (debouncedEventSource)
import Utils.Path (DirPath())

type QueryP = Coproduct Query (ChildF CellSlot CellQueryP)
type StateP =
  InstalledState State CellStateP Query CellQueryP Slam CellSlot

type NotebookHTML = ParentHTML CellStateP Query CellQueryP Slam CellSlot
type NotebookDSL =
  ParentDSL State CellStateP Query CellQueryP Slam CellSlot

initialState :: BrowserFeatures -> StateP
initialState fs = installedState $ initialNotebook fs

notebookComponent :: Component StateP QueryP Slam
notebookComponent = parentComponent' render eval peek

render :: State -> NotebookHTML
render state =
  case state.stateMode of
    Loading ->
      H.div
        [ P.classes [ B.alert, B.alertInfo ] ]
        [ H.h1
          [ P.class_ B.textCenter ]
          [ H.text "Loading..." ]
          -- We need to render the cells but have them invisible during loading
          -- otherwise the various nested components won't initialise correctly
        , renderCells false
        ]
    Ready ->
      -- WARNING: Very strange things happen when this is not in a div; see SD-1326.
      H.div_
        [ renderCells true
        ]
    Error err ->
      H.div
        [ P.classes [ B.alert, B.alertDanger ] ]
        [ H.h1
            [ P.class_ B.textCenter ]
            [ H.text err ]
        ]

  where

  renderCells visible =
    -- The key here helps out virtual-dom: the entire subtree will be moved
    -- when the loading message disappears, rather than being reconstructed in
    -- the parent element
    H.div ([P.key "notebook-cells"] <> if visible then [] else [P.class_ CSS.invisible])
      $ List.fromList (map renderCell state.cells)
     <> if isEditable state.accessType then [newCellMenu state] else []

  renderCell cellDef =
    H.div
      ([ P.key ("cell" <> cellIdToString cellDef.id)
       ] <> maybe [] (viewingStyle cellDef) state.viewingCell)
      [ H.Slot cellDef.ctor ]

  viewingStyle cellDef cid =
    if cellDef.id == cid || cellIsLinkedCellOf { childId: cellDef.id, parentId: cid } state
      then []
      else [ P.class_ CSS.invisible ]

newCellMenu :: State -> NotebookHTML
newCellMenu state =
  H.ul
    [ P.class_ CSS.newCellMenu ]
    [ H.li_
        [ H.button
            [ P.classes [B.btnLg, B.btnLink]
            , E.onClick (E.input_ ToggleAddCellMenu)
            , P.title "Insert new cell"
            ]
            [ glyph
                if state.isAddingCell
                then B.glyphiconMinus
                else B.glyphiconPlus
            ]
        ]
    , insertMenuItem (Ace SQLMode)
    , insertMenuItem (Ace MarkdownMode)
    , insertMenuItem Explore
    , insertMenuItem Search
    , insertMenuItem API
    ]
  where
  insertMenuItem :: CellType -> NotebookHTML
  insertMenuItem cellType =
    H.li_
      [ H.button
          [ P.title (cellName cellType)
          , E.onClick $ E.input_ (AddCell cellType)
          , P.classes (fadeWhen $ not (state.isAddingCell))
          ]
          [ glyph (cellGlyph cellType) ]
      ]

eval :: Natural Query NotebookDSL
eval (AddCell cellType next) = modify (addCell cellType Nothing) $> next
eval (RunActiveCell next) =
  (maybe (pure unit) runCell =<< gets (_.activeCellId)) $> next
eval (ToggleAddCellMenu next) = modify (_isAddingCell %~ not) $> next
eval (LoadNotebook fs dir next) = do
  modify (_stateMode .~ Loading)
  json <- liftAff $ Quasar.load $ dir </> Pathy.file "index"
  case Model.decode =<< json of
    Left err -> do
      liftAff $ log err
      modify (_stateMode .~ Error "There was a problem decoding the saved notebook")
      pure next
    Right model ->
      let peeledPath = Pathy.peel dir
          path = fst <$> peeledPath
          name = either Just (const Nothing) <<< snd =<< peeledPath
      in case fromModel fs path name model of
        Tuple cells st -> do
          set st
          forceRerender'
          ranCells <- catMaybes <$> for cells \cell -> do
            query (CellSlot cell.cellId) $ left $ action $ LoadCell cell
            pure if cell.hasRun then Just cell.cellId else Nothing
          -- We only need to run the root node in each subgraph, as doing so
          -- will result in all child nodes being run also as the outputs
          -- propagate down each subgraph.
          traverse_ runCell $ nub $ flip findRoot st <$> ranCells
          modify (_stateMode .~ Ready)
          pure next
eval (ExploreFile fs res next) = do
  modify
    $ (_path .~ Pathy.parentDir res)
    <<< (_browserFeatures .~ fs)
    <<< (addCell Explore Nothing)
  forceRerender'
  query (CellSlot zero) $ right
    $ ChildF unit $ right $ ExploreQuery
    $ right $ ChildF unit
    $ action $ Fi.SelectFile $ R.File res
  forceRerender'
  runCell zero
  pure next
eval (Publish next) = do
  state <- get
  case state.path of
    Nothing -> pure next
    Just path -> do
      let publish name = newTab $ mkNotebookURL name path (NA.Load ReadOnly)
      liftEff $ maybe (pure unit) (publish <<< nameFromDirName) $ theseLeft state.name
      pure next
eval (Reset fs dir next) = do
  let nb = initialNotebook fs
      peeledPath = Pathy.peel dir
      path = fst <$> peeledPath
      name = maybe nb.name This (either Just (const Nothing) <<< snd =<< peeledPath)
  set $ nb { path = path, name = name }
  pure next
eval (SetName name next) = modify (_name .~ That name) $> next
eval (SetAccessType aType next) = modify (_accessType .~ aType) $> next
eval (GetPath k) = k <$> gets _.path
eval (GetNameToSave k) = do
  name <- gets _.name
  pure $ k
    $ map (\x -> Pathy.DirName $ x ++ "." ++ Config.notebookExtension)
    $ theseRight name
eval (SetViewingCell mbcid next) = modify (_viewingCell .~ mbcid) $> next
eval (SaveNotebook next) = saveNotebook unit $> next
eval (RunPendingCells next) = runPendingCells unit $> next
eval (GetGlobalVarMap k) = k <$> gets _.globalVarMap
eval (SetGlobalVarMap m next) = modify (_globalVarMap .~ m) $> next

peek :: forall a. ChildF CellSlot CellQueryP a -> NotebookDSL Unit
peek (ChildF (CellSlot cellId) q) =
  coproduct (peekCell cellId) (peekCellInner cellId) q

-- | Peek on the cell component to observe actions from the cell control
-- | buttons.
peekCell :: forall a. CellId -> CellQuery a -> NotebookDSL Unit
peekCell cellId q = case q of
  RunCell _ -> runCell cellId
  RefreshCell _ -> runCell <<< findRoot cellId =<< get
  TrashCell _ -> do
    descendants <- gets (findDescendants cellId)
    modify $ removeCells (S.insert cellId descendants)
  CreateChildCell cellType _ -> do
    Tuple st newCellId <- gets $ addCell' cellType (Just cellId)
    set st
    forceRerender'
    input <- map join $ query (CellSlot cellId) $ left (request GetOutput)
    case input of
      Just input' -> do
        path <- gets notebookPath
        let setupInfo = { notebookPath: path, inputPort: input' }
        void $ query (CellSlot newCellId)
             $ right $ ChildF unit $ left $ action (SetupCell setupInfo)
      Nothing -> pure unit
    when (autorun cellType) $ runCell newCellId
  ShareCell _ -> pure unit
  _ -> pure unit

-- | Peek on the inner cell components to observe `NotifyRunCell`, which is
-- | raised by actions within a cell that should cause the cell to run.
peekCellInner :: forall a. CellId -> ChildF Unit InnerCellQuery a -> NotebookDSL Unit
peekCellInner cellId (ChildF _ q) =
  coproduct (peekEvalCell cellId) (peekAnyCell cellId) q

peekEvalCell :: forall a. CellId -> CellEvalQuery a -> NotebookDSL Unit
peekEvalCell cellId (NotifyRunCell _) = runCell cellId
peekEvalCell _ _ = pure unit

peekAnyCell :: forall a. CellId -> AnyCellQuery a -> NotebookDSL Unit
peekAnyCell cellId q = do
  when (queryShouldRun q) $ runCell cellId
  when (queryShouldSave q) $ triggerSave unit
  pure unit

queryShouldRun :: forall a. AnyCellQuery a -> Boolean
queryShouldRun (VizQuery q) = true
queryShouldRun (JTableQuery q) = JTC.queryShouldRun q
queryShouldRun (MarkdownQuery q) = MDC.queryShouldRun q
queryShouldRun (APIQuery q) = APIC.queryShouldRun q
queryShouldRun _ = false

queryShouldSave  :: forall a. AnyCellQuery a -> Boolean
queryShouldSave (AceQuery q) =
  coproduct evalQueryShouldSave aceQueryShouldSave q
queryShouldSave _ = true

evalQueryShouldSave :: forall a. CellEvalQuery a -> Boolean
evalQueryShouldSave _ = true

aceQueryShouldSave
  :: forall p a. ChildF p Ace.AceQuery a -> Boolean
aceQueryShouldSave (ChildF _ q) =
  case q of
    Ace.TextChanged _ -> true
    _ -> false

-- | Runs all cell that are present in the set of pending cells.
runPendingCells :: Unit -> NotebookDSL Unit
runPendingCells _ = do
  cells <- gets _.pendingCells
  modify (_pendingCells .~ S.empty)
  traverse_ runCell' cells
  where
  runCell' :: CellId -> NotebookDSL Unit
  runCell' cellId = do
    mbParentId <- gets (findParent cellId)
    case mbParentId of
      -- if there's no parent there's no input port value to pass through
      Nothing -> updateCell Nothing cellId
      Just parentId -> do
        value <- map join $ query (CellSlot parentId) $ left (request GetOutput)
        case value of
          -- if there's a parent but no output the parent cell hasn't been evaluated
          -- yet, so we can't run this cell either
          Nothing -> pure unit
          -- if there's a parent and an output, pass it on as this cell's input
          Just p -> updateCell (Just p) cellId
    triggerSave unit

-- | Enqueues the cell with the specified ID in the set of cells that are
-- | pending to run and enqueues a debounced query to trigger the cells to
-- | actually run.
runCell :: CellId -> NotebookDSL Unit
runCell cellId = do
  modify (addPendingCell cellId)
  _runTrigger `fireDebouncedQuery` RunPendingCells

-- | Updates the evaluated value for a cell by running it with the specified
-- | input and then runs any cells that depend on the cell's output with the
-- | new result.
updateCell :: Maybe Port -> CellId -> NotebookDSL Unit
updateCell inputPort cellId = do
  path <- gets notebookPath
  globalVarMap <- gets _.globalVarMap
  let input = { notebookPath: path, inputPort, cellId, globalVarMap }
  result <- join <$> (query (CellSlot cellId) $ left $ request (UpdateCell input))
  maybe (pure unit) (runCellDescendants cellId) result
  where
  runCellDescendants :: CellId -> Port -> NotebookDSL Unit
  runCellDescendants parentId value = do
    children <- gets (findChildren parentId)
    traverse_ (updateCell (Just value)) children

-- | Triggers the query for autosave. This does not immediate perform the save
-- | action, but instead enqueues a debounced query to trigger the actual save.
triggerSave :: Unit -> NotebookDSL Unit
triggerSave _ = _saveTrigger `fireDebouncedQuery` SaveNotebook

-- | Fires the specified debouced query trigger with the passed query. This
-- | function also handles constructing the initial trigger if it has not yet
-- | been created.
fireDebouncedQuery
  :: LensP State (Maybe DebounceTrigger)
  -> Action Query
  -> NotebookDSL Unit
fireDebouncedQuery lens act = do
  t <- gets (view lens) >>= \mbt -> case mbt of
    Just t' -> pure t'
    Nothing -> do
      t' <- debouncedEventSource liftEff subscribe' (Milliseconds 500.0)
      modify (lens ?~ t')
      pure t'
  liftH $ liftH $ t $ action $ act

-- | Saves the notebook as JSON, using the current values present in the state.
saveNotebook :: Unit -> NotebookDSL Unit
saveNotebook _ = do
  st <- get
  for_ st.path \path -> do
    cells <- catMaybes <$> for (List.fromList st.cells) \cell ->
      query (CellSlot cell.id) $ left $ request (SaveCell cell.id cell.ty)

    let json = Model.encode { cells, dependencies: st.dependencies }

    savedName <- case st.name of
      This name -> save path name json
      That name -> do
        newName <- getNewName' path name
        save path newName json
      Both oldName newName -> do
        save path oldName json
        if newName == nameFromDirName oldName
          then pure oldName
          else rename path oldName newName

    modify (_name .~ This savedName)

    let
      notebookHash =
        case st.viewingCell of
          Nothing -> mkNotebookHash (nameFromDirName savedName) path (NA.Load st.accessType) st.globalVarMap
          Just cid -> mkNotebookCellHash (nameFromDirName savedName) path cid st.accessType st.globalVarMap
    liftEff $ locationObject >>= Location.setHash notebookHash

  where

  -- Finds a new name for a notebook in the specified parent directory, using
  -- a name value as a basis to start with.
  getNewName' :: DirPath -> String -> NotebookDSL Pathy.DirName
  getNewName' dir name =
    let baseName = name ++ "." ++ Config.notebookExtension
    in liftAff $ Pathy.DirName <$> Quasar.getNewName dir baseName

  -- Saves a notebook and returns the name it was saved as.
  save :: DirPath -> Pathy.DirName -> Json -> NotebookDSL Pathy.DirName
  save dir name json = do
    let notebookPath = dir </> Pathy.dir' name </> Pathy.file "index"
    liftAff $ Quasar.save notebookPath json
    pure name

  -- Renames a notebook and returns the new name it was changed to.
  rename :: DirPath -> Pathy.DirName -> String -> NotebookDSL Pathy.DirName
  rename dir oldName newName = do
    newName' <- getNewName' dir newName
    let oldPath = dir </> Pathy.dir' oldName
        newPath = dir </> Pathy.dir' newName'
    liftAff $ Quasar.move (R.Directory oldPath) (Right newPath)
    pure newName'

-- | Takes a `DirName` for a saved notebook and returns the name part without
-- | the `.slam` extension.
nameFromDirName :: Pathy.DirName -> String
nameFromDirName dirName =
  let name = Pathy.runDirName dirName
  in Str.take (Str.length name - Str.length Config.notebookExtension - 1) name

{-
Copyright 2015 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 Notebook.Component
  ( notebookComponent
  , initialState
  , QueryP()
  , StateP()
  , module Notebook.Component.Query
  , module Notebook.Component.State
  ) where

import Prelude

import Control.Bind ((=<<), join)
import Control.Monad (when)
import Control.Monad.Aff.Console (log)
import Control.UI.Browser (newTab, locationObject)

import Data.Argonaut (Json())
import Data.Array (catMaybes, nub)
import Data.BrowserFeatures (BrowserFeatures())
import Data.Either (Either(..), either)
import Data.Foldable (traverse_, for_)
import Data.Traversable (for)
import Data.Functor (($>))
import Data.Functor.Aff (liftAff)
import Data.Functor.Coproduct (Coproduct(), coproduct, left, right)
import Data.Functor.Eff (liftEff)
import Data.Lens (LensP(), view, (.~), (%~), (?~))
import Data.List as List
import Data.Maybe (Maybe(..), maybe)
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as Pathy
import Data.Set as S
import Data.String as Str
import Data.These (These(..), theseRight, theseLeft)
import Data.Time (Milliseconds(..))
import Data.Traversable (for)
import Data.Tuple (Tuple(..), fst, snd)

import DOM.HTML.Location as Location

import Halogen
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Halogen.Themes.Bootstrap3 as B

import Render.Common (glyph, fadeWhen)
import Render.CssClasses as CSS

import Model.AccessType (AccessType(..), isEditable)
import Model.Common (mkNotebookHash, mkNotebookCellHash, mkNotebookURL)
import Model.Notebook.Action as NA
import Model.Resource as R

import Notebook.Cell.CellId (CellId(), cellIdToString)
import Notebook.Cell.CellType (CellType(..), AceMode(..), cellName, cellGlyph, autorun)
import Notebook.Cell.Common.EvalQuery (CellEvalQuery(..))
import Notebook.Cell.Component (CellQueryP(), CellQuery(..), InnerCellQuery(), CellStateP(), AnyCellQuery(..))
import Notebook.Cell.JTable.Component as JTC
import Notebook.Cell.Markdown.Component as MDC
import Notebook.Cell.API.Component as APIC
import Notebook.Cell.Port (Port())
import Notebook.CellSlot (CellSlot(..))
import Notebook.Common (Slam(), forceRerender')
import Notebook.Component.Query
import Notebook.Component.State
import Notebook.FileInput.Component as Fi
import Notebook.Model as Model

import Ace.Halogen.Component as Ace

import Quasar.Aff as Quasar
import Utils.Debounced (debouncedEventSource)
import Utils.Path (DirPath())

type QueryP = Coproduct Query (ChildF CellSlot CellQueryP)
type StateP =
  InstalledState State CellStateP Query CellQueryP Slam CellSlot

type NotebookHTML = ParentHTML CellStateP Query CellQueryP Slam CellSlot
type NotebookDSL =
  ParentDSL State CellStateP Query CellQueryP Slam CellSlot

initialState :: BrowserFeatures -> StateP
initialState fs = installedState $ initialNotebook fs

notebookComponent :: Component StateP QueryP Slam
notebookComponent = parentComponent' render eval peek

render :: State -> NotebookHTML
render state =
  case state.stateMode of
    Loading ->
      H.div
        [ P.classes [ B.alert, B.alertInfo ] ]
        [ H.h1
          [ P.class_ B.textCenter ]
          [ H.text "Loading..." ]
          -- We need to render the cells but have them invisible during loading
          -- otherwise the various nested components won't initialise correctly
        , renderCells false
        ]
    Ready -> renderCells true
    Error err ->
      H.div
        [ P.classes [ B.alert, B.alertDanger ] ]
        [ H.h1
            [ P.class_ B.textCenter ]
            [ H.text err ]
        ]

  where

  renderCells visible =
    -- The key here helps out virtual-dom: the entire subtree will be moved
    -- when the loading message disappears, rather than being reconstructed in
    -- the parent element
    H.div ([P.key "notebook-cells"] <> if visible then [] else [P.class_ CSS.invisible])
      $ List.fromList (map renderCell state.cells)
     <> if isEditable state.accessType then [newCellMenu state] else []

  renderCell cellDef =
    H.div
      ([ P.key ("cell" <> cellIdToString cellDef.id)
       ] <> maybe [] (viewingStyle cellDef) state.viewingCell)
      [ H.Slot cellDef.ctor ]

  viewingStyle cellDef cid =
    if cellDef.id == cid || cellIsLinkedCellOf { childId: cellDef.id, parentId: cid } state
      then []
      else [ P.class_ CSS.invisible ]

newCellMenu :: State -> NotebookHTML
newCellMenu state =
  H.ul
    [ P.class_ CSS.newCellMenu ]
    [ H.li_
        [ H.button
            [ P.classes [B.btnLg, B.btnLink]
            , E.onClick (E.input_ ToggleAddCellMenu)
            , P.title "Insert new cell"
            ]
            [ glyph
                if state.isAddingCell
                then B.glyphiconMinus
                else B.glyphiconPlus
            ]
        ]
    , insertMenuItem (Ace SQLMode)
    , insertMenuItem (Ace MarkdownMode)
    , insertMenuItem Explore
    , insertMenuItem Search
    , insertMenuItem API
    ]
  where
  insertMenuItem :: CellType -> NotebookHTML
  insertMenuItem cellType =
    H.li_
      [ H.button
          [ P.title (cellName cellType)
          , E.onClick $ E.input_ (AddCell cellType)
          , P.classes (fadeWhen $ not (state.isAddingCell))
          ]
          [ glyph (cellGlyph cellType) ]
      ]

eval :: Natural Query NotebookDSL
eval (AddCell cellType next) = modify (addCell cellType Nothing) $> next
eval (RunActiveCell next) =
  (maybe (pure unit) runCell =<< gets (_.activeCellId)) $> next
eval (ToggleAddCellMenu next) = modify (_isAddingCell %~ not) $> next
eval (LoadNotebook fs dir next) = do
  modify (_stateMode .~ Loading)
  json <- liftAff $ Quasar.load $ dir </> Pathy.file "index"
  case Model.decode =<< json of
    Left err -> do
      liftAff $ log err
      modify (_stateMode .~ Error "There was a problem decoding the saved notebook")
      pure next
    Right model ->
      let peeledPath = Pathy.peel dir
          path = fst <$> peeledPath
          name = either Just (const Nothing) <<< snd =<< peeledPath
      in case fromModel fs path name model of
        Tuple cells st -> do
          set st
          forceRerender'
          ranCells <- catMaybes <$> for cells \cell -> do
            query (CellSlot cell.cellId) $ left $ action $ LoadCell cell
            pure if cell.hasRun then Just cell.cellId else Nothing
          -- We only need to run the root node in each subgraph, as doing so
          -- will result in all child nodes being run also as the outputs
          -- propagate down each subgraph.
          traverse_ runCell $ nub $ flip findRoot st <$> ranCells
          modify (_stateMode .~ Ready)
          pure next
eval (ExploreFile fs res next) = do
  modify
    $ (_path .~ Pathy.parentDir res)
    <<< (_browserFeatures .~ fs)
    <<< (addCell Explore Nothing)
  forceRerender'
  query (CellSlot zero) $ right
    $ ChildF unit $ right $ ExploreQuery
    $ right $ ChildF unit
    $ action $ Fi.SelectFile $ R.File res
  forceRerender'
  runCell zero
  pure next
eval (Publish next) = do
  state <- get
  case state.path of
    Nothing -> pure next
    Just path -> do
      let publish name = newTab $ mkNotebookURL name path (NA.Load ReadOnly)
      liftEff $ maybe (pure unit) (publish <<< nameFromDirName) $ theseLeft state.name
      pure next
eval (Reset fs dir next) = do
  let nb = initialNotebook fs
      peeledPath = Pathy.peel dir
      path = fst <$> peeledPath
      name = maybe nb.name This (either Just (const Nothing) <<< snd =<< peeledPath)
  set $ nb { path = path, name = name }
  pure next
eval (SetName name next) = modify (_name .~ That name) $> next
eval (SetAccessType aType next) = modify (_accessType .~ aType) $> next
eval (GetPath k) = k <$> gets _.path
eval (GetNameToSave k) = do
  name <- gets _.name
  pure $ k
    $ map (\x -> Pathy.DirName $ x ++ "." ++ Config.notebookExtension)
    $ theseRight name
eval (SetViewingCell mbcid next) = modify (_viewingCell .~ mbcid) $> next
eval (SaveNotebook next) = saveNotebook unit $> next
eval (RunPendingCells next) = runPendingCells unit $> next
eval (GetGlobalVarMap k) = k <$> gets _.globalVarMap
eval (SetGlobalVarMap m next) = modify (_globalVarMap .~ m) $> next

peek :: forall a. ChildF CellSlot CellQueryP a -> NotebookDSL Unit
peek (ChildF (CellSlot cellId) q) =
  coproduct (peekCell cellId) (peekCellInner cellId) q

-- | Peek on the cell component to observe actions from the cell control
-- | buttons.
peekCell :: forall a. CellId -> CellQuery a -> NotebookDSL Unit
peekCell cellId q = case q of
  RunCell _ -> runCell cellId
  RefreshCell _ -> runCell <<< findRoot cellId =<< get
  TrashCell _ -> do
    descendants <- gets (findDescendants cellId)
    modify $ removeCells (S.insert cellId descendants)
  CreateChildCell cellType _ -> do
    Tuple st newCellId <- gets $ addCell' cellType (Just cellId)
    set st
    forceRerender'
    input <- map join $ query (CellSlot cellId) $ left (request GetOutput)
    case input of
      Just input' -> do
        path <- gets notebookPath
        let setupInfo = { notebookPath: path, inputPort: input' }
        void $ query (CellSlot newCellId)
             $ right $ ChildF unit $ left $ action (SetupCell setupInfo)
      Nothing -> pure unit
    when (autorun cellType) $ runCell newCellId
  ShareCell _ -> pure unit
  _ -> pure unit

-- | Peek on the inner cell components to observe `NotifyRunCell`, which is
-- | raised by actions within a cell that should cause the cell to run.
peekCellInner :: forall a. CellId -> ChildF Unit InnerCellQuery a -> NotebookDSL Unit
peekCellInner cellId (ChildF _ q) =
  coproduct (peekEvalCell cellId) (peekAnyCell cellId) q

peekEvalCell :: forall a. CellId -> CellEvalQuery a -> NotebookDSL Unit
peekEvalCell cellId (NotifyRunCell _) = runCell cellId
peekEvalCell _ _ = pure unit

peekAnyCell :: forall a. CellId -> AnyCellQuery a -> NotebookDSL Unit
peekAnyCell cellId q = do
  when (queryShouldRun q) $ runCell cellId
  when (queryShouldSave q) $ triggerSave unit
  pure unit

queryShouldRun :: forall a. AnyCellQuery a -> Boolean
queryShouldRun (VizQuery q) = true
queryShouldRun (JTableQuery q) = JTC.queryShouldRun q
queryShouldRun (MarkdownQuery q) = MDC.queryShouldRun q
queryShouldRun (APIQuery q) = APIC.queryShouldRun q
queryShouldRun _ = false

queryShouldSave  :: forall a. AnyCellQuery a -> Boolean
queryShouldSave (AceQuery q) =
  coproduct evalQueryShouldSave aceQueryShouldSave q
queryShouldSave _ = true

evalQueryShouldSave :: forall a. CellEvalQuery a -> Boolean
evalQueryShouldSave _ = true

aceQueryShouldSave
  :: forall p a. ChildF p Ace.AceQuery a -> Boolean
aceQueryShouldSave (ChildF _ q) =
  case q of
    Ace.TextChanged _ -> true
    _ -> false

-- | Runs all cell that are present in the set of pending cells.
runPendingCells :: Unit -> NotebookDSL Unit
runPendingCells _ = do
  cells <- gets _.pendingCells
  modify (_pendingCells .~ S.empty)
  traverse_ runCell' cells
  where
  runCell' :: CellId -> NotebookDSL Unit
  runCell' cellId = do
    mbParentId <- gets (findParent cellId)
    case mbParentId of
      -- if there's no parent there's no input port value to pass through
      Nothing -> updateCell Nothing cellId
      Just parentId -> do
        value <- map join $ query (CellSlot parentId) $ left (request GetOutput)
        case value of
          -- if there's a parent but no output the parent cell hasn't been evaluated
          -- yet, so we can't run this cell either
          Nothing -> pure unit
          -- if there's a parent and an output, pass it on as this cell's input
          Just p -> updateCell (Just p) cellId
    triggerSave unit

-- | Enqueues the cell with the specified ID in the set of cells that are
-- | pending to run and enqueues a debounced query to trigger the cells to
-- | actually run.
runCell :: CellId -> NotebookDSL Unit
runCell cellId = do
  modify (addPendingCell cellId)
  _runTrigger `fireDebouncedQuery` RunPendingCells

-- | Updates the evaluated value for a cell by running it with the specified
-- | input and then runs any cells that depend on the cell's output with the
-- | new result.
updateCell :: Maybe Port -> CellId -> NotebookDSL Unit
updateCell inputPort cellId = do
  path <- gets notebookPath
  globalVarMap <- gets _.globalVarMap
  let input = { notebookPath: path, inputPort, cellId, globalVarMap }
  result <- join <$> (query (CellSlot cellId) $ left $ request (UpdateCell input))
  maybe (pure unit) (runCellDescendants cellId) result
  where
  runCellDescendants :: CellId -> Port -> NotebookDSL Unit
  runCellDescendants parentId value = do
    children <- gets (findChildren parentId)
    traverse_ (updateCell (Just value)) children

-- | Triggers the query for autosave. This does not immediate perform the save
-- | action, but instead enqueues a debounced query to trigger the actual save.
triggerSave :: Unit -> NotebookDSL Unit
triggerSave _ = _saveTrigger `fireDebouncedQuery` SaveNotebook

-- | Fires the specified debouced query trigger with the passed query. This
-- | function also handles constructing the initial trigger if it has not yet
-- | been created.
fireDebouncedQuery
  :: LensP State (Maybe DebounceTrigger)
  -> Action Query
  -> NotebookDSL Unit
fireDebouncedQuery lens act = do
  t <- gets (view lens) >>= \mbt -> case mbt of
    Just t' -> pure t'
    Nothing -> do
      t' <- debouncedEventSource liftEff subscribe' (Milliseconds 500.0)
      modify (lens ?~ t')
      pure t'
  liftH $ liftH $ t $ action $ act

-- | Saves the notebook as JSON, using the current values present in the state.
saveNotebook :: Unit -> NotebookDSL Unit
saveNotebook _ = do
  st <- get
  for_ st.path \path -> do
    cells <- catMaybes <$> for (List.fromList st.cells) \cell ->
      query (CellSlot cell.id) $ left $ request (SaveCell cell.id cell.ty)

    let json = Model.encode { cells, dependencies: st.dependencies }

    savedName <- case st.name of
      This name -> save path name json
      That name -> do
        newName <- getNewName' path name
        save path newName json
      Both oldName newName -> do
        save path oldName json
        if newName == nameFromDirName oldName
          then pure oldName
          else rename path oldName newName

    modify (_name .~ This savedName)

    let
      notebookHash =
        case st.viewingCell of
          Nothing -> mkNotebookHash (nameFromDirName savedName) path (NA.Load st.accessType) st.globalVarMap
          Just cid -> mkNotebookCellHash (nameFromDirName savedName) path cid st.accessType st.globalVarMap
    liftEff $ locationObject >>= Location.setHash notebookHash

  where

  -- Finds a new name for a notebook in the specified parent directory, using
  -- a name value as a basis to start with.
  getNewName' :: DirPath -> String -> NotebookDSL Pathy.DirName
  getNewName' dir name =
    let baseName = name ++ "." ++ Config.notebookExtension
    in liftAff $ Pathy.DirName <$> Quasar.getNewName dir baseName

  -- Saves a notebook and returns the name it was saved as.
  save :: DirPath -> Pathy.DirName -> Json -> NotebookDSL Pathy.DirName
  save dir name json = do
    let notebookPath = dir </> Pathy.dir' name </> Pathy.file "index"
    liftAff $ Quasar.save notebookPath json
    pure name

  -- Renames a notebook and returns the new name it was changed to.
  rename :: DirPath -> Pathy.DirName -> String -> NotebookDSL Pathy.DirName
  rename dir oldName newName = do
    newName' <- getNewName' dir newName
    let oldPath = dir </> Pathy.dir' oldName
        newPath = dir </> Pathy.dir' newName'
    liftAff $ Quasar.move (R.Directory oldPath) (Right newPath)
    pure newName'

-- | Takes a `DirName` for a saved notebook and returns the name part without
-- | the `.slam` extension.
nameFromDirName :: Pathy.DirName -> String
nameFromDirName dirName =
  let name = Pathy.runDirName dirName
  in Str.take (Str.length name - Str.length Config.notebookExtension - 1) name


Remove S appendix from function names

Remove S appendix from function names

Not needed now we can import qualified

module Data.String where

foreign import charAt
  "function charAt(i) {\
  \  return function(s) {\
  \    return s.charAt(i); \
  \  };\
  \}" :: Number -> String -> String

foreign import fromCharCode
  "function fromCharCode(n) {\
  \  return String.fromCharCode(n);\
  \}" :: Number -> String

foreign import indexOf
  "function indexOf(s1) {\
  \  return function(s2) {\
  \    return s1.indexOf(s2);\
  \  }; \
  \}" :: String -> String -> Number

foreign import lastIndexOf
  "function lastIndexOf(s1) {\
  \  return function(s2) {\
  \    return s1.lastIndexOf(s2);\
  \  };\
  \}" :: String -> String -> Number

foreign import length
  "function length(s) {\
  \  return s.length;\
  \}" :: String -> Number

foreign import localeCompare
  "function localeCompare(s1) {\
  \  return function(s2) {\
  \    return s1.localeCompare(s2);\
  \  };\
  \}" :: String -> String -> Number

foreign import replace
  "function replace(s1) {\
  \  return function(s2) {\
  \    return function(s3) {\
  \      return s3.replace(s1, s2);\
  \    };\
  \  };\
  \}" :: String -> String -> String -> String

foreign import slice
  "function slice(st) {\
  \  return function(e) {\
  \    return function(s) {\
  \      return s.slice(st, e);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import split
  "function split(sep) {\
  \  return function(s) {\
  \    return s.split(sep);\
  \  };\
  \}" :: String -> String -> [String]

foreign import substr
  "function substr(n1) {\
  \  return function(n2) {\
  \    return function(s) {\
  \      return s.substr(n1, n2);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import substring
  "function substring(n1) {\
  \  return function(n2) {\
  \    return function(s) {\
  \      return s.substring(n1, n2);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import toLower
  "function toLower(s) {\
  \  return s.toLowerCase();\
  \}" :: String -> String

foreign import toUpper
  "function toUpper(s) {\
  \  return s.toUpperCase();\
  \}" :: String -> String

foreign import trim
  "function trim(s) {\
  \  return s.trim();\
  \}" :: String -> String

module Data.String where

foreign import charAt
  "function charAt(i) {\
  \  return function(s) {\
  \    return s.charAt(i); \
  \  };\
  \}" :: Number -> String -> String

foreign import fromCharCode
  "function fromCharCode(n) {\
  \  return String.fromCharCode(n);\
  \}" :: Number -> String

foreign import indexOfS
  "function indexOfS(s1) {\
  \  return function(s2) {\
  \    return s1.indexOf(s2);\
  \  }; \
  \}" :: String -> String -> Number

foreign import lastIndexOfS
  "function lastIndexOfS(s1) {\
  \  return function(s2) {\
  \    return s1.lastIndexOf(s2);\
  \  };\
  \}" :: String -> String -> Number

foreign import lengthS
  "function lengthS(s) {\
  \  return s.length;\
  \}" :: String -> Number

foreign import localeCompare
  "function localeCompare(s1) {\
  \  return function(s2) {\
  \    return s1.localeCompare(s2);\
  \  };\
  \}" :: String -> String -> Number

foreign import replace
  "function replace(s1) {\
  \  return function(s2) {\
  \    return function(s3) {\
  \      return s3.replace(s1, s2);\
  \    };\
  \  };\
  \}" :: String -> String -> String -> String

foreign import sliceS
  "function sliceS(st) {\
  \  return function(e) {\
  \    return function(s) {\
  \      return s.slice(st, e);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import split
  "function split(sep) {\
  \  return function(s) {\
  \    return s.split(sep);\
  \  };\
  \}" :: String -> String -> [String]

foreign import substr
  "function substr(n1) {\
  \  return function(n2) {\
  \    return function(s) {\
  \      return s.substr(n1, n2);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import substring
  "function substring(n1) {\
  \  return function(n2) {\
  \    return function(s) {\
  \      return s.substring(n1, n2);\
  \    };\
  \  };\
  \}" :: Number -> Number -> String -> String

foreign import toLower
  "function toLower(s) {\
  \  return s.toLowerCase();\
  \}" :: String -> String

foreign import toUpper
  "function toUpper(s) {\
  \  return s.toUpperCase();\
  \}" :: String -> String

foreign import trim
  "function trim(s) {\
  \  return s.trim();\
  \}" :: String -> String