Made Greek letter mu be equivalent to micro prefix

While the parser already understands the micro sign to mean the micro prefix, it should also understand the Greek letter mu too, right?

-- | This module defines the parser for the Insect language.
module Insect.Parser
  ( parseInsect
  ) where

import Prelude hiding (degree)

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

import Quantities (DerivedUnit, atto, bit, byte, centi, day, deci, degree, exa,
                   femto, foot, giga, gram, hecto, hertz, hour, inch, joule,
                   kilo, mega, meter, micro, mile, milli, minute, nano,
                   newton, ounce, peta, pico, pound, radian, second, tera,
                   watt, week, yard, (./))

import Data.Array (some, fromFoldable)
import Data.Either (Either)
import Data.Foldable (foldr)
import Data.List (List, many, init, last)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.NonEmpty (NonEmpty, (:|), foldl1)
import Data.String (fromCharArray, singleton)
import Global (readFloat, isFinite)

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 (Func(..), BinOp(..), Expression(..), Command(..),
                        Statement(..))

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

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

-- | The language definition.
insectLanguage ∷ LanguageDef
insectLanguage = LanguageDef
  { commentStart: ""
  , commentEnd: ""
  , commentLine: "#"
  , nestedComments: false
  , identStart: letter <|> char '_'
  , identLetter: identLetter
  , opStart: oneOf ['+', '-', '*', '·', '/', '^', '=', '²', '³']
  , opLetter: oneOf ['>', '*']
  , reservedNames: ["help", "?", "list", "ls", "reset", "clear"]
  , 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 Number
number = do
  intPart ← digits

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

  mExpPart ← optionMaybe (append <$> string "e" <*> signAndDigits)
  let expPart = fromMaybe "" mExpPart

  whiteSpace

  let floatStr = intPart <> fracPart <> expPart
  let num = readFloat floatStr

  if isFinite num
    then pure num
    else fail $ "readFloat 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)

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

-- | Parse a SI prefix like `µ` or `G`.
siPrefix ∷ P (DerivedUnit → DerivedUnit)
siPrefix =
      (string "a" *> pure atto)
  <|> (string "f" *> pure femto)
  <|> (string "p" *> pure pico)
  <|> (string "n" *> pure nano)
  <|> (string "µ" *> pure micro) -- Micro sign U+00B5
  <|> (string "μ" *> pure micro) -- Greek small letter mu U+039C
  <|> (string "m" *> pure milli)
  <|> (string "c" *> pure centi)
  <|> (string "d" *> pure deci)
  <|> (string "h" *> pure hecto)
  <|> (string "k" *> pure kilo)
  <|> (string "M" *> pure mega)
  <|> (string "G" *> pure giga)
  <|> (string "T" *> pure tera)
  <|> (string "P" *> pure peta)
  <|> (string "E" *> pure exa)
  <|> pure id

-- | Parse a normal (SI-conform, non-imperical) unit, like `N` or `watt`.
normalUnit ∷ P DerivedUnit
normalUnit =
      (string "radians" *> pure radian)
  <|> (string "radian"  *> pure radian)
  <|> (string "rad"     *> pure radian)
  <|> (string "degrees" *> pure degree)
  <|> (string "degree"  *> pure degree)
  <|> (string "deg"     *> pure degree)
  <|> (string "°"       *> pure degree)
  <|> (string "hertz"   *> pure hertz)
  <|> (string "Hz"      *> pure hertz)
  <|> (string "newton"  *> pure newton)
  <|> (string "N"       *> pure newton)
  <|> (string "joules"  *> pure joule)
  <|> (string "joule"   *> pure joule)
  <|> (string "J"       *> pure joule)
  <|> (string "watts"   *> pure watt)
  <|> (string "watt"    *> pure watt)
  <|> (string "W"       *> pure watt)
  <|> (string "bytes"   *> pure byte)
  <|> (string "byte"    *> pure byte)
  <|> (string "bits"    *> pure bit)
  <|> (string "bit"     *> pure bit)
  <|> (string "bps"     *> pure (bit ./ second))
  <|> (string "b"       *> pure byte)
  <|> (string "seconds" *> pure second)
  <|> (string "second"  *> pure second)
  <|> (string "sec"     *> pure second)
  <|> (string "s"       *> pure second)
  <|> (string "minutes" *> pure minute)
  <|> (string "minute"  *> pure minute)
  <|> (string "min"     *> pure minute)
  <|> (string "hours"   *> pure hour)
  <|> (string "hour"    *> pure hour)
  <|> (string "h"       *> pure hour)
  <|> (string "days"    *> pure day)
  <|> (string "day"     *> pure day)
  <|> (string "d"       *> pure day)
  <|> (string "weeks"   *> pure week)
  <|> (string "week"    *> pure week)
  <|> (string "grams"   *> pure gram)
  <|> (string "gram"    *> pure gram)
  <|> (string "g"       *> pure gram)
  <|> (string "meters"  *> pure meter)
  <|> (string "meter"   *> pure meter)
  <|> (string "m"       *> pure meter)
  <?> "unit"

-- | Parse an imperial unit like `ft` of `mile`.
imperialUnit ∷ P DerivedUnit
imperialUnit =
      (string "miles"  *> pure mile)
  <|> (string "mile"   *> pure mile)
  <|> (string "mph"    *> pure (mile ./ hour))
  <|> (string "inches" *> pure inch)
  <|> (string "inch"   *> pure inch)
  <|> (string "in"     *> pure inch)
  <|> (string "yards"  *> pure yard)
  <|> (string "yard"   *> pure yard)
  <|> (string "yd"     *> pure yard)
  <|> (string "feet"   *> pure foot)
  <|> (string "foot"   *> pure foot)
  <|> (string "ft"     *> pure foot)
  <|> (string "ounces" *> pure ounce)
  <|> (string "ounce"  *> pure ounce)
  <|> (string "oz"     *> pure ounce)
  <|> (string "pound"  *> pure pound)
  <|> (string "lb"     *> pure pound)

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

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

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

-- | Parse the name of a mathematical function.
funcName ∷ P Func
funcName =
      (string "acosh" *> pure Acosh)
  <|> (string "acos"  *> pure Acos)
  <|> (string "asinh" *> pure Asinh)
  <|> (string "asin"  *> pure Asin)
  <|> (string "atanh" *> pure Atanh)
  <|> (string "atan"  *> pure Atan)
  <|> (string "ceil"  *> pure Ceil)
  <|> (string "cosh"  *> pure Cosh)
  <|> (string "cos"   *> pure Cos)
  <|> (string "exp"   *> pure Exp)
  <|> (string "floor" *> pure Floor)
  <|> (string "log10" *> pure Log10)
  <|> (string "log"   *> pure Ln)
  <|> (string "ln"    *> pure Ln)
  <|> (string "round" *> pure Round)
  <|> (string "sinh"  *> pure Sinh)
  <|> (string "sin"   *> pure Sin)
  <|> (string "sqrt"  *> pure Sqrt)
  <|> (string "tanh"  *> pure Tanh)
  <|> (string "tan"   *> pure Tan)

-- | 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 $ do
    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 full mathematical expression.
expression ∷ P Expression
expression =
  fix \p →
    let
      atomic ∷ P Expression
      atomic = whiteSpace *> (
              parens p
          <|> (Scalar <$> number)
          <|> try (Unit <$> derivedUnit)
          <|> try (Apply <$> funcName <*> (parens p <* whiteSpace))
          <|> variable
          )

      suffixPow ∷ P Expression
      suffixPow = do
        a ← atomic
        mFn ← optionMaybe ((sqrOp *> pure square) <|> (cubOp *> pure cube))
        case mFn of
          Just fn → pure $ fn a
          Nothing → pure a

      sepByPow ∷ P Expression
      sepByPow = foldr1 (BinOp Pow) <$> suffixPow `sepBy1` powOp

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

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

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

      prefixed ∷ P Expression
      prefixed = do
        prefixFn ← ((subOp *> pure Negate) <|> (addOp *> pure id) <|> pure id)
        prefixFn <$> sepByMul

      sepBySub ∷ P Expression
      sepBySub = foldl1 (BinOp Sub) <$> prefixed `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

    powOp = reservedOp "^" <|> reservedOp "**"
    sqrOp = reservedOp "²"
    cubOp = reservedOp "³"
    divOp = reservedOp "/"
    mulOp = reservedOp "*" <|> reservedOp "·"
    subOp = reservedOp "-"
    addOp = reservedOp "+"
    arrOp = reservedOp "->"

    square q = BinOp Pow q (Scalar 2.0)
    cube q = BinOp Pow q (Scalar 3.0)

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

  pure $ expr

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

-- | Parse a variable assignment like `x = 3m*pi`
assignment ∷ P Statement
assignment = do
  whiteSpace
  var ← token.identifier
  reservedOp "="
  value ← expression
  pure $ Assignment var value

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

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

-- | This module defines the parser for the Insect language.
module Insect.Parser
  ( parseInsect
  ) where

import Prelude hiding (degree)

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

import Quantities (DerivedUnit, atto, bit, byte, centi, day, deci, degree, exa,
                   femto, foot, giga, gram, hecto, hertz, hour, inch, joule,
                   kilo, mega, meter, micro, mile, milli, minute, nano,
                   newton, ounce, peta, pico, pound, radian, second, tera,
                   watt, week, yard, (./))

import Data.Array (some, fromFoldable)
import Data.Either (Either)
import Data.Foldable (foldr)
import Data.List (List, many, init, last)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.NonEmpty (NonEmpty, (:|), foldl1)
import Data.String (fromCharArray, singleton)
import Global (readFloat, isFinite)

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 (Func(..), BinOp(..), Expression(..), Command(..),
                        Statement(..))

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

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

-- | The language definition.
insectLanguage ∷ LanguageDef
insectLanguage = LanguageDef
  { commentStart: ""
  , commentEnd: ""
  , commentLine: "#"
  , nestedComments: false
  , identStart: letter <|> char '_'
  , identLetter: identLetter
  , opStart: oneOf ['+', '-', '*', '·', '/', '^', '=', '²', '³']
  , opLetter: oneOf ['>', '*']
  , reservedNames: ["help", "?", "list", "ls", "reset", "clear"]
  , 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 Number
number = do
  intPart ← digits

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

  mExpPart ← optionMaybe (append <$> string "e" <*> signAndDigits)
  let expPart = fromMaybe "" mExpPart

  whiteSpace

  let floatStr = intPart <> fracPart <> expPart
  let num = readFloat floatStr

  if isFinite num
    then pure num
    else fail $ "readFloat 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)

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

-- | Parse a SI prefix like `µ` or `G`.
siPrefix ∷ P (DerivedUnit → DerivedUnit)
siPrefix =
      (string "a" *> pure atto)
  <|> (string "f" *> pure femto)
  <|> (string "p" *> pure pico)
  <|> (string "n" *> pure nano)
  <|> (string "µ" *> pure micro)
  <|> (string "m" *> pure milli)
  <|> (string "c" *> pure centi)
  <|> (string "d" *> pure deci)
  <|> (string "h" *> pure hecto)
  <|> (string "k" *> pure kilo)
  <|> (string "M" *> pure mega)
  <|> (string "G" *> pure giga)
  <|> (string "T" *> pure tera)
  <|> (string "P" *> pure peta)
  <|> (string "E" *> pure exa)
  <|> pure id

-- | Parse a normal (SI-conform, non-imperical) unit, like `N` or `watt`.
normalUnit ∷ P DerivedUnit
normalUnit =
      (string "radians" *> pure radian)
  <|> (string "radian"  *> pure radian)
  <|> (string "rad"     *> pure radian)
  <|> (string "degrees" *> pure degree)
  <|> (string "degree"  *> pure degree)
  <|> (string "deg"     *> pure degree)
  <|> (string "°"       *> pure degree)
  <|> (string "hertz"   *> pure hertz)
  <|> (string "Hz"      *> pure hertz)
  <|> (string "newton"  *> pure newton)
  <|> (string "N"       *> pure newton)
  <|> (string "joules"  *> pure joule)
  <|> (string "joule"   *> pure joule)
  <|> (string "J"       *> pure joule)
  <|> (string "watts"   *> pure watt)
  <|> (string "watt"    *> pure watt)
  <|> (string "W"       *> pure watt)
  <|> (string "bytes"   *> pure byte)
  <|> (string "byte"    *> pure byte)
  <|> (string "bits"    *> pure bit)
  <|> (string "bit"     *> pure bit)
  <|> (string "bps"     *> pure (bit ./ second))
  <|> (string "b"       *> pure byte)
  <|> (string "seconds" *> pure second)
  <|> (string "second"  *> pure second)
  <|> (string "sec"     *> pure second)
  <|> (string "s"       *> pure second)
  <|> (string "minutes" *> pure minute)
  <|> (string "minute"  *> pure minute)
  <|> (string "min"     *> pure minute)
  <|> (string "hours"   *> pure hour)
  <|> (string "hour"    *> pure hour)
  <|> (string "h"       *> pure hour)
  <|> (string "days"    *> pure day)
  <|> (string "day"     *> pure day)
  <|> (string "d"       *> pure day)
  <|> (string "weeks"   *> pure week)
  <|> (string "week"    *> pure week)
  <|> (string "grams"   *> pure gram)
  <|> (string "gram"    *> pure gram)
  <|> (string "g"       *> pure gram)
  <|> (string "meters"  *> pure meter)
  <|> (string "meter"   *> pure meter)
  <|> (string "m"       *> pure meter)
  <?> "unit"

-- | Parse an imperial unit like `ft` of `mile`.
imperialUnit ∷ P DerivedUnit
imperialUnit =
      (string "miles"  *> pure mile)
  <|> (string "mile"   *> pure mile)
  <|> (string "mph"    *> pure (mile ./ hour))
  <|> (string "inches" *> pure inch)
  <|> (string "inch"   *> pure inch)
  <|> (string "in"     *> pure inch)
  <|> (string "yards"  *> pure yard)
  <|> (string "yard"   *> pure yard)
  <|> (string "yd"     *> pure yard)
  <|> (string "feet"   *> pure foot)
  <|> (string "foot"   *> pure foot)
  <|> (string "ft"     *> pure foot)
  <|> (string "ounces" *> pure ounce)
  <|> (string "ounce"  *> pure ounce)
  <|> (string "oz"     *> pure ounce)
  <|> (string "pound"  *> pure pound)
  <|> (string "lb"     *> pure pound)

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

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

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

-- | Parse the name of a mathematical function.
funcName ∷ P Func
funcName =
      (string "acosh" *> pure Acosh)
  <|> (string "acos"  *> pure Acos)
  <|> (string "asinh" *> pure Asinh)
  <|> (string "asin"  *> pure Asin)
  <|> (string "atanh" *> pure Atanh)
  <|> (string "atan"  *> pure Atan)
  <|> (string "ceil"  *> pure Ceil)
  <|> (string "cosh"  *> pure Cosh)
  <|> (string "cos"   *> pure Cos)
  <|> (string "exp"   *> pure Exp)
  <|> (string "floor" *> pure Floor)
  <|> (string "log10" *> pure Log10)
  <|> (string "log"   *> pure Ln)
  <|> (string "ln"    *> pure Ln)
  <|> (string "round" *> pure Round)
  <|> (string "sinh"  *> pure Sinh)
  <|> (string "sin"   *> pure Sin)
  <|> (string "sqrt"  *> pure Sqrt)
  <|> (string "tanh"  *> pure Tanh)
  <|> (string "tan"   *> pure Tan)

-- | 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 $ do
    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 full mathematical expression.
expression ∷ P Expression
expression =
  fix \p →
    let
      atomic ∷ P Expression
      atomic = whiteSpace *> (
              parens p
          <|> (Scalar <$> number)
          <|> try (Unit <$> derivedUnit)
          <|> try (Apply <$> funcName <*> (parens p <* whiteSpace))
          <|> variable
          )

      suffixPow ∷ P Expression
      suffixPow = do
        a ← atomic
        mFn ← optionMaybe ((sqrOp *> pure square) <|> (cubOp *> pure cube))
        case mFn of
          Just fn → pure $ fn a
          Nothing → pure a

      sepByPow ∷ P Expression
      sepByPow = foldr1 (BinOp Pow) <$> suffixPow `sepBy1` powOp

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

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

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

      prefixed ∷ P Expression
      prefixed = do
        prefixFn ← ((subOp *> pure Negate) <|> (addOp *> pure id) <|> pure id)
        prefixFn <$> sepByMul

      sepBySub ∷ P Expression
      sepBySub = foldl1 (BinOp Sub) <$> prefixed `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

    powOp = reservedOp "^" <|> reservedOp "**"
    sqrOp = reservedOp "²"
    cubOp = reservedOp "³"
    divOp = reservedOp "/"
    mulOp = reservedOp "*" <|> reservedOp "·"
    subOp = reservedOp "-"
    addOp = reservedOp "+"
    arrOp = reservedOp "->"

    square q = BinOp Pow q (Scalar 2.0)
    cube q = BinOp Pow q (Scalar 3.0)

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

  pure $ expr

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

-- | Parse a variable assignment like `x = 3m*pi`
assignment ∷ P Statement
assignment = do
  whiteSpace
  var ← token.identifier
  reservedOp "="
  value ← expression
  pure $ Assignment var value

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

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


Add units psi, mmHg, atm, BTU

Add units psi, mmHg, atm, BTU

closes #103, closes #111

-- | This module defines the parser for the Insect language.
module Insect.Parser
  ( DictEntry(..)
  , (==>)
  , Dictionary(..)
  , commands
  , functions
  , 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.Either (Either(..))
import Data.Decimal (Decimal, fromString, fromNumber, isFinite)
import Data.Foldable (foldr, foldMap)
import Data.Foldable as F
import Data.List (List, many, init, last)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.NonEmpty (NonEmpty, (:|), foldl1)
import Data.String (fromCharArray, singleton)
import Data.Tuple (Tuple(..))

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 (Func(..), BinOp(..), Expression(..), Command(..),
                        Statement(..))

-- | 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)

    signAndDigits ∷ P String
    signAndDigits = do
      sign ← option '+' (oneOf ['+', '-'])
      intPart ← digits
      pure $ singleton 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 id

-- | 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"]
  , 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"]
  ]

