Parse 'u' as a the SI prefix micro

Parse 'u' as a the SI prefix micro

-- | This module defines the parser for the Insect language.
module Insect.Parser
  ( DictEntry(..)
  , (==>)
  , Dictionary(..)
  , commands
  , functions
  , siPrefixDict
  , 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

siPrefixDict ∷ Dictionary (DerivedUnit → DerivedUnit)
siPrefixDict = Dictionary
  [ 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 prefix like `µ` or `G`.
siPrefix ∷ P (DerivedUnit → DerivedUnit)
siPrefix = buildDictParser siPrefixDict <|> 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.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.liter ==> ["liters", "liter", "litres", "litre", "L"]
  , Q.tonne ==> ["tonnes", "tonne", "tons", "ton"]
  , Q.electronvolt ==> ["electronvolt", "eV"]
  , Q.bel ==> ["bel"]
  , Q.astronomicalUnit ==> ["AU"]
  , 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"]
  , 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.month ==> ["months", "month"]
  , Q.year ==> ["years", "year"]
  , Q.gram ==> ["grammes", "gramme", "grams", "gram", "g"]
  , Q.meter ==> ["metres", "metre", "meters", "meter", "m"]
  ]

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

-- | 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 ← siPrefix
  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"]
  , Gamma ==> ["gamma"]
  , Log10 ==> ["log10"]
  , Ln ==> ["log", "ln"]
  , Round ==> ["round"]
  , Sinh ==> ["sinh"]
  , Sin ==> ["sin"]
  , Sqrt ==> ["sqrt"]
  , Tanh ==> ["tanh"]
  , Tan ==> ["tan"]
  ]

-- | 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 "→" <|> 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
  , siPrefixDict
  , 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

siPrefixDict ∷ Dictionary (DerivedUnit → DerivedUnit)
siPrefixDict = Dictionary
  [ 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"
                , "µ" -- 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 prefix like `µ` or `G`.
siPrefix ∷ P (DerivedUnit → DerivedUnit)
siPrefix = buildDictParser siPrefixDict <|> 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.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.liter ==> ["liters", "liter", "litres", "litre", "L"]
  , Q.tonne ==> ["tonnes", "tonne", "tons", "ton"]
  , Q.electronvolt ==> ["electronvolt", "eV"]
  , Q.bel ==> ["bel"]
  , Q.astronomicalUnit ==> ["AU"]
  , 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"]
  , 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.month ==> ["months", "month"]
  , Q.year ==> ["years", "year"]
  , Q.gram ==> ["grammes", "gramme", "grams", "gram", "g"]
  , Q.meter ==> ["metres", "metre", "meters", "meter", "m"]
  ]

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

-- | 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 ← siPrefix
  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"]
  , Gamma ==> ["gamma"]
  , Log10 ==> ["log10"]
  , Ln ==> ["log", "ln"]
  , Round ==> ["round"]
  , Sinh ==> ["sinh"]
  , Sin ==> ["sin"]
  , Sqrt ==> ["sqrt"]
  , Tanh ==> ["tanh"]
  , Tan ==> ["tan"]
  ]

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


Fix docs for `permsToString`

Fix docs for `permsToString`

module Node.FS.Perms
  ( Perm()
  , none
  , read
  , write
  , execute
  , all
  , Perms()
  , mkPerms
  , permsFromString
  , permsToString
  , permsToInt
  ) where

import Global (readInt)
import Data.Array () -- for Semigroup and Functor instances
import Data.Maybe (Maybe(..))
import Data.Char (Char(), charString, fromCharCode)
import Data.String (toCharArray, joinWith, drop, charAt)
import Data.Int (Int(), fromNumber, toNumber)

-- | A `Perm` value specifies what is allowed to be done with a particular
-- | file by a particular class of user — that is, whether it is
-- | readable, writable, and/or executable. It has a semigroup instance, which
-- | allows you to combine permissions; for example, `read <> write` means
-- | "readable and writable".
newtype Perm = Perm { r :: Boolean, w :: Boolean, x :: Boolean }

instance eqPerm :: Eq Perm where
  (==) (Perm { r = r1, w = w1, x = x1 }) (Perm { r = r2, w = w2, x = x2 }) =
    r1 == r2  && w1 == w2 && x1 == x2
  (/=) x y = not (x == y)

instance ordPerm :: Ord Perm where
  compare (Perm { r = r1, w = w1, x = x1 }) (Perm { r = r2, w = w2, x = x2 }) =
    compare [r1, w1, x1] [r2, w2, x2]

instance showPerm :: Show Perm where
  show p | p == none = "none"
  show p | p == all  = "all"
  show (Perm { r = r, w = w, x = x }) =
    joinWith " <> " ps
    where
    ps =
      (if r then ["read"] else []) <>
      (if w then ["write"] else []) <>
      (if x then ["execute"] else [])

instance semigroupPerm :: Semigroup Perm where
  (<>) (Perm { r = r0, w = w0, x = x0 }) (Perm { r = r1, w = w1, x = x1 }) =
    Perm { r: r0 || r1, w: w0 || w1, x: x0 || x1  }

-- | Create a `Perm` value. The arguments represent the readable, writable, and
-- | executable permissions, in that order.
mkPerm :: Boolean -> Boolean -> Boolean -> Perm
mkPerm r w x = Perm { r: r, w: w, x: x }

-- | No permissions. This is the identity of the `Semigroup` operation `(<>)`
-- | for `Perm`.
none :: Perm
none = Perm { r: false, w: false, x: false }

-- | The "readable" permission.
read :: Perm
read = Perm { r: true, w: false, x: false }

-- | The "writable" permission.
write :: Perm
write = Perm { r: false, w: true, x: false }

-- | The "executable" permission.
execute :: Perm
execute = Perm { r: false, w: false, x: true }

-- | All permissions: readable, writable, and executable.
all :: Perm
all = read <> write <> execute

-- | A `Perms` value includes all the permissions information about a
-- | particular file or directory, by storing a `Perm` value for each of the
-- | file owner, the group, and any other users.
newtype Perms = Perms { u :: Perm, g :: Perm, o :: Perm }

instance eqPerms :: Eq Perms where
  (==) (Perms { u = u1, g = g1, o = o1 }) (Perms { u = u2, g = g2, o = o2 }) =
    u1 == u2  && g1 == g2 && o1 == o2
  (/=) x y = not (x == y)

instance ordPerms :: Ord Perms where
  compare (Perms { u = u1, g = g1, o = o1 }) (Perms { u = u2, g = g2, o = o2 }) =
    compare [u1, g1, o1] [u2, g2, o2]

instance showPerms :: Show Perms where
  show (Perms { u = u, g = g, o = o }) =
    "mkPerms " <> joinWith " " (f <$> [u, g, o])
    where
    f perm = "(" <> show perm <> ")"

-- | Attempt to parse a `Perms` value from a `String` containing an octal
-- | integer. For example,
-- | `permsFromString "0644" == Just (mkPerms (read <> write) read read)`.
permsFromString :: String -> Maybe Perms
permsFromString = _perms <<< toCharArray <<< dropPrefix zeroChar
  where
    zeroChar = fromCharCode 48

    dropPrefix x xs
      | charAt 0 xs == Just x = drop 1 xs
      | otherwise             = xs

    _perms [u, g, o] =
      mkPerms <$> permFromChar u
              <*> permFromChar g
              <*> permFromChar o
    _perms _ = Nothing

permFromChar :: Char -> Maybe Perm
permFromChar = _perm <<< charString
  where
    _perm "0" = Just $ none
    _perm "1" = Just $ execute
    _perm "2" = Just $ write
    _perm "3" = Just $ write <> execute
    _perm "4" = Just $ read
    _perm "5" = Just $ read <> execute
    _perm "6" = Just $ read <> write
    _perm "7" = Just $ read <> write <> execute
    _perm _   = Nothing

-- | Create a `Perms` value. The arguments represent the owner's, group's, and
-- | other users' permission sets, respectively.
mkPerms :: Perm -> Perm -> Perm -> Perms
mkPerms u g o = Perms { u: u, g: g, o: o }

-- | Convert a `Perm` to an octal digit. For example:
-- |
-- | * `permToInt r == 4`
-- | * `permToInt w == 2`
-- | * `permToInt (r <> w) == 6`
permToInt :: Perm -> Int
permToInt (Perm { r = r, w = w, x = x }) =
  fromNumber $
      (if r then 4 else 0)
    + (if w then 2 else 0)
    + (if x then 1 else 0)

-- | Convert a `Perm` to an octal string, via `permToInt`.
permToString :: Perm -> String
permToString = show <<< toNumber <<< permToInt

-- | Convert a `Perms` value to an octal string, in a format similar to that
-- | accepted by `chmod`. For example:
-- | `permsToString (mkPerms (read <> write) read read) == "0644"`
permsToString :: Perms -> String
permsToString (Perms { u = u, g = g, o = o }) =
     "0"
  ++ permToString u
  ++ permToString g
  ++ permToString o

-- | Convert a `Perms` value to an `Int`, via `permsToString`.
permsToInt :: Perms -> Int
permsToInt = fromNumber <<< readInt 8 <<< permsToString

module Node.FS.Perms
  ( Perm()
  , none
  , read
  , write
  , execute
  , all
  , Perms()
  , mkPerms
  , permsFromString
  , permsToString
  , permsToInt
  ) where

import Global (readInt)
import Data.Array () -- for Semigroup and Functor instances
import Data.Maybe (Maybe(..))
import Data.Char (Char(), charString, fromCharCode)
import Data.String (toCharArray, joinWith, drop, charAt)
import Data.Int (Int(), fromNumber, toNumber)

-- | A `Perm` value specifies what is allowed to be done with a particular
-- | file by a particular class of user — that is, whether it is
-- | readable, writable, and/or executable. It has a semigroup instance, which
-- | allows you to combine permissions; for example, `read <> write` means
-- | "readable and writable".
newtype Perm = Perm { r :: Boolean, w :: Boolean, x :: Boolean }

instance eqPerm :: Eq Perm where
  (==) (Perm { r = r1, w = w1, x = x1 }) (Perm { r = r2, w = w2, x = x2 }) =
    r1 == r2  && w1 == w2 && x1 == x2
  (/=) x y = not (x == y)

instance ordPerm :: Ord Perm where
  compare (Perm { r = r1, w = w1, x = x1 }) (Perm { r = r2, w = w2, x = x2 }) =
    compare [r1, w1, x1] [r2, w2, x2]

instance showPerm :: Show Perm where
  show p | p == none = "none"
  show p | p == all  = "all"
  show (Perm { r = r, w = w, x = x }) =
    joinWith " <> " ps
    where
    ps =
      (if r then ["read"] else []) <>
      (if w then ["write"] else []) <>
      (if x then ["execute"] else [])

instance semigroupPerm :: Semigroup Perm where
  (<>) (Perm { r = r0, w = w0, x = x0 }) (Perm { r = r1, w = w1, x = x1 }) =
    Perm { r: r0 || r1, w: w0 || w1, x: x0 || x1  }

-- | Create a `Perm` value. The arguments represent the readable, writable, and
-- | executable permissions, in that order.
mkPerm :: Boolean -> Boolean -> Boolean -> Perm
mkPerm r w x = Perm { r: r, w: w, x: x }

-- | No permissions. This is the identity of the `Semigroup` operation `(<>)`
-- | for `Perm`.
none :: Perm
none = Perm { r: false, w: false, x: false }

-- | The "readable" permission.
read :: Perm
read = Perm { r: true, w: false, x: false }

-- | The "writable" permission.
write :: Perm
write = Perm { r: false, w: true, x: false }

-- | The "executable" permission.
execute :: Perm
execute = Perm { r: false, w: false, x: true }

-- | All permissions: readable, writable, and executable.
all :: Perm
all = read <> write <> execute

-- | A `Perms` value includes all the permissions information about a
-- | particular file or directory, by storing a `Perm` value for each of the
-- | file owner, the group, and any other users.
newtype Perms = Perms { u :: Perm, g :: Perm, o :: Perm }

instance eqPerms :: Eq Perms where
  (==) (Perms { u = u1, g = g1, o = o1 }) (Perms { u = u2, g = g2, o = o2 }) =
    u1 == u2  && g1 == g2 && o1 == o2
  (/=) x y = not (x == y)

instance ordPerms :: Ord Perms where
  compare (Perms { u = u1, g = g1, o = o1 }) (Perms { u = u2, g = g2, o = o2 }) =
    compare [u1, g1, o1] [u2, g2, o2]

instance showPerms :: Show Perms where
  show (Perms { u = u, g = g, o = o }) =
    "mkPerms " <> joinWith " " (f <$> [u, g, o])
    where
    f perm = "(" <> show perm <> ")"