-- | 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.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"]
  ]

-- | 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

-- | Possible names for the mathematical functions.
funcNameDict ∷ Dictionary Func
funcNameDict = Dictionary
  [ Acosh ==> ["acosh"]
  , Acos ==> ["acos"]
  , Asinh ==> ["asinh"]
  , Asin ==> ["asin"]
  , Atanh ==> ["atanh"]
  , Atan ==> ["atan"]
  , Ceil ==> ["ceil"]
  , Cosh ==> ["cosh"]
  , Cos ==> ["cos"]
  , Exp ==> ["exp"]
  , Floor ==> ["floor"]
  , FromCelsius ==> ["fromCelsius"]
  , FromFahrenheit ==> ["fromFahrenheit"]
  , Gamma ==> ["gamma"]
  , Log10 ==> ["log10"]
  , Ln ==> ["log", "ln"]
  , Round ==> ["round"]
  , Sinh ==> ["sinh"]
  , Sin ==> ["sin"]
  , Sqrt ==> ["sqrt"]
  , Tanh ==> ["tanh"]
  , Tan ==> ["tan"]
  , ToCelsius ==> ["toCelsius"]
  , ToFahrenheit ==> ["toFahrenheit"]
  ]

-- | A list of all mathematical function names (for tab-completion).
functions ∷ Array String
functions =
  case funcNameDict of
    Dictionary dict → foldMap (\(_ ==> names) → names) dict