-- | Attempt to parse a `Perms` value from a `String` containing an octal
-- | integer. For example,
-- | `permsFromString "0644" == Just (mkPerms (read <> write) read read)`.
permsFromString :: String -> Maybe Perms
permsFromString = _perms <<< toCharArray <<< dropPrefix zeroChar
  where
    zeroChar = fromCharCode 48

    dropPrefix x xs
      | charAt 0 xs == Just x = drop 1 xs
      | otherwise             = xs

    _perms [u, g, o] =
      mkPerms <$> permFromChar u
              <*> permFromChar g
              <*> permFromChar o
    _perms _ = Nothing

permFromChar :: Char -> Maybe Perm
permFromChar = _perm <<< charString
  where
    _perm "0" = Just $ none
    _perm "1" = Just $ execute
    _perm "2" = Just $ write
    _perm "3" = Just $ write <> execute
    _perm "4" = Just $ read
    _perm "5" = Just $ read <> execute
    _perm "6" = Just $ read <> write
    _perm "7" = Just $ read <> write <> execute
    _perm _   = Nothing

-- | Create a `Perms` value. The arguments represent the owner's, group's, and
-- | other users' permission sets, respectively.
mkPerms :: Perm -> Perm -> Perm -> Perms
mkPerms u g o = Perms { u: u, g: g, o: o }

-- | Convert a `Perm` to an octal digit. For example:
-- |
-- | * `permToInt r == 4`
-- | * `permToInt w == 2`
-- | * `permToInt (r <> w) == 6`
permToInt :: Perm -> Int
permToInt (Perm { r = r, w = w, x = x }) =
  fromNumber $
      (if r then 4 else 0)
    + (if w then 2 else 0)
    + (if x then 1 else 0)

-- | Convert a `Perm` to an octal string, via `permToInt`.
permToString :: Perm -> String
permToString = show <<< toNumber <<< permToInt

-- | Convert a `Perms` value to an octal string, in a format similar to that
-- | accepted by `chmod`. For example:
-- |
-- | * `permsToString (mkPerms (r <> w) r r) == "0644"`
permsToString :: Perms -> String
permsToString (Perms { u = u, g = g, o = o }) =
     "0"
  ++ permToString u
  ++ permToString g
  ++ permToString o

-- | Convert a `Perms` value to an `Int`, via `permsToString`.
permsToInt :: Perms -> Int
permsToInt = fromNumber <<< readInt 8 <<< permsToString


Indentation example

Indentation example

module Main where

  import Prelude

  collatz = \x -> case x of
    y | y % 2 == 0 -> y / 2
    y -> y * 3 + 1

  -- Guards have access to current scope
  collatz2 = \x y -> case x of
    z | y > 0 -> z / 2
    z -> z * 3 + 1

  min :: forall a. (Ord a) => a -> a -> a
  min n m | n < m     = n
          | otherwise = m

  max :: forall a. (Ord a) => a -> a -> a
  max n m = case unit of
    _ | m < n     -> n
      | otherwise -> m

  testIndentation :: Number -> Number -> Number
  testIndentation x y | x > 0
    = x + y
                      | otherwise
    = y - x

  main = Debug.Trace.trace $ min "Done" "ZZZZ"

module Main where

  import Prelude

  collatz = \x -> case x of
    y | y % 2 == 0 -> y / 2
    y -> y * 3 + 1

  -- Guards have access to current scope
  collatz2 = \x y -> case x of
    z | y > 0 -> z / 2
    z -> z * 3 + 1

  min :: forall a. (Ord a) => a -> a -> a
  min n m | n < m     = n
          | otherwise = m

  max :: forall a. (Ord a) => a -> a -> a
  max n m = case unit of
    _ | m < n     -> n
      | otherwise -> m

  main = Debug.Trace.trace $ min "Done" "ZZZZ"


η-reduction on IdentParserT and IdentParser

module IndentParser (
    -- $doc
    -- * Types
    IndentParser, IndentParserT, runIndent,
    -- * Blocks
    withBlock, withBlock', block, block1,
    -- * Indentation Checking
    indented, indented', sameLine, sameOrIndented, checkIndent, withPos,
    -- * Paired characters
    -- indentBrackets, indentAngles, indentBraces, indentParens,
    -- * Line Fold Chaining
    -- | Any chain using these combinators must used with 'withPos'
    indentAp, (<+/>), indentNoAp, (<-/>), indentMany, (<*/>), indentOp, (<?/>), OptionalT(..), Optional
) where

import Prelude (class Monad, Unit, id, ap, const, ($), flip, unit, (==), bind, (<=), (>>=))
import Data.List (List(..), many)
import Data.Maybe (Maybe(..))
import Data.Identity (Identity(..))

import Control.Alt ((<|>))
import Control.Apply ((*>), lift2)
import Control.Applicative (pure)
import Control.Monad.Trans.Class (lift)
import Control.Monad.State (StateT, State, evalState)
import Control.Monad.State.Trans (get, put)

import Text.Parsing.Parser (ParserT, ParseState(ParseState), fail)
import Text.Parsing.Parser.Combinators
import Text.Parsing.Parser.Pos (Position(..), initialPos)
import Text.Parsing.Parser.String (string, oneOf)

-- $doc
-- This is purescript-port of Text.Parsing.Indent
-- https://hackage.haskell.org/package/indents-0.3.3/docs/Text-Parsec-Indent.html, 05.07.2016

-- A module to construct indentation aware parsers. Many programming
-- language have indentation based syntax rules e.g. python and Haskell.
-- This module exports combinators to create such parsers.
--
-- The input source can be thought of as a list of tokens. Abstractly
-- each token occurs at a line and a column and has a width. The column
-- number of a token measures is indentation. If t1 and t2 are two tokens
-- then we say that indentation of t1 is more than t2 if the column
-- number of occurrence of t1 is greater than that of t2.
--
-- Currently this module supports two kind of indentation based syntactic
-- structures which we now describe:
--
-- [Block] --A block of indentation /c/ is a sequence of tokens with
-- indentation at least /c/.  Examples for a block is a where clause of
-- Haskell with no explicit braces.
--
-- [Line fold] A line fold starting at line /l/ and indentation /c/ is a
-- sequence of tokens that start at line /l/ and possibly continue to
-- subsequent lines as long as the indentation is greater than /c/. Such
-- a sequence of lines need to be /folded/ to a single line. An example
-- is MIME headers. Line folding based binding separation is used in
-- Haskell as well.

-- | Indentation sensitive parser type. Usually @ m @ will
--   be @ Identity @ as with any @ ParserT @
type IndentParserT s m = ParserT s (StateT Position m)
type IndentParser s = IndentParserT s Identity

-- | @ getPosition @ returns current position
--   should probably be added to Text.Parsing.Parser.Pos
getPosition :: forall m s. (Monad m) => ParserT s m Position
getPosition = get >>= \(ParseState _ pos _) -> pure pos