-- | Parse the name of a mathematical function.
funcName ∷ P Func
funcName = buildDictParser funcNameDict <?> "function name"

-- | 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 full mathematical expression.
expression ∷ P Expression
expression =
  fix \p →
    let
      atomic ∷ P Expression
      atomic = whiteSpace *> (
              parens p
          <|> (Scalar <$> number)
          <|> try (Unit <$> derivedUnit)
          <|> try (Apply <$> funcName <*> (parens p <* whiteSpace))
          <|> 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 ((sqrOp *> pure square) <|> (cubOp *> pure cube))
        case mFn of
          Just fn → pure $ fn x
          Nothing → pure x

      sepByPow ∷ P Expression
      sepByPow = foldr1 (BinOp Pow) <$> suffixPow `sepBy1` powOp

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

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

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

      prefixed ∷ P Expression
      prefixed = do
        prefixFn ← ((subOp *> pure Negate) <|> (addOp *> pure id) <|> pure id)
        prefixFn <$> sepByMul

      sepBySub ∷ P Expression
      sepBySub = foldl1 (BinOp Sub) <$> prefixed `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

    facOp = reservedOp "!"
    powOp = reservedOp "^" <|> reservedOp "**"
    sqrOp = reservedOp "²"
    cubOp = reservedOp "³"
    divOp = reservedOp "/" <|> reservedOp "÷" <|> reserved "per"
    mulOp = reservedOp "*" <|> reservedOp "·" <|> reservedOp "⋅"
                           <|> reservedOp "×"
    subOp = reservedOp "-"
    addOp = reservedOp "+"
    arrOp = reservedOp "->" <|> reservedOp "→" <|> reservedOp "➞" <|> reserved "to"

    square q = BinOp Pow q (Scalar $ fromNumber 2.0)
    cube q = BinOp Pow q (Scalar $ fromNumber 3.0)

-- | Parse a mathematical expression (or conversion) like `3m+2in -> cm`.
fullExpression ∷ P Expression
fullExpression = do
  whiteSpace
  expr ← expression
  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 assignment like `x = 3m*pi`
assignment ∷ P (Tuple String Expression)
assignment = do
  whiteSpace
  var ← token.identifier
  reservedOp "="
  value ← expression
  eof
  pure $ Tuple var value

-- | Try to parse the identifier as a unit, and fail if it succeeds.
checkIdentifier ∷ Tuple String Expression → P Statement
checkIdentifier (Tuple var value) =
  case runParser var (derivedUnit <* eof) of
    Right _ →
      fail $ "'" <> var <> "' is reserved for a physical unit"
    Left _ →
      case runParser var (funcName <* eof) of
        Right _ →
          fail $ "'" <> var <> "' is reserved for a math. function"
        Left _ →
          pure $ Assignment var value

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

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

-- | This module defines the parser for the Insect language.
module Insect.Parser
  ( DictEntry(..)
  , (==>)
  , Dictionary(..)
  , commands
  , functions
  , 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.Either (Either(..))
import Data.Decimal (Decimal, fromString, fromNumber, isFinite)
import Data.Foldable (foldr, foldMap)
import Data.Foldable as F
import Data.List (List, many, init, last)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.NonEmpty (NonEmpty, (:|), foldl1)
import Data.String (fromCharArray, singleton)
import Data.Tuple (Tuple(..))

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 (Func(..), BinOp(..), Expression(..), Command(..),
                        Statement(..))

-- | 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)

    signAndDigits ∷ P String
    signAndDigits = do
      sign ← option '+' (oneOf ['+', '-'])
      intPart ← digits
      pure $ singleton 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 id

-- | 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"]
  , 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"]
  ]

-- | 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.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"]
  ]

-- | 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

-- | Possible names for the mathematical functions.
funcNameDict ∷ Dictionary Func
funcNameDict = Dictionary
  [ Acosh ==> ["acosh"]
  , Acos ==> ["acos"]
  , Asinh ==> ["asinh"]
  , Asin ==> ["asin"]
  , Atanh ==> ["atanh"]
  , Atan ==> ["atan"]
  , Ceil ==> ["ceil"]
  , Cosh ==> ["cosh"]
  , Cos ==> ["cos"]
  , Exp ==> ["exp"]
  , Floor ==> ["floor"]
  , FromCelsius ==> ["fromCelsius"]
  , FromFahrenheit ==> ["fromFahrenheit"]
  , Gamma ==> ["gamma"]
  , Log10 ==> ["log10"]
  , Ln ==> ["log", "ln"]
  , Round ==> ["round"]
  , Sinh ==> ["sinh"]
  , Sin ==> ["sin"]
  , Sqrt ==> ["sqrt"]
  , Tanh ==> ["tanh"]
  , Tan ==> ["tan"]
  , ToCelsius ==> ["toCelsius"]
  , ToFahrenheit ==> ["toFahrenheit"]
  ]

-- | A list of all mathematical function names (for tab-completion).
functions ∷ Array String
functions =
  case funcNameDict of
    Dictionary dict → foldMap (\(_ ==> names) → names) dict

-- | Parse the name of a mathematical function.
funcName ∷ P Func
funcName = buildDictParser funcNameDict <?> "function name"

-- | 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 full mathematical expression.
expression ∷ P Expression
expression =
  fix \p →
    let
      atomic ∷ P Expression
      atomic = whiteSpace *> (
              parens p
          <|> (Scalar <$> number)
          <|> try (Unit <$> derivedUnit)
          <|> try (Apply <$> funcName <*> (parens p <* whiteSpace))
          <|> 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 ((sqrOp *> pure square) <|> (cubOp *> pure cube))
        case mFn of
          Just fn → pure $ fn x
          Nothing → pure x

      sepByPow ∷ P Expression
      sepByPow = foldr1 (BinOp Pow) <$> suffixPow `sepBy1` powOp

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

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

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

      prefixed ∷ P Expression
      prefixed = do
        prefixFn ← ((subOp *> pure Negate) <|> (addOp *> pure id) <|> pure id)
        prefixFn <$> sepByMul

      sepBySub ∷ P Expression
      sepBySub = foldl1 (BinOp Sub) <$> prefixed `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

    facOp = reservedOp "!"
    powOp = reservedOp "^" <|> reservedOp "**"
    sqrOp = reservedOp "²"
    cubOp = reservedOp "³"
    divOp = reservedOp "/" <|> reservedOp "÷" <|> reserved "per"
    mulOp = reservedOp "*" <|> reservedOp "·" <|> reservedOp "⋅"
                           <|> reservedOp "×"
    subOp = reservedOp "-"
    addOp = reservedOp "+"
    arrOp = reservedOp "->" <|> reservedOp "→" <|> reservedOp "➞" <|> reserved "to"

    square q = BinOp Pow q (Scalar $ fromNumber 2.0)
    cube q = BinOp Pow q (Scalar $ fromNumber 3.0)

-- | Parse a mathematical expression (or conversion) like `3m+2in -> cm`.
fullExpression ∷ P Expression
fullExpression = do
  whiteSpace
  expr ← expression
  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 assignment like `x = 3m*pi`
assignment ∷ P (Tuple String Expression)
assignment = do
  whiteSpace
  var ← token.identifier
  reservedOp "="
  value ← expression
  eof
  pure $ Tuple var value

-- | Try to parse the identifier as a unit, and fail if it succeeds.
checkIdentifier ∷ Tuple String Expression → P Statement
checkIdentifier (Tuple var value) =
  case runParser var (derivedUnit <* eof) of
    Right _ →
      fail $ "'" <> var <> "' is reserved for a physical unit"
    Left _ →
      case runParser var (funcName <* eof) of
        Right _ →
          fail $ "'" <> var <> "' is reserved for a math. function"
        Left _ →
          pure $ Assignment var value

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

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


Add Web module

Add Web module

module Web
  ( exprToJQuery
  , getPath
  ) where

import Control.Monad.Eff
import qualified Control.Monad.Eff.JQuery as J
import DOM
import Prelude

import Data.Foldable (all)
import Data.Traversable (for)
import Data.List
import Data.String (joinWith)
import Data.Foreign (unsafeFromForeign)
import Control.Apply ((*>))
import Control.Bind ((=<<), (>=>))

import AST
import Evaluator (Path(..))

pathPropName :: String
pathPropName = "clickyEvaluation_path"

getPath :: forall eff. J.JQuery -> Eff (dom :: DOM | eff) Path
getPath j = unsafeFromForeign <$> J.getProp pathPropName j

exprToJQuery :: forall eff. Expr -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery expr = go id expr
  where
  go :: (Path -> Path) -> Expr -> Eff (dom :: DOM | eff) J.JQuery
  go p e = J.setProp pathPropName (p End) =<< case e of
    Atom a -> atom a
    Binary op e1 e2 -> do
      j1 <- go (p <<< Fst) e1
      j2 <- go (p <<< Snd) e2
      binary op j1 j2
    List es -> case isString es of
                  true  -> string es
                  false -> do js <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length es - 1)) es
                              list js
    NTuple es -> do
      js <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length es - 1)) es
      tuple js
    SectL e op -> do
      j <- go (p <<< Fst) e
      jop <- makeDiv (show op) (singleton "op")
      section j jop
    SectR op e -> do
      jop <- makeDiv (show op) (singleton "op")
      j <- go (p <<< Snd) e
      section jop j
    PrefixOp op -> makeDiv ("(" ++ show op ++ ")") (toList ["prefix", "op"])
    IfExpr cond thenExpr elseExpr -> do
      jc <- go (p <<< Fst) cond
      jt <- go (p <<< Snd) thenExpr
      je <- go (p <<< Thrd) elseExpr
      ifexpr jc jt je
    Lambda binds body -> do
      jBinds <- for binds binding
      jBody <- go (p <<< Fst) body
      lambda jBinds jBody
    App func args -> do
      jFunc <- go (p <<< Fst) func
      jArgs <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length args - 1)) args
      app jFunc jArgs

atom :: forall eff. Atom -> Eff (dom :: DOM | eff) J.JQuery
atom (AInt n)      = makeDiv (show n) (toList ["atom", "num"])
atom (Bool true)  = makeDiv "True"  (toList ["atom", "bool"])
atom (Bool false) = makeDiv "False" (toList ["atom", "bool"])
atom (Char c)     = makeDiv ("'" ++ c ++ "'") (toList ["atom", "char"])
atom (Name name)  = makeDiv name (toList ["atom", "name"])

binding :: forall eff. Binding -> Eff (dom :: DOM | eff) J.JQuery
binding b = case b of
  Lit a        -> atom a
  ConsLit b bs -> do
    jCons <- makeDiv "" Nil
    makeDiv "(" (singleton "brace") >>= flip J.append jCons
    binding b             >>= flip J.append jCons
    makeDiv ":" (singleton "colon") >>= flip J.append jCons
    binding bs            >>= flip J.append jCons
    makeDiv ")" (singleton "brace") >>= flip J.append jCons
  ListLit bs -> do
    jList <- makeDiv "" Nil
    makeDiv "[" (singleton "brace") >>= flip J.append jList
    for bs $ \b -> do
      binding b >>= flip J.append jList
      makeDiv "," (singleton "comma") >>= flip J.append jList
    makeDiv "]" (singleton "brace") >>= flip J.append jList
  NTupleLit bs -> do
    jTuple <- makeDiv "" Nil
    makeDiv "(" (singleton "brace") >>= flip J.append jTuple
    interleaveM_ (binding >=> flip J.append jTuple) (makeDiv "," (singleton "comma") >>= flip J.append jTuple) bs
    makeDiv ")" (singleton "brace") >>= flip J.append jTuple
    return jTuple

lambda :: forall eff. List J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
lambda jBinds jBody = do
  jLam <- makeDiv "" (singleton "lambda")
  open <- makeDiv "(" (singleton "brace")
  J.append open jLam
  bs <- makeDiv "\\" (singleton "backslash")
  J.append bs jLam
  for jBinds (flip J.append jLam)
  arrow <- makeDiv "->" (singleton "arrow")
  J.append arrow jLam
  J.append jBody jLam
  close <- makeDiv ")" (singleton "brace")
  J.append close jLam
  return jLam

binary :: forall eff. Op -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
binary op j1 j2 = do
  dBin <- makeDiv "" (singleton "binary")
  J.append j1 dBin
  dOp <- makeDiv (show op) (singleton "op")
  J.append dOp dBin
  J.append j2 dBin
  return dBin

section :: forall eff. J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
section j1 j2 = do
  jSect <- makeDiv "" (singleton "section")
  open <- makeDiv "(" (singleton "brace")
  J.append open jSect
  J.append j1 jSect
  J.append j2 jSect
  close <- makeDiv ")" (singleton "brace")
  J.append close jSect
  return jSect

ifexpr :: forall eff. J.JQuery -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
ifexpr cond thenExpr elseExpr = do
  dIf <- makeDiv "" (singleton "if")
  makeDiv "if" (singleton "keyword") >>= flip J.append dIf
  J.append cond dIf
  makeDiv "then" (singleton "keyword") >>= flip J.append dIf
  J.append thenExpr dIf
  makeDiv "else" (singleton "keyword") >>= flip J.append dIf
  J.append elseExpr dIf
  return dIf

interleaveM_ :: forall a b m. (Monad m) => (a -> m b) -> m b -> List a -> m Unit
interleaveM_ f sep = go
  where
  go Nil     = return unit
  go (Cons x Nil)    = void $ f x
  go (Cons x xs) = f x *> sep *> go xs

tuple :: forall eff. List J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
tuple js = do
  dtuple <- makeDiv "" (singleton "tuple")
  open <- makeDiv "(" (singleton "brace")
  J.append open dtuple
  interleaveM_ (flip J.append dtuple) (makeDiv "," (singleton "comma") >>= flip J.append dtuple) js
  close <- makeDiv ")" (singleton "brace")
  J.append close dtuple
  return dtuple

list :: forall eff. List J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
list js = do
  dls <- makeDiv "" (singleton "list")
  open <- makeDiv "[" (singleton "brace")
  J.append open dls
  interleaveM_ (flip J.append dls) (makeDiv "," (singleton "comma") >>= flip J.append dls) js
  close <- makeDiv "]" (singleton "brace")
  J.append close dls
  return dls

isString :: List Expr -> Boolean
isString es = length es > 0 && all isChar es
  where
  isChar (Atom (Char _)) = true
  isChar _               = false

string :: forall eff. List Expr -> Eff (dom :: DOM | eff) J.JQuery
string es = do
  let str = "\"" ++ joinWith "" (fromList ((\(Atom (Char s)) -> s) <$> es)) ++ "\""
  dstring <- makeDiv str (toList ["list", "string"])
  return dstring

app :: forall eff. J.JQuery -> List J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
app jFunc jArgs = do
  dApp <- makeDiv "" (singleton "app")
  J.addClass "func" jFunc
  J.append jFunc dApp
  for jArgs (flip J.append dApp)
  return dApp

type Class = String

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

"
  J.setText text d
  for classes (flip J.addClass d)
  return d

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


Update docs

Update docs

module Benchotron.Core
  ( Benchmark()
  , BenchmarkF()
  , BenchmarkFunction()
  , mkBenchmark
  , unpackBenchmark
  , benchFn
  , benchFn'
  , runBenchmark
  , runBenchmarkF
  , BenchM()
  , runBenchM
  , BenchEffects()
  , BenchmarkResult()
  , ResultSeries()
  , DataPoint()
  ) where

import Prelude
import Data.Exists
import Data.Tuple
import Data.Array (filter, (..), length, replicateM, zip)
import Data.Array.Unsafe (head)
import Data.Traversable (for)
import Data.Date (Now())
import Data.Date.Locale (Locale())
import Control.Monad.State.Trans (StateT(), evalStateT)
import Control.Monad.State.Class (get, put)
import Control.Monad.Trans (lift)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)
import Node.FS (FS())
import Control.Monad.Eff.Console (CONSOLE())
import Control.Monad.Eff.Random  (RANDOM())
import Test.QuickCheck.Gen (Gen(), GenState(), runGen)