-- | simple helper function to avoid typ-problems with MonadState instance
get' :: forall m s. (Monad m) => IndentParserT s m Position
get' = do
  g <- lift get
  pure g

-- | simple helper function to avoid typ-problems with MonadState instance
put' :: forall m s. (Monad m) => Position -> IndentParserT s m Unit
put' p = lift (put p)

sourceColumn :: Position -> Int
sourceColumn (Position {line: _, column: c}) = c

sourceLine :: Position -> Int
sourceLine (Position {line: l, column: _}) = l

setSourceLine :: Position -> Int -> Position
setSourceLine (Position {line: _, column: c}) l = Position {line: l, column: c}

biAp :: forall a b c. (a -> b) -> (b -> b -> c) -> a -> a -> c
biAp f c v1 v2 = c (f v1) (f v2)

-- | @ many1 @ should prabably be inside Text.Parsing.Parser.Combinators
many1 :: forall s m a. (Monad m) => ParserT s m a -> ParserT s m (List a)
many1 p = lift2 Cons p (many p)

symbol :: forall m. (Monad m) => String -> ParserT String m String
symbol name = (many $ oneOf [' ','\t']) *> (string name)

----------------------------------------------------------------------

-- | @ 'withBlock' f a p @ parses @ a @
--   followed by an indented block of @ p @
--   combining them with @ f @
withBlock :: forall m a b c s. (Monad m) => (a -> List b -> c) -> IndentParserT s m a -> IndentParserT s m b -> IndentParserT s m c
withBlock f a p = withPos $ do
    r1 <- a
    r  <- optionMaybe $ indented *> block p
    case r of
      Nothing -> pure (f r1 Nil)
      Just r2 -> pure (f r1 r2)

-- | Like 'withBlock', but throws away initial parse result
withBlock' :: forall m a b s. (Monad m) => IndentParserT s m a -> IndentParserT s m b -> IndentParserT s m (List b)
withBlock' = withBlock (flip const)

-- | Parses only when indented past the level of the reference
indented :: forall m s. (Monad m) => IndentParserT s m Unit
indented = do
    pos <- getPosition
    s <- get'
    if biAp sourceColumn (<=) pos s then fail "not indented" else do
        put' $ setSourceLine s (sourceLine pos)
        pure unit

-- | same as 'indented', but does not change the indent state
indented' :: forall m s. (Monad m) => IndentParserT s m Unit
indented' = do
    pos <- getPosition
    s <- get'
    if biAp sourceColumn (<=) pos s then fail "not indented" else pure unit

-- | Parses only when indented past the level of the reference or on the same line
sameOrIndented :: forall m s. (Monad m) => IndentParserT s m Unit
sameOrIndented = sameLine <|> indented

-- | Parses only on the same line as the reference
sameLine :: forall m s. (Monad m) => IndentParserT s m Unit
sameLine = do
    pos <- getPosition
    s   <- get'
    if biAp sourceLine (==) pos s then pure unit else fail "over one line"

-- | Parses a block of lines at the same indentation level
block1 :: forall m s a. (Monad m) => IndentParserT s m a -> IndentParserT s m (List a)
block1 p = withPos $ do
    r <- many1 $ checkIndent *> p
    pure r

-- | Parses a block of lines at the same indentation level , empty Blocks allowed
block :: forall m s a. (Monad m) => IndentParserT s m a -> IndentParserT s m (List a)
block p = withPos $ do
    r <- many $ checkIndent *> p
    pure r

-- | Parses using the current location for indentation reference
withPos :: forall m s a. (Monad m) => IndentParserT s m a -> IndentParserT s m a
withPos x = do
    a <- get'
    p <- getPosition
    r <- put' p *> x
    put' a *> pure r

-- | Ensures the current indentation level matches that of the reference
checkIndent :: forall m s. (Monad m) => IndentParserT s m Unit
checkIndent = do
    s <- get'
    p <- getPosition
    if biAp sourceColumn (==) p s then pure unit else fail "indentation doesn't match"

-- | Run the result of an indentation sensitive parse
runIndent :: forall a. State Position a -> a
runIndent = flip evalState initialPos

-- | '<+/>' is to indentation sensitive parsers what 'ap' is to monads
indentAp :: forall m s a b. (Monad m) => IndentParserT s m (a -> b) -> IndentParserT s m a -> IndentParserT s m b
indentAp a b = ap a $ sameOrIndented *> b

infixl 9 indentAp as <+/>

-- | Like '<+/>' but doesn't apply the function to the parsed value
indentNoAp :: forall m s a b. (Monad m) => IndentParserT s m a -> IndentParserT s m b -> IndentParserT s m a
indentNoAp a b = lift2 const a $ sameOrIndented *> b

infixl 10 indentNoAp as <-/>

-- | Like '<+/>' but applies the second parser many times
indentMany :: forall m s a b. (Monad m) => IndentParserT s m (List a -> b) -> IndentParserT s m a -> IndentParserT s m b
indentMany a b = ap a (many (sameOrIndented *> b))

infixl 11 indentMany as <*/>

-- | Datatype used to optional parsing
data OptionalT s m a = Opt a (IndentParserT s m a)
type Optional s a = OptionalT s Identity a

-- | Like '<+/>' but applies the second parser optionally using the 'Optional' datatype
indentOp :: forall m s a b. (Monad m) => IndentParserT s m (a -> b) -> (OptionalT s m a) -> IndentParserT s m b
indentOp a (Opt b c) = ap a (option b (sameOrIndented *> c))

infixl 12 indentOp as <?/>

-- | parses with surrounding brackets
indentBrackets :: forall m a. (Monad m) => IndentParserT String m a -> IndentParserT String m a
indentBrackets p = withPos $ pure id <-/> symbol "[" <+/> p <-/> symbol "]"

-- | parses with surrounding angle brackets
indentAngles :: forall m a. (Monad m) => IndentParserT String m a -> IndentParserT String m a
indentAngles p = withPos $ pure id <-/> symbol "<" <+/> p <-/> symbol ">"

-- | parses with surrounding braces
indentBraces :: forall m a. (Monad m) => IndentParserT String m a -> IndentParserT String m a
indentBraces p = withPos $ pure id <-/> symbol "{" <+/> p <-/> symbol "}"

-- | parses with surrounding parentheses
indentParens :: forall m a. (Monad m) => IndentParserT String m a -> IndentParserT String m a
indentParens p = withPos $ pure id <-/> symbol "(" <+/> p <-/> symbol ")"