import Benchotron.BenchmarkJS
import Benchotron.Utils

-- | A value representing a benchmark to be performed. The type parameter is
-- | the type of the input to each of the competing functions in the benchmark.
-- |
-- | **Attributes**
-- |
-- | * `slug`: An identifier for the benchmark. Used for filenames.
-- | * `title`: The title of the benchmark.
-- | * `sizes`: An array of numbers representing each input size you would like
-- |   your benchmark to be run with. The interpretation of 'size' depends on
-- |   the specific case; if the input is an array, for example, the size would
-- |   usually be the number of elements in the array.
-- | * `sizeInterpretation`: A `String` with a human-readable description of
-- |   how the size is meant to be interpreted in this specific case.
-- | * `inputsPerSize`: The number of inputs to be generated for each each
-- |   input size. Often it's acceptable to set this to 1. By using higher
-- |   values, you can have more confidence in your results; however, your
-- |   benchmarks will also take much longer to run.
-- | * `gen`: a QuickCheck generator, which should produce a random input of
-- |   the given argument size when executed.
-- | * `functions`: An array of competing functions to be benchmarked.
type BenchmarkF a =
  { slug               :: String
  , title              :: String
  , sizes              :: Array Int
  , sizeInterpretation :: String
  , inputsPerSize      :: Int
  , gen                :: Int -> Gen a
  , functions          :: Array (BenchmarkFunction a)
  }

-- This is only necessary because psc doesn't support partially applied type
-- synonyms.
newtype BenchmarkFF a = BenchmarkFF (BenchmarkF a)

newtype Benchmark = Benchmark (Exists (BenchmarkFF))

mkBenchmark :: forall a. BenchmarkF a -> Benchmark
mkBenchmark = Benchmark <<< mkExists <<< BenchmarkFF

unpackBenchmark :: forall r. (forall a. BenchmarkF a -> r) -> Benchmark -> r
unpackBenchmark f (Benchmark b) = runExists f' b
  where
  f' :: forall a. BenchmarkFF a -> r
  f' (BenchmarkFF b') = f b'

newtype BenchmarkFunction a = BenchmarkFunction (Exists (BenchmarkFunctionF a))

newtype BenchmarkFunctionF a b = BenchmarkFunctionF
  { name :: String
  , fn :: b -> Any
  , before :: a -> b
  }

-- | Create a `BenchmarkFunction`, given a name and a function to be
-- | benchmarked.
benchFn :: forall a r. String -> (a -> r) -> BenchmarkFunction a
benchFn name fn = benchFn' name fn id

-- | Create a `BenchmarkFunction`. Like `benchFn`, except that it accepts a
-- | third argument which will be used to preprocess the input, before starting
-- | the benchmark. This is useful if you want to compare two functions which
-- | have different argument types.
benchFn' :: forall a b r. String -> (b -> r) -> (a -> b) -> BenchmarkFunction a
benchFn' name fn before =
  BenchmarkFunction $ mkExists $ BenchmarkFunctionF
    { name: name, fn: toAny <<< fn, before: before }

getName :: forall a. BenchmarkFunction a -> String
getName (BenchmarkFunction f) = runExists go f
  where
  go :: forall b. BenchmarkFunctionF a b -> String
  go (BenchmarkFunctionF o) = o.name

type BenchM e a = StateT GenState (Eff (BenchEffects e)) a

runBenchM :: forall e a. BenchM e a -> GenState -> Eff (BenchEffects e) a
runBenchM = evalStateT

-- | Use the given generator to generate a random value, using (and modifying)
-- | the state of the BenchM computation.
stepGen :: forall e a. Gen a -> BenchM e a
stepGen gen = do
  st <- get
  let out = runGen gen st
  put $ snd out
  return $ fst out

runBenchmark :: forall e.
  Benchmark ->
  -- ^ The Benchmark to be run.
  (Int -> Int -> BenchM e Unit) ->
  -- ^ Callback for when the size changes; the arguments are current size index
  --   (1-based) , and the current size.
  BenchM e BenchmarkResult
runBenchmark = unpackBenchmark runBenchmarkF

runBenchmarkF :: forall e a.
  BenchmarkF a ->
  -- ^ The Benchmark to be run.
  (Int -> Int -> BenchM e Unit) ->
  -- ^ Callback for when the size changes; the arguments are current size index
  --   (1-based) , and the current size.
  BenchM e BenchmarkResult
runBenchmarkF benchmark onChange = do
  results <- for (withIndices benchmark.sizes) $ \(Tuple idx size) -> do
    onChange idx size
    let getAnInput = stepGen $ benchmark.gen size
    inputs   <- replicateM benchmark.inputsPerSize getAnInput
    allStats <- for benchmark.functions $ \function -> do
                  let name = getName function
                  lift $
                    handleBenchmarkException name size $ do
                      stats <- runBenchmarkFunction inputs function
                      return { name: name, stats: stats }

    return { size: size, allStats: allStats }

  let series = rejig results
  return
    { slug: benchmark.slug
    , title: benchmark.title
    , sizeInterpretation: benchmark.sizeInterpretation
    , series: series
    }

  where
  withIndices arr = zip (1..(length arr)) arr

-- TODO: use purescript-exceptions instead. This appears to be blocked on:
--    https://github.com/purescript/purescript-exceptions/issues/5
foreign import handleBenchmarkException ::
  forall e a. String -> Int -> Eff (BenchEffects e) a -> Eff (BenchEffects e) a

runBenchmarkFunction :: forall e a. Array a -> BenchmarkFunction a -> Eff (BenchEffects e) Stats
runBenchmarkFunction inputs (BenchmarkFunction function') =
  runExists go function'
  where
  go :: forall b. BenchmarkFunctionF a b -> Eff (BenchEffects e) Stats
  go (BenchmarkFunctionF function) =
    let inputs' = map function.before inputs
        f = \_ -> toAny $ map function.fn inputs'
    in do
      monkeyPatchBenchmark benchmarkJS
      runBenchmarkImpl benchmarkJS f

type BenchEffects e
  = ( err       :: EXCEPTION
    , fs        :: FS
    , now       :: Now
    , locale    :: Locale
    , console   :: CONSOLE
    , random    :: RANDOM
    , benchmark :: BENCHMARK
    | e
    )

type BenchmarkResult =
  { slug               :: String
  , title              :: String
  , sizeInterpretation :: String
  , series             :: Array ResultSeries
  }

type ResultSeries =
  { name    :: String
  , results :: Array DataPoint
  }

type DataPoint =
  { size  :: Int
  , stats :: Stats
  }

type IntermediateResult =
  Array { size :: Int, allStats :: Array { name :: String, stats :: Stats } }

rejig :: IntermediateResult -> Array ResultSeries
rejig [] = []
rejig results = map toSeries names
  where
  r = head results
  names = map _.name r.allStats
  toSeries name =
    { name: name
    , results: map (\o -> { size: o.size
                          , stats: _.stats $ the $ filter ((==) name <<< _.name) o.allStats
                          }) results
    }
  the [x] = x
  the _ = unsafeThrow "Benchotron.Core.the: invalid input"

module Benchotron.Core
  ( Benchmark()
  , BenchmarkF()
  , BenchmarkFunction()
  , mkBenchmark
  , unpackBenchmark
  , benchFn
  , benchFn'
  , runBenchmark
  , runBenchmarkF
  , BenchM()
  , runBenchM
  , BenchEffects()
  , BenchmarkResult()
  , ResultSeries()
  , DataPoint()
  ) where

import Prelude
import Data.Exists
import Data.Tuple
import Data.Array (filter, (..), length, replicateM, zip)
import Data.Array.Unsafe (head)
import Data.Traversable (for)
import Data.Date (Now())
import Data.Date.Locale (Locale())
import Control.Monad.State.Trans (StateT(), evalStateT)
import Control.Monad.State.Class (get, put)
import Control.Monad.Trans (lift)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)
import Node.FS (FS())
import Control.Monad.Eff.Console (CONSOLE())
import Control.Monad.Eff.Random  (RANDOM())
import Test.QuickCheck.Gen (Gen(), GenState(), runGen)

import Benchotron.BenchmarkJS
import Benchotron.Utils