module IndentParser (
    -- $doc
    -- * Types
    IndentParser, IndentParserT, runIndent,
    -- * Blocks
    withBlock, withBlock', block, block1,
    -- * Indentation Checking
    indented, indented', sameLine, sameOrIndented, checkIndent, withPos,
    -- * Paired characters
    -- indentBrackets, indentAngles, indentBraces, indentParens,
    -- * Line Fold Chaining
    -- | Any chain using these combinators must used with 'withPos'
    indentAp, (<+/>), indentNoAp, (<-/>), indentMany, (<*/>), indentOp, (<?/>), OptionalT(..), Optional
) where

import Prelude (class Monad, Unit, id, ap, const, ($), flip, unit, (==), bind, (<=), (>>=))
import Data.List (List(..), many)
import Data.Maybe (Maybe(..))
import Data.Identity (Identity(..))

import Control.Alt ((<|>))
import Control.Apply ((*>), lift2)
import Control.Applicative (pure)
import Control.Monad.Trans.Class (lift)
import Control.Monad.State (StateT, State, evalState)
import Control.Monad.State.Trans (get, put)

import Text.Parsing.Parser (ParserT, ParseState(ParseState), fail)
import Text.Parsing.Parser.Combinators
import Text.Parsing.Parser.Pos (Position(..), initialPos)
import Text.Parsing.Parser.String (string, oneOf)

-- $doc
-- This is purescript-port of Text.Parsing.Indent
-- https://hackage.haskell.org/package/indents-0.3.3/docs/Text-Parsec-Indent.html, 05.07.2016

-- A module to construct indentation aware parsers. Many programming
-- language have indentation based syntax rules e.g. python and Haskell.
-- This module exports combinators to create such parsers.
--
-- The input source can be thought of as a list of tokens. Abstractly
-- each token occurs at a line and a column and has a width. The column
-- number of a token measures is indentation. If t1 and t2 are two tokens
-- then we say that indentation of t1 is more than t2 if the column
-- number of occurrence of t1 is greater than that of t2.
--
-- Currently this module supports two kind of indentation based syntactic
-- structures which we now describe:
--
-- [Block] --A block of indentation /c/ is a sequence of tokens with
-- indentation at least /c/.  Examples for a block is a where clause of
-- Haskell with no explicit braces.
--
-- [Line fold] A line fold starting at line /l/ and indentation /c/ is a
-- sequence of tokens that start at line /l/ and possibly continue to
-- subsequent lines as long as the indentation is greater than /c/. Such
-- a sequence of lines need to be /folded/ to a single line. An example
-- is MIME headers. Line folding based binding separation is used in
-- Haskell as well.

-- | Indentation sensitive parser type. Usually @ m @ will
--   be @ Identity @ as with any @ ParserT @
type IndentParserT s m a = ParserT s (StateT Position m) a
type IndentParser s a = IndentParserT s Identity a

-- | @ getPosition @ returns current position
--   should probably be added to Text.Parsing.Parser.Pos
getPosition :: forall m s. (Monad m) => ParserT s m Position
getPosition = get >>= \(ParseState _ pos _) -> pure pos

-- | simple helper function to avoid typ-problems with MonadState instance
get' :: forall m s. (Monad m) => IndentParserT s m Position
get' = do
  g <- lift get
  pure g

-- | simple helper function to avoid typ-problems with MonadState instance
put' :: forall m s. (Monad m) => Position -> IndentParserT s m Unit
put' p = lift (put p)

sourceColumn :: Position -> Int
sourceColumn (Position {line: _, column: c}) = c

sourceLine :: Position -> Int
sourceLine (Position {line: l, column: _}) = l

setSourceLine :: Position -> Int -> Position
setSourceLine (Position {line: _, column: c}) l = Position {line: l, column: c}

biAp :: forall a b c. (a -> b) -> (b -> b -> c) -> a -> a -> c
biAp f c v1 v2 = c (f v1) (f v2)

-- | @ many1 @ should prabably be inside Text.Parsing.Parser.Combinators
many1 :: forall s m a. (Monad m) => ParserT s m a -> ParserT s m (List a)
many1 p = lift2 Cons p (many p)

symbol :: forall m. (Monad m) => String -> ParserT String m String
symbol name = (many $ oneOf [' ','\t']) *> (string name)

----------------------------------------------------------------------

-- | @ 'withBlock' f a p @ parses @ a @
--   followed by an indented block of @ p @
--   combining them with @ f @
withBlock :: forall m a b c s. (Monad m) => (a -> List b -> c) -> IndentParserT s m a -> IndentParserT s m b -> IndentParserT s m c
withBlock f a p = withPos $ do
    r1 <- a
    r  <- optionMaybe $ indented *> block p
    case r of
      Nothing -> pure (f r1 Nil)
      Just r2 -> pure (f r1 r2)

-- | Like 'withBlock', but throws away initial parse result
withBlock' :: forall m a b s. (Monad m) => IndentParserT s m a -> IndentParserT s m b -> IndentParserT s m (List b)
withBlock' = withBlock (flip const)

-- | Parses only when indented past the level of the reference
indented :: forall m s. (Monad m) => IndentParserT s m Unit
indented = do
    pos <- getPosition
    s <- get'
    if biAp sourceColumn (<=) pos s then fail "not indented" else do
        put' $ setSourceLine s (sourceLine pos)
        pure unit

-- | same as 'indented', but does not change the indent state
indented' :: forall m s. (Monad m) => IndentParserT s m Unit
indented' = do
    pos <- getPosition
    s <- get'
    if biAp sourceColumn (<=) pos s then fail "not indented" else pure unit

-- | Parses only when indented past the level of the reference or on the same line
sameOrIndented :: forall m s. (Monad m) => IndentParserT s m Unit
sameOrIndented = sameLine <|> indented

-- | Parses only on the same line as the reference
sameLine :: forall m s. (Monad m) => IndentParserT s m Unit
sameLine = do
    pos <- getPosition
    s   <- get'
    if biAp sourceLine (==) pos s then pure unit else fail "over one line"

-- | Parses a block of lines at the same indentation level
block1 :: forall m s a. (Monad m) => IndentParserT s m a -> IndentParserT s m (List a)
block1 p = withPos $ do
    r <- many1 $ checkIndent *> p
    pure r

-- | Parses a block of lines at the same indentation level , empty Blocks allowed
block :: forall m s a. (Monad m) => IndentParserT s m a -> IndentParserT s m (List a)
block p = withPos $ do
    r <- many $ checkIndent *> p
    pure r

-- | Parses using the current location for indentation reference
withPos :: forall m s a. (Monad m) => IndentParserT s m a -> IndentParserT s m a
withPos x = do
    a <- get'
    p <- getPosition
    r <- put' p *> x
    put' a *> pure r

-- | Ensures the current indentation level matches that of the reference
checkIndent :: forall m s. (Monad m) => IndentParserT s m Unit
checkIndent = do
    s <- get'
    p <- getPosition
    if biAp sourceColumn (==) p s then pure unit else fail "indentation doesn't match"

-- | Run the result of an indentation sensitive parse
runIndent :: forall a. State Position a -> a
runIndent = flip evalState initialPos

-- | '<+/>' is to indentation sensitive parsers what 'ap' is to monads
indentAp :: forall m s a b. (Monad m) => IndentParserT s m (a -> b) -> IndentParserT s m a -> IndentParserT s m b
indentAp a b = ap a $ sameOrIndented *> b

infixl 9 indentAp as <+/>

-- | Like '<+/>' but doesn't apply the function to the parsed value
indentNoAp :: forall m s a b. (Monad m) => IndentParserT s m a -> IndentParserT s m b -> IndentParserT s m a
indentNoAp a b = lift2 const a $ sameOrIndented *> b

infixl 10 indentNoAp as <-/>

-- | Like '<+/>' but applies the second parser many times
indentMany :: forall m s a b. (Monad m) => IndentParserT s m (List a -> b) -> IndentParserT s m a -> IndentParserT s m b
indentMany a b = ap a (many (sameOrIndented *> b))

infixl 11 indentMany as <*/>

-- | Datatype used to optional parsing
data OptionalT s m a = Opt a (IndentParserT s m a)
type Optional s a = OptionalT s Identity a

-- | Like '<+/>' but applies the second parser optionally using the 'Optional' datatype
indentOp :: forall m s a b. (Monad m) => IndentParserT s m (a -> b) -> (OptionalT s m a) -> IndentParserT s m b
indentOp a (Opt b c) = ap a (option b (sameOrIndented *> c))

infixl 12 indentOp as <?/>

-- | parses with surrounding brackets
indentBrackets :: forall m a. (Monad m) => IndentParserT String m a -> IndentParserT String m a
indentBrackets p = withPos $ pure id <-/> symbol "[" <+/> p <-/> symbol "]"

-- | parses with surrounding angle brackets
indentAngles :: forall m a. (Monad m) => IndentParserT String m a -> IndentParserT String m a
indentAngles p = withPos $ pure id <-/> symbol "<" <+/> p <-/> symbol ">"

-- | parses with surrounding braces
indentBraces :: forall m a. (Monad m) => IndentParserT String m a -> IndentParserT String m a
indentBraces p = withPos $ pure id <-/> symbol "{" <+/> p <-/> symbol "}"

-- | parses with surrounding parentheses
indentParens :: forall m a. (Monad m) => IndentParserT String m a -> IndentParserT String m a
indentParens p = withPos $ pure id <-/> symbol "(" <+/> p <-/> symbol ")"


formatted

formatted

module Blueprint.Ccomponents.Hotkeys where

import Blueprint.ComponentsClasses (hotkeyClass, hotkeysClass)
import Blueprint.PropTypes (Prop, PropsEx, UnknownEventType)
import React

-- DISCUSS: Do we need this to be extensible?
type HotkeysProps = HotkeysPropsEx ()

type HotkeysPropsEx r = PropsEx
  ( tabIndex :: Int
  | r
  )

type HotkeyProps =
  { combo :: String
  , label :: String
  , global :: Boolean
  , group :: String
  , onKeyDown :: UnknownEventType
  , onKeyUp :: UnknownEventType
  }

hotkey :: Prop HotkeyProps -> Array ReactElement -> ReactElement
hotkey = createElement hotkeyClass

hotkeys :: Prop HotkeysProps -> Array ReactElement -> ReactElement
hotkeys = createElement hotkeysClass

module Blueprint.Ccomponents.Hotkeys where

import Blueprint.PropTypes
import Blueprint.ComponentsClasses
import React

type IHotkeysProps = IHotkeysPropsEx ()
type IHotkeysPropsEx r = IPropsEx (tabIndex :: Int | r)

type IHotkeyProps = { combo :: String

                    , label :: String
                    , global :: Boolean
                    , group :: String
                    , onKeyDown :: UnknownEventType
                    , onKeyUp :: UnknownEventType
                    }

hotkey :: Prop IHotkeyProps -> Array ReactElement -> ReactElement
hotkey = createElement hotkeyClass

hotkeys :: Prop IHotkeysProps -> Array ReactElement -> ReactElement
hotkeys = createElement hotkeysClass


Indicate that Array monad is a nested for loop

module Control.Monad
  ( class Monad
  , liftM1
  , ap
  , whenM
  , unlessM
  , module Data.Functor
  , module Control.Apply
  , module Control.Applicative
  , module Control.Bind
  ) where

import Control.Applicative (class Applicative, liftA1, pure, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Bind (class Bind, bind, ifM, join, (<=<), (=<<), (>=>), (>>=))

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit)

-- | The `Monad` type class combines the operations of the `Bind` and
-- | `Applicative` type classes. Therefore, `Monad` instances represent type
-- | constructors which support sequential composition, and also lifting of
-- | functions of arbitrary arity.
-- |
-- | Instances must satisfy the following laws in addition to the
-- | `Applicative` and `Bind` laws:
-- |
-- | - Left Identity: `pure x >>= f = f x`
-- | - Right Identity: `x >>= pure = x`
-- | - Applicative Superclass: `apply = ap`
class (Applicative m, Bind m) <= Monad m

instance monadFn :: Monad ((->) r)

-- | The `Array` monad's "do notation" works like a nested for loop:
-- | ```
-- | foo :: Array Int
-- | foo = do
-- |   eachElementInArray1 <- [0, 1]
-- |   eachElementInArray2 <- [1, 2]
-- |   pure (eachElementInArray1 + eachElementInArray2)
-- |
-- | foo == [(0 + 1), (0 + 2), (1 + 1), (1 + 2)] == [1, 2, 2, 3]
-- | ```
instance monadArray :: Monad Array