-- | A value representing a benchmark to be performed. The type parameter 'e'
-- | is provided to allow you to supply a random value generator with arbitrary
-- | effects, if you need to. The type parameter 'a' is the type of the input
-- | to each of the competing functions in the benchmark.
-- |
-- | **Attributes**
-- |
-- | * `slug`: An identifier for the benchmark. Used for filenames.
-- | * `title`: The title of the benchmark.
-- | * `sizes`: An array of numbers representing each input size you would like
-- |   your benchmark to be run with. The interpretation of 'size' depends on
-- |   the specific case; if the input is an array, for example, the size would
-- |   usually be the number of elements in the array.
-- | * `sizeInterpretation`: A `String` with a human-readable description of
-- |   how the size is meant to be interpreted in this specific case.
-- | * `inputsPerSize`: The number of inputs to be generated for each each
-- |   input size. Often it's acceptable to set this to 1. By using higher
-- |   values, you can have more confidence in your results; however, your
-- |   benchmarks will also take much longer to run.
-- | * `gen`: An Eff action which should produce a random input of the given
-- |   argument size when executed.
-- | * `functions`: An array of competing functions to be benchmarked.
type BenchmarkF a =
  { slug               :: String
  , title              :: String
  , sizes              :: Array Int
  , sizeInterpretation :: String
  , inputsPerSize      :: Int
  , gen                :: Int -> Gen a
  , functions          :: Array (BenchmarkFunction a)
  }

-- This is only necessary because psc doesn't support partially applied type
-- synonyms.
newtype BenchmarkFF a = BenchmarkFF (BenchmarkF a)

newtype Benchmark = Benchmark (Exists (BenchmarkFF))

mkBenchmark :: forall a. BenchmarkF a -> Benchmark
mkBenchmark = Benchmark <<< mkExists <<< BenchmarkFF

unpackBenchmark :: forall r. (forall a. BenchmarkF a -> r) -> Benchmark -> r
unpackBenchmark f (Benchmark b) = runExists f' b
  where
  f' :: forall a. BenchmarkFF a -> r
  f' (BenchmarkFF b') = f b'

newtype BenchmarkFunction a = BenchmarkFunction (Exists (BenchmarkFunctionF a))

newtype BenchmarkFunctionF a b = BenchmarkFunctionF
  { name :: String
  , fn :: b -> Any
  , before :: a -> b
  }

-- | Create a `BenchmarkFunction`, given a name and a function to be
-- | benchmarked.
benchFn :: forall a r. String -> (a -> r) -> BenchmarkFunction a
benchFn name fn = benchFn' name fn id

-- | Create a `BenchmarkFunction`. Like `benchFn`, except that it accepts a
-- | third argument which will be used to preprocess the input, before starting
-- | the benchmark. This is useful if you want to compare two functions which
-- | have different argument types.
benchFn' :: forall a b r. String -> (b -> r) -> (a -> b) -> BenchmarkFunction a
benchFn' name fn before =
  BenchmarkFunction $ mkExists $ BenchmarkFunctionF
    { name: name, fn: toAny <<< fn, before: before }

getName :: forall a. BenchmarkFunction a -> String
getName (BenchmarkFunction f) = runExists go f
  where
  go :: forall b. BenchmarkFunctionF a b -> String
  go (BenchmarkFunctionF o) = o.name

type BenchM e a = StateT GenState (Eff (BenchEffects e)) a

runBenchM :: forall e a. BenchM e a -> GenState -> Eff (BenchEffects e) a
runBenchM = evalStateT

-- | Use the given generator to generate a random value, using (and modifying)
-- | the state of the BenchM computation.
stepGen :: forall e a. Gen a -> BenchM e a
stepGen gen = do
  st <- get
  let out = runGen gen st
  put $ snd out
  return $ fst out

runBenchmark :: forall e.
  Benchmark ->
  -- ^ The Benchmark to be run.
  (Int -> Int -> BenchM e Unit) ->
  -- ^ Callback for when the size changes; the arguments are current size index
  --   (1-based) , and the current size.
  BenchM e BenchmarkResult
runBenchmark = unpackBenchmark runBenchmarkF

runBenchmarkF :: forall e a.
  BenchmarkF a ->
  -- ^ The Benchmark to be run.
  (Int -> Int -> BenchM e Unit) ->
  -- ^ Callback for when the size changes; the arguments are current size index
  --   (1-based) , and the current size.
  BenchM e BenchmarkResult
runBenchmarkF benchmark onChange = do
  results <- for (withIndices benchmark.sizes) $ \(Tuple idx size) -> do
    onChange idx size
    let getAnInput = stepGen $ benchmark.gen size
    inputs   <- replicateM benchmark.inputsPerSize getAnInput
    allStats <- for benchmark.functions $ \function -> do
                  let name = getName function
                  lift $
                    handleBenchmarkException name size $ do
                      stats <- runBenchmarkFunction inputs function
                      return { name: name, stats: stats }

    return { size: size, allStats: allStats }

  let series = rejig results
  return
    { slug: benchmark.slug
    , title: benchmark.title
    , sizeInterpretation: benchmark.sizeInterpretation
    , series: series
    }

  where
  withIndices arr = zip (1..(length arr)) arr

-- TODO: use purescript-exceptions instead. This appears to be blocked on:
--    https://github.com/purescript/purescript-exceptions/issues/5
foreign import handleBenchmarkException ::
  forall e a. String -> Int -> Eff (BenchEffects e) a -> Eff (BenchEffects e) a

runBenchmarkFunction :: forall e a. Array a -> BenchmarkFunction a -> Eff (BenchEffects e) Stats
runBenchmarkFunction inputs (BenchmarkFunction function') =
  runExists go function'
  where
  go :: forall b. BenchmarkFunctionF a b -> Eff (BenchEffects e) Stats
  go (BenchmarkFunctionF function) =
    let inputs' = map function.before inputs
        f = \_ -> toAny $ map function.fn inputs'
    in do
      monkeyPatchBenchmark benchmarkJS
      runBenchmarkImpl benchmarkJS f

type BenchEffects e
  = ( err       :: EXCEPTION
    , fs        :: FS
    , now       :: Now
    , locale    :: Locale
    , console   :: CONSOLE
    , random    :: RANDOM
    , benchmark :: BENCHMARK
    | e
    )

type BenchmarkResult =
  { slug               :: String
  , title              :: String
  , sizeInterpretation :: String
  , series             :: Array ResultSeries
  }

type ResultSeries =
  { name    :: String
  , results :: Array DataPoint
  }

type DataPoint =
  { size  :: Int
  , stats :: Stats
  }

type IntermediateResult =
  Array { size :: Int, allStats :: Array { name :: String, stats :: Stats } }

rejig :: IntermediateResult -> Array ResultSeries
rejig [] = []
rejig results = map toSeries names
  where
  r = head results
  names = map _.name r.allStats
  toSeries name =
    { name: name
    , results: map (\o -> { size: o.size
                          , stats: _.stats $ the $ filter ((==) name <<< _.name) o.allStats
                          }) results
    }
  the [x] = x
  the _ = unsafeThrow "Benchotron.Core.the: invalid input"


Language.PureScript.Optimizer partially done

Again needs psc fix for qualified operators

module Language.PureScript.Optimizer (optimize) where

import Data.Tuple
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Options
import Language.PureScript.Optimizer.Common
import Language.PureScript.Optimizer.TCO
import Language.PureScript.Optimizer.MagicDo
import Language.PureScript.Optimizer.Inliner
import Language.PureScript.Optimizer.Unused
import Language.PureScript.Optimizer.Blocks
import qualified Language.PureScript.Constants as C

-- |
-- Apply a series of optimizer passes to simplified Javascript code
--
optimize :: Options -> JS -> JS
optimize (Options o) | o.noOptimizations = id
optimize opts = untilFixedPoint (applyAll
  [ collapseNestedBlocks
  , tco opts
  , magicDo opts
  , removeUnusedVariables
  , removeCodeAfterReturnStatements
  , unThunk
  , etaConvert
  , evaluateIifes
  , inlineVariables
  -- , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]
  -- , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]
  , inlineOperator (Tuple C.preludeUnsafe C.unsafeIndex) $ flip JSIndexer
  , inlineCommonOperators ])

untilFixedPoint :: forall a. (Eq a) => (a -> a) -> a -> a
untilFixedPoint f = go
  where
  go a = let a' = f a in
          if a' == a then a' else go a'

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


Simplified two helper functions.

Simplified two helper functions.

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


Stuck in the middle of getting functions for header composed.


Add test case

Add test case

module Main where

import Prelude
import Control.Monad.Eff.Console (log)

x :: forall a. a -> String
x a = y "Done"
  where
  y :: forall a. (Show a) => a -> String
  y a = show (a :: a)

main = log (x 0)

error: pathspec 'examples/passing/1335.purs' did not match any file(s) known to git


Add Tag type for tagged instructions

Add Tag type for tagged instructions

Each tag takes up the 3 least-significant bits in a 32-bit number, so
payloads can be up to 29 bits. Since payloads are mostly indexes into
the name store, I can't imagine that not being enough.

module Lambda.Language.Snapshot.Tag
  ( Tag(..)
  , _VAR
  , _NAT
  , _TAK
  , _LAM
  , _DEF
  , _APV
  , _AP0
  ) where

import Lambda.Prelude

import Lambda.Language.Pretty (class Pretty, text)

-- | 3-bit tag used to encode RPN instructions as Ints
newtype Tag = Tag Int

derive instance newtypeTag :: Newtype Tag _
derive newtype instance eqTag :: Eq Tag

instance showTag :: Show Tag where
  show tag
    | tag == _VAR = "_VAR"
    | tag == _NAT = "_NAT"
    | tag == _TAK = "_TAK"
    | tag == _LAM = "_LAM"
    | tag == _DEF = "_DEF"
    | tag == _APV = "_APV"
    | tag == _APV = "_AP0"
    | otherwise = "?" <> show (un Tag tag)

instance prettyTag :: Pretty Tag where
  pretty _ = text <<< show

-- | Fetch name at index
_VAR :: Tag
_VAR = Tag 1

-- | Push literal natural number
_NAT :: Tag
_NAT = Tag 2

-- | Take N items from stack as literal list
_TAK :: Tag
_TAK = Tag 3

-- | Create lambda from name and expression on stack
_LAM :: Tag
_LAM = Tag 4

-- | Create definition from name and expression on stack
_DEF :: Tag
_DEF = Tag 5

-- | Apply name using variable index to top of stack
_APV :: Tag
_APV = Tag 6

-- | Apply top of stack to element beneath it
_AP0 :: Tag
_AP0 = Tag 7

error: pathspec 'frontend/src/Lambda/Language/Snapshot/Tag.purs' did not match any file(s) known to git


'smallest' as a top-level func

'smallest' as a top-level func

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


add generated Mesh module

add generated Mesh module

-- generated file, do not modify!
-- 2016-11-14T21:30:03.056917000000Z

module LambdaCube.Mesh where
import Prelude
import Data.Generic
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.StrMap (StrMap(..))
import Data.Map (Map(..))
import Data.List (List(..))
import LambdaCube.LinearBase

import Data.Argonaut.Encode.Combinators ((~>), (:=))
import Data.Argonaut.Decode.Combinators ((.?))
import Data.Argonaut.Core (jsonEmptyObject)
import Data.Argonaut.Printer (printJson)
import Data.Argonaut.Encode (class EncodeJson, encodeJson)
import Data.Argonaut.Decode (class DecodeJson, decodeJson)

data MeshAttribute
  = A_Float (Array Float)
  | A_V2F (Array V2F)
  | A_V3F (Array V3F)
  | A_V4F (Array V4F)
  | A_M22F (Array M22F)
  | A_M33F (Array M33F)
  | A_M44F (Array M44F)
  | A_Int (Array Int32)
  | A_Word (Array Word32)

data MeshPrimitive
  = P_Points
  | P_TriangleStrip
  | P_Triangles
  | P_TriangleStripI (Array Int32)
  | P_TrianglesI (Array Int32)

data Mesh
  = Mesh
  { mAttributes :: StrMap MeshAttribute
  , mPrimitive :: MeshPrimitive
  }

instance encodeJsonMeshAttribute :: EncodeJson MeshAttribute where
  encodeJson v = case v of
    A_Float arg0 -> "tag" := "A_Float" ~> "arg0" := arg0 ~> jsonEmptyObject
    A_V2F arg0 -> "tag" := "A_V2F" ~> "arg0" := arg0 ~> jsonEmptyObject
    A_V3F arg0 -> "tag" := "A_V3F" ~> "arg0" := arg0 ~> jsonEmptyObject
    A_V4F arg0 -> "tag" := "A_V4F" ~> "arg0" := arg0 ~> jsonEmptyObject
    A_M22F arg0 -> "tag" := "A_M22F" ~> "arg0" := arg0 ~> jsonEmptyObject
    A_M33F arg0 -> "tag" := "A_M33F" ~> "arg0" := arg0 ~> jsonEmptyObject
    A_M44F arg0 -> "tag" := "A_M44F" ~> "arg0" := arg0 ~> jsonEmptyObject
    A_Int arg0 -> "tag" := "A_Int" ~> "arg0" := arg0 ~> jsonEmptyObject
    A_Word arg0 -> "tag" := "A_Word" ~> "arg0" := arg0 ~> jsonEmptyObject

instance decodeJsonMeshAttribute :: DecodeJson MeshAttribute where
  decodeJson json = do
    obj <- decodeJson json
    tag <- obj .? "tag"
    case tag of
      "A_Float" -> A_Float <$> obj .? "arg0"
      "A_V2F" -> A_V2F <$> obj .? "arg0"
      "A_V3F" -> A_V3F <$> obj .? "arg0"
      "A_V4F" -> A_V4F <$> obj .? "arg0"
      "A_M22F" -> A_M22F <$> obj .? "arg0"
      "A_M33F" -> A_M33F <$> obj .? "arg0"
      "A_M44F" -> A_M44F <$> obj .? "arg0"
      "A_Int" -> A_Int <$> obj .? "arg0"
      "A_Word" -> A_Word <$> obj .? "arg0"
      _ -> Left ("decodeJsonMeshAttribute - unknown tag: " <> tag)

instance encodeJsonMeshPrimitive :: EncodeJson MeshPrimitive where
  encodeJson v = case v of
    P_Points -> "tag" := "P_Points" ~> jsonEmptyObject
    P_TriangleStrip -> "tag" := "P_TriangleStrip" ~> jsonEmptyObject
    P_Triangles -> "tag" := "P_Triangles" ~> jsonEmptyObject
    P_TriangleStripI arg0 -> "tag" := "P_TriangleStripI" ~> "arg0" := arg0 ~> jsonEmptyObject
    P_TrianglesI arg0 -> "tag" := "P_TrianglesI" ~> "arg0" := arg0 ~> jsonEmptyObject

instance decodeJsonMeshPrimitive :: DecodeJson MeshPrimitive where
  decodeJson json = do
    obj <- decodeJson json
    tag <- obj .? "tag"
    case tag of
      "P_Points" -> pure P_Points
      "P_TriangleStrip" -> pure P_TriangleStrip
      "P_Triangles" -> pure P_Triangles
      "P_TriangleStripI" -> P_TriangleStripI <$> obj .? "arg0"
      "P_TrianglesI" -> P_TrianglesI <$> obj .? "arg0"
      _ -> Left ("decodeJsonMeshPrimitive - unknown tag: " <> tag)

instance encodeJsonMesh :: EncodeJson Mesh where
  encodeJson v = case v of
    Mesh r ->
      "tag" := "Mesh" ~>
      "mAttributes" := r.mAttributes ~>
      "mPrimitive" := r.mPrimitive ~>
      jsonEmptyObject

instance decodeJsonMesh :: DecodeJson Mesh where
  decodeJson json = do
    obj <- decodeJson json
    tag <- obj .? "tag"
    case tag of
      "Mesh" -> do
        mAttributes <- obj .? "mAttributes"
        mPrimitive <- obj .? "mPrimitive"
        pure $ Mesh
          { mAttributes:mAttributes
          , mPrimitive:mPrimitive
          }
      _ -> Left ("decodeJsonMesh - unknown tag: " <> tag)

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


Add AST representation

Add AST representation

Contains function application and definition, lists,
pattern-matching on lists and operator sections.

module AST where

import Data.String (joinWith)
import Data.Array  ()

data Op = Add | Sub | Mul | Div | And | Or | Cons | Append

data Atom = Num Number
          | Bool Boolean
          | Name String

data Expr = Atom Atom
          | List [Expr]
          | Infix Expr Op Expr
          | SectL Expr Op
          | SectR Op Expr
          | App String [Expr]

data Binding = Lit Atom
             | ListLit Atom Binding

data Definition = Def String [Binding] Expr

instance showOp :: Show Op where
  show op = case op of
    Add    -> "+"
    Sub    -> "-"
    Mul    -> "*"
    Div    -> "`div`"
    And    -> "&&"
    Or     -> "||"
    Cons   -> ":"
    Append -> "++"

instance showAtom :: Show Atom where
  show atom = case atom of
    Num number  -> "(Num " ++ show number ++ ")"
    Bool bool   -> "(Bool " ++ show bool ++ ")"
    Name string -> "(Name " ++ string ++ ")"

instance showExpr :: Show Expr where
  show expr = case expr of
    Atom atom      -> "(Atom " ++ show atom ++ ")"
    List ls        -> "(List [" ++ joinWith ", " (show <$> ls) ++ "])"
    Infix e1 op e2 -> "(Infix " ++ show e1 ++ " " ++ show op ++ " " ++ show e2 ++ ")"
    SectL expr op  -> "(SectL" ++ show expr ++ " " ++ show op ++ ")"
    SectR op expr  -> "(SectR" ++ show op ++ " " ++ show expr ++ ")"
    App name args  -> "(App " ++ name ++ " [" ++ joinWith ", " (show <$> args) ++ "])"

instance showBinding :: Show Binding where
  show binding = case binding of
    Lit atom              -> "(Lit " ++ show atom ++ ")"
    ListLit atom bindings -> "(ListLit " ++ show atom ++ " " ++ show bindings ++ ")"

instance showDefinition :: Show Definition where
  show (Def name bindings body) = "(Def " ++ name ++ " " ++ show bindings ++ show body ++ ")"

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