-- | `liftM1` provides a default implementation of `(<$>)` for any
-- | [`Monad`](#monad), without using `(<$>)` as provided by the
-- | [`Functor`](#functor)-[`Monad`](#monad) superclass relationship.
-- |
-- | `liftM1` can therefore be used to write [`Functor`](#functor) instances
-- | as follows:
-- |
-- | ```purescript
-- | instance functorF :: Functor F where
-- |   map = liftM1
-- | ```
liftM1 :: forall m a b. Monad m => (a -> b) -> m a -> m b
liftM1 f a = do
  a' <- a
  pure (f a')

-- | `ap` provides a default implementation of `(<*>)` for any
-- | [`Monad`](#monad), without using `(<*>)` as provided by the
-- | [`Apply`](#apply)-[`Monad`](#monad) superclass relationship.
-- |
-- | `ap` can therefore be used to write [`Apply`](#apply) instances as
-- | follows:
-- |
-- | ```purescript
-- | instance applyF :: Apply F where
-- |   apply = ap
-- | ```
ap :: forall m a b. Monad m => m (a -> b) -> m a -> m b
ap f a = do
  f' <- f
  a' <- a
  pure (f' a')

-- | Perform a monadic action when a condition is true, where the conditional
-- | value is also in a monadic context.
whenM :: forall m. Monad m => m Boolean -> m Unit -> m Unit
whenM mb m = do
  b <- mb
  when b m

-- | Perform a monadic action unless a condition is true, where the conditional
-- | value is also in a monadic context.
unlessM :: forall m. Monad m => m Boolean -> m Unit -> m Unit
unlessM mb m =  do
  b <- mb
  unless b m

module Control.Monad
  ( class Monad
  , liftM1
  , ap
  , whenM
  , unlessM
  , module Data.Functor
  , module Control.Apply
  , module Control.Applicative
  , module Control.Bind
  ) where

import Control.Applicative (class Applicative, liftA1, pure, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Bind (class Bind, bind, ifM, join, (<=<), (=<<), (>=>), (>>=))

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit)

-- | The `Monad` type class combines the operations of the `Bind` and
-- | `Applicative` type classes. Therefore, `Monad` instances represent type
-- | constructors which support sequential composition, and also lifting of
-- | functions of arbitrary arity.
-- |
-- | Instances must satisfy the following laws in addition to the
-- | `Applicative` and `Bind` laws:
-- |
-- | - Left Identity: `pure x >>= f = f x`
-- | - Right Identity: `x >>= pure = x`
-- | - Applicative Superclass: `apply = ap`
class (Applicative m, Bind m) <= Monad m

instance monadFn :: Monad ((->) r)
instance monadArray :: Monad Array

-- | `liftM1` provides a default implementation of `(<$>)` for any
-- | [`Monad`](#monad), without using `(<$>)` as provided by the
-- | [`Functor`](#functor)-[`Monad`](#monad) superclass relationship.
-- |
-- | `liftM1` can therefore be used to write [`Functor`](#functor) instances
-- | as follows:
-- |
-- | ```purescript
-- | instance functorF :: Functor F where
-- |   map = liftM1
-- | ```
liftM1 :: forall m a b. Monad m => (a -> b) -> m a -> m b
liftM1 f a = do
  a' <- a
  pure (f a')

-- | `ap` provides a default implementation of `(<*>)` for any
-- | [`Monad`](#monad), without using `(<*>)` as provided by the
-- | [`Apply`](#apply)-[`Monad`](#monad) superclass relationship.
-- |
-- | `ap` can therefore be used to write [`Apply`](#apply) instances as
-- | follows:
-- |
-- | ```purescript
-- | instance applyF :: Apply F where
-- |   apply = ap
-- | ```
ap :: forall m a b. Monad m => m (a -> b) -> m a -> m b
ap f a = do
  f' <- f
  a' <- a
  pure (f' a')

-- | Perform a monadic action when a condition is true, where the conditional
-- | value is also in a monadic context.
whenM :: forall m. Monad m => m Boolean -> m Unit -> m Unit
whenM mb m = do
  b <- mb
  when b m

-- | Perform a monadic action unless a condition is true, where the conditional
-- | value is also in a monadic context.
unlessM :: forall m. Monad m => m Boolean -> m Unit -> m Unit
unlessM mb m =  do
  b <- mb
  unless b m


Different way of displaying View Type selector

module Gauge where

import Prelude
import Control.Bind ((=<<))
import Control.Monad.Eff.Exception
import Data.Maybe
import Data.Monoid
import Data.Functor
import Data.List as L
import Data.Map as Map
import Data.Eq (Eq)
import Data.Foldable (sum)
import Data.List (concatMap)
import Data.Map (Map, alter, fromFoldable, update)

import Pux.Html.Events (onClick)
import Pux.Html as H
import Pux.CSS as CSS
import Pux.Html.Attributes as A
import Pux.Html.Events as E

import React.DOM.Props (onChange)

data ViewType = PerNode | PerBroker | PerNodeAndBroker | Aggregate deriving Eq

data Action = UpdateStats (List NodeStats) | ChangeView ViewType

type TimedVal a = { time::Time, value::a }
type State =
    { viewType:: ViewType
    , stats:: List NodeStats }

-- /todo: Add Node = String | IPAddress
type BStats = Int
type Node = String

type Broker =
    { name :: Node
    , port :: Int }
type BrokerStats =
    { broker ::Broker
    , connections :: BStats}

type NodeStats =
    { node ::  Node
    , brokers:: List BrokerStats}

init :: State
init = { viewType : PerBroker, stats : Nil }

update :: Action -> State -> State
update (UpdateStats us) s = s {stats = us}
update (ChangeView vt) s = s {viewType = vt}

view:: State -> H.Html Action
view {viewType,stats} =
    H.div []
        [ H.h1 [] [numConnectionsView stats]
        , select viewType
        , stats # viewAs viewType ]

numConnectionsView :: (List NodeStats) -> H.Html Action
numConnectionsView stats =
    H.text $ stats # show <<< numConnections

viewAs :: ViewType -> (List NodeStats) -> H.Html Action
viewAs PerNode s =
    H.div []
    s # map \{node,brokers} ->
        let agg = brokers # map _.connections # sum in
        H.div []
            [ H.h1  [] [text $ show node]
            , viewStats agg ]

viewAs PerBroker s =
    let mergeBrokerStats {broker, connections} = addOrInsert broker connections
        statsPerBroker = s # concatMap _.brokers
                            >>> foldl mergeBrokerStats Map.empty
                            >>> Map.toAscUnfoldable
    in
    H.div []
    statsPerBroker
    # map \(Tuple broker agg) ->
         H.div []
            [ H.h1  [] [text $ show broker]
            , viewStats agg]

viewAs PerNodeAndBroker s =
    H.div []
    s # concatMap \{node,brokers} -> brokers # map {node,brokerStats}
    >>> map \{node,brokerStats} ->
        [ H.h1  [] [text $ "Node: " <> node <> " Broker: " <> show brokerStats.broker]
            , viewStats brokerStats.connections]

viewAs Aggregate s =
    let agg = s # numConnections in
    H.div []
        [ H.h1  [] [text "Aggregate Stats"]
        , viewStats agg]

viewStats :: BStats -> H.Html Action
viewStats stats =
    H.div []
        [ H.h2 [] [text "Connections:"]
        , H.p  [] [text $ show stats] ]

select :: ViewType -> H.Html Action
select viewType =
    H.ul []
     (optionView viewType <$> availableViews)

optionView :: ViewType -> ViewType -> H.Html Action
optionView sel v =
    H.li
        if v == sel
        then [CSS.style ""]
        else [E.onClick $ const (ChangeView v)]
        [H.text $ show v]

availableViews :: Array ViewType
availableViews =
   [PerNode, PerBroker, PerNodeAndBroker, Aggregate]

instance viewTypeShow :: Show ViewType where
  show PerNode = "Per Node"
  show PerBroker = "Per Broker"
  show PerNodeAndBroker = "Per Node And Broker"
  show Aggregate = "Aggregate"

numConnections :: List NodeStats -> Int
numConnections =
    concatMap _.brokers
    >>> map _.connections
    >>> sum

upsert :: forall k v. Monoid v => (v -> v) -> k -> Map k v -> Map k v
upsert f = Map.alter (emptyIfNothing >>> f >>> Just)

addOrInsert :: forall k v. Monoid v => v -> k -> Map k v -> Map k v
addOrInsert v = upsert $ (<#>) v

emptyIfNothing :: forall f. Monoid f => Maybe f -> f
emptyIfNothing (Just fa) = fa
emptyIfNothing Nothing = mempty

module Gauge where

import Prelude
import Data.Maybe
import Data.Monoid
import Data.Functor
import Control.Monad.Eff.Exception
import Data.List as L
import Data.Map as Map
import Control.Bind ((=<<))
import Data.Eq (Eq)
import Data.Foldable (sum)
import Data.List (concatMap)
import Data.Map (Map, alter, fromFoldable, update)

import Pux.Html as H
import Pux.Html.Attributes as A
import Pux.Html.Events as E

import React.DOM.Props (onChange)

data ViewType = PerNode | PerBroker | PerNodeAndBroker | Aggregate deriving Eq

data Action = UpdateStats (List NodeStats) | ChangeView ViewType

type TimedVal a = { time::Time, value::a }
type State =
    { viewType:: ViewType
    , stats:: List NodeStats }

-- /todo: Add Node = String | IPAddress
type Node = String
type Broker =
    { name :: Node
    , port :: Int }
type BStats = Int
type BrokerStats =
    { broker ::Broker
    , connections :: BStats}

type NodeStats =
    { node ::  Node
    , brokers:: List BrokerStats}

init :: State
init = { viewType : PerBroker, stats : Nil }

update :: Action -> State -> State
update (UpdateStats us) s = s {stats = us}
update (ChangeView vt) s = s {viewType = vt}

view:: State -> H.Html Action
view {viewType,stats} =
    H.div []
        [ H.h1 [] [numConnectionsView stats]
        , select viewType
        , stats # viewAs viewType ]

numConnectionsView :: (List NodeStats) -> H.Html Action
numConnectionsView stats =
    H.text $ stats # show <<< numConnections

viewAs :: ViewType -> (List NodeStats) -> H.Html Action
viewAs PerNode s =
    H.div []
    s # map \{node,brokers} ->
        let agg = brokers # map _.connections # sum in
        H.div []
            [ H.h1  [] [text $ show node]
            , viewStats agg ]

viewAs PerBroker s =
    let mergeBrokerStats {broker, connections} = addOrInsert broker connections
        statsPerBroker = s # concatMap _.brokers
                            >>> foldl mergeBrokerStats Map.empty
                            >>> Map.toAscUnfoldable
    in
    H.div []
    statsPerBroker
    # map \(Tuple broker agg) ->
         H.div []
            [ H.h1  [] [text $ show broker]
            , viewStats agg]

viewAs PerNodeAndBroker s =
    H.div []
    []

viewAs Aggregate s =
    let agg = s # numConnections in
    H.div []
        [ H.h1  [] [text "Aggregate Stats"]
        , viewStats agg]

viewStats :: BStats -> H.Html Action
viewStats stats =
    H.div []
        [ H.h2 [] [text "Connections:"]
        , H.p  [] [text  stats] ]

select :: ViewType -> H.Html Action
select viewType =
    H.select
     [E.onSelect changeView]
     (optionView <$> availableViews)

optionView :: ViewType -> ViewType -> H.Html Action
optionView v sel =
    let strVal = viewTypeToStr v in
    H.option [A.value strVal, A.selected (v == sel) ] [H.text strVal]

changeView :: E.SelectionEvent -> Action
changeView se =
    ChangeView (toViewType se.target.value)

availableViews :: Array ViewType
availableViews =
   [PerNode, PerBroker, PerNodeAndBroker, Aggregate]

viewTypeToStr:: ViewType -> String
viewTypeToStr = show

toViewType :: String -> ViewType
toViewType "PerNode" = PerNode
toViewType "PerBroker" = PerBroker
toViewType "PerNodeAndBroker" = PerNodeAndBroker
toViewType "Aggregate" = Aggregate
toViewType _ = Aggregate

instance viewTypeShow :: Show ViewType where
  show PerNode = "PerNode"
  show PerBroker = "PerBroker"
  show PerNodeAndBroker = "PerNodeAndBroker"
  show Aggregate = "Aggregate"

numConnections :: List NodeStats -> Int
numConnections =
    concatMap _.brokers
    >>> map _.connections
    >>> sum

-- latestStatsPerBroker :: NodeStats -> List BrokerStats
-- latestStatsPerBroker =
--      _.timedSeries
--         >>> head
--         >>> map _.value
--         >>> emptyIfNothing

-- latestStatsPerBroker :: NodeStats -> List BrokerStats
-- latestStatsPerBroker =
--      _.timedSeries
--         >>> head
--         >>> map _.value
--         >>> emptyIfNothing

upsert :: forall k v. Monoid v => (v -> v) -> k -> Map k v -> Map k v
upsert f = Map.alter (emptyIfNothing >>> f >>> Just)

addOrInsert :: forall k v. Monoid v => v -> k -> Map k v -> Map k v
addOrInsert v = upsert $ (<#>) v

emptyIfNothing :: forall f. Monoid f => Maybe f -> f
emptyIfNothing (Just fa) = fa
emptyIfNothing Nothing = mempty