Trying out pattern guards.

Trying out pattern guards.


Add Bob module

Add Bob module

module Pux.Routing.Bob where

import Control.Monad.Eff (Eff)
import DOM (DOM)
import Prelude

foreign import push :: forall eff. String -> Eff (dom :: DOM | eff) Unit

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


Push state implementation

Push state implementation

module Routing.PushState
  ( PushStateEffects
  , PushStateInterface
  , LocationState
  , Basename(..)
  , Path(..)
  , makeInterface
  , foldLocations
  , locations
  , foldPaths
  , paths
  , matches
  , matchesWith
  ) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (REF, modifyRef, newRef, readRef, writeRef)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener) as DOM
import DOM.HTML (window) as DOM
import DOM.HTML.Event.EventTypes (popstate) as DOM
import DOM.HTML.History (DocumentTitle(..), URL(..), pushState, replaceState, state) as DOM
import DOM.HTML.Location (hash, pathname, search) as DOM
import DOM.HTML.Types (HISTORY)
import DOM.HTML.Types (htmlDocumentToDocument, windowToEventTarget) as DOM
import DOM.HTML.Window (document, history, location) as DOM
import DOM.Node.Document (createTextNode) as DOM
import DOM.Node.MutationObserver (mutationObserver, observe) as DOM
import DOM.Node.Node (setNodeValue) as DOM
import DOM.Node.Types (textToNode) as DOM
import Data.Array (find)
import Data.Array as Array
import Data.Foldable (class Foldable, for_, traverse_)
import Data.Foreign (Foreign)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.StrMap as StrMap
import Data.String as String
import Routing (match)
import Routing.Match (Match)

type PushStateEffects eff =
  ( history :: HISTORY
  , dom :: DOM
  , ref :: REF
  | eff
  )

newtype Basename = Basename String

derive newtype instance eqBasename :: Eq Basename
derive newtype instance ordBasename :: Ord Basename
derive instance newtypeBasename :: Newtype Basename _

newtype Path = Path String

derive newtype instance eqPath :: Eq Path
derive newtype instance ordPath :: Ord Path
derive instance newtypePath :: Newtype Path _

type PushStateInterface eff =
  { pushState :: Foreign -> Path -> Eff eff Unit
  , replaceState :: Foreign -> Path -> Eff eff Unit
  , locationState :: Eff eff LocationState
  , listen :: (LocationState -> Eff eff Unit) -> Eff eff (Eff eff Unit)
  }

makeInterface :: forall eff. Basename -> Eff (PushStateEffects eff) (PushStateInterface (PushStateEffects eff))
makeInterface basename = do
  argsRef <- newRef []
  freshRef <- newRef 0
  listenersRef <- newRef StrMap.empty

  let
    notify ev =
      traverse_ (_ $ ev) =<< readRef listenersRef

    listen k = do
      fresh <- readRef freshRef
      writeRef freshRef (fresh + 1)
      modifyRef listenersRef $ StrMap.insert (show fresh) k
      pure $ modifyRef listenersRef $ StrMap.delete (show fresh)

    locationState = do
      loc <- DOM.window >>= DOM.location
      state <- DOM.window >>= DOM.history >>= DOM.state
      pathname <- fromMaybe <*> String.stripPrefix (String.Pattern (unwrap basename)) <$> DOM.pathname loc
      search <- DOM.search loc
      hash <- DOM.hash loc
      pure { state, pathname, search, hash }

  schedule <- do
    obsvNode <-
      DOM.window
        >>= DOM.document
        >>> map DOM.htmlDocumentToDocument
        >>= DOM.createTextNode ""
        >>> map DOM.textToNode
    observer <- DOM.mutationObserver \_ _ -> do
      argsQueue <- readRef argsRef
      writeRef argsRef []
      for_ argsQueue notify
    DOM.observe obsvNode { characterData: true } observer
    pure \args -> do
      argsQueue <- readRef argsRef
      writeRef argsRef (Array.snoc argsQueue args)
      when (Array.null argsQueue) do
        fresh ← readRef freshRef
        writeRef freshRef (fresh + 1)
        DOM.setNodeValue (show fresh) obsvNode

  let
    stateFn op state path = do
      let
        loc = normalizeLocation basename state path
        url = DOM.URL $ loc.pathname <> loc.search <> loc.hash
      DOM.window
        >>= DOM.history
        >>= op state (DOM.DocumentTitle "") url
      schedule loc

    listener =
      DOM.eventListener \_ -> notify =<< locationState

  DOM.window
    >>= DOM.windowToEventTarget
    >>> DOM.addEventListener DOM.popstate listener false

  pure
    { pushState: stateFn DOM.pushState
    , replaceState: stateFn DOM.replaceState
    , locationState
    , listen
    }

type LocationState =
  { state :: Foreign
  , pathname :: String
  , search :: String
  , hash :: String
  }

normalizeLocation :: Basename -> Foreign -> Path -> LocationState
normalizeLocation (Basename basename) state (Path path) =
  case searchIx, hashIx of
    Nothing, Nothing   -> { state, pathname: path', hash: "", search: "" }
    Nothing, Just hix  -> { state, pathname: String.take hix path', search: "", hash: String.drop hix path' }
    Just six, Nothing  -> { state, pathname: String.take six path', search: String.drop six path', hash: "" }
    Just six, Just hix -> { state, pathname: String.take hix path', search: String.take (hix - six) (String.drop six path'), hash: String.drop hix path' }
  where
  path' = basename <> path
  searchIx = String.indexOf (String.Pattern "?") path'
  hashIx = String.indexOf (String.Pattern "#") path'

foldLocations
  :: forall eff a
   . (a -> LocationState -> Eff (PushStateEffects eff) a)
  -> (LocationState -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldLocations cb init psi = do
  ref <- newRef =<< init =<< psi.locationState
  psi.listen (\loc -> writeRef ref =<< flip cb loc =<< readRef ref)

locations
  :: forall eff a
   . (Maybe LocationState -> LocationState -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
locations cb = foldLocations go (go Nothing)
  where
  go a b = Just b <$ cb a b

foldPaths
  :: forall eff a
   . (a -> String -> Eff (PushStateEffects eff) a)
  -> (String -> Eff (PushStateEffects eff) a)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
foldPaths cb init = foldLocations (\a -> cb a <<< toString) (init <<< toString)
  where
  toString loc = loc.pathname <> loc.search <> loc.hash

paths
  :: forall eff
   . (Maybe String -> String -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
paths = matchesWith Just

matches
  :: forall eff a
   . Match a
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matches = matchesWith <<< match

matchesWith
  :: forall eff f a
   . Foldable f
  => (String -> f a)
  -> (Maybe a -> a -> Eff (PushStateEffects eff) Unit)
  -> PushStateInterface (PushStateEffects eff)
  -> Eff (PushStateEffects eff) (Eff (PushStateEffects eff) Unit)
matchesWith parser cb = foldPaths go (go Nothing)
  where
  go a =
    maybe (pure a) (\b -> Just b <$ cb a b)
      <<< find (const true)
      <<< parser

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


Add Heap mapping addresses to nodes

Add Heap mapping addresses to nodes

module Machine.Heap
  ( Heap
  , empty
  , alloc
  , fetch
  , update
  ) where

import Prelude

import Control.Monad.State (class MonadState, gets, modify_)
import Data.HashMap (HashMap)
import Data.HashMap as HashMap
import Data.Maybe (Maybe(..))
import Data.Newtype (wrap)
import Data.Tuple (Tuple(..))
import Machine.Address (Address)
import Partial.Unsafe (unsafeCrashWith)

type Heap a =
  { memory :: HashMap Address a
  , next :: Address
  }

empty :: forall a. Heap a
empty = { memory: HashMap.empty, next: wrap 1 }

alloc :: forall a s m. MonadState { heap :: Heap a | s } m => a -> m Address
alloc node = modifyHeap \{ memory, next } -> Tuple next
  { memory: HashMap.insert next node memory
  , next: next + wrap 1
  }

fetch :: forall a s m. MonadState { heap :: Heap a | s } m => Address -> m a
fetch address = withHeap \{ memory } ->
  case HashMap.lookup address memory of
    Just node -> node
    Nothing -> unsafeCrashWith $ "Invalid address " <> show address

update :: forall a s m. MonadState { heap :: Heap a | s } m => Address -> a -> m Unit
update address node = modifyHeap \heap -> Tuple unit $ heap
  { memory = HashMap.insert address node heap.memory
  }

modifyHeap :: forall a s m r. MonadState { heap :: Heap a | s } m => (Heap a -> Tuple r (Heap a)) -> m r
modifyHeap f = do
  heap0 <- gets _.heap
  case f heap0 of
    Tuple r heap1 -> do
      modify_ $ _ { heap = heap1 }
      pure r

withHeap :: forall a s m r. MonadState { heap :: Heap a | s } m => (Heap a -> r) -> m r
withHeap f = modifyHeap $ \heap -> Tuple (f heap) heap

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