Fix KeyCombo Ord instance

Fix KeyCombo Ord instance

module Data.KeyCombo
  ( KeyCombo()
  , meta
  , alt
  , shift
  , letter
  , enter
  , combo
  , printKeyComboWin
  , printKeyComboLinux
  , printKeyComboMac
  ) where

import Data.Array (nub, sort, snoc)
import Data.Char (Char(), fromCharCode)
import Data.Foldable (foldl)
import Data.String (charAt, fromChar, joinWith, toUpper)

import qualified Data.String.Unsafe as U

data KeyCombo
  = Meta
  | Alt
  | Shift
  | Letter Char
  | Enter
  | Combo [KeyCombo]

meta :: KeyCombo
meta = Meta

alt :: KeyCombo
alt = Alt

shift :: KeyCombo
shift = Shift

letter :: Char -> KeyCombo
letter = Letter <<< U.charAt 0 <<< toUpper <<< fromChar

enter :: KeyCombo
enter = Enter

combo :: [KeyCombo] -> KeyCombo
combo ks = Combo $ sort $ nub $ foldl snoc [] ks

instance eqKeyCombo :: Eq KeyCombo where
  (==) Meta Meta = true
  (==) Alt Alt = true
  (==) Shift Shift = true
  (==) (Letter x) (Letter y) = x == y
  (==) Enter Enter = true
  (==) (Combo xs) (Combo ys) = xs == ys
  (==) _ _ = false
  (/=) x y = not (x == y)

instance ordKeyCombo :: Ord KeyCombo where
  compare Meta Meta = EQ
  compare Meta _ = LT
  compare _ Meta = GT
  compare Alt Alt = EQ
  compare Alt _ = EQ
  compare _ Alt = GT
  compare Shift Shift = EQ
  compare Shift _ = LT
  compare _ Shift = GT
  compare (Letter x) (Letter y) = compare x y
  compare (Letter _) _ = LT
  compare _ (Letter _) = GT
  compare Enter Enter = EQ
  compare Enter _ = LT
  compare _ Enter = GT
  compare (Combo xs) (Combo ys) = compare xs ys

instance showKeyCombo :: Show KeyCombo where
  show Meta = "Meta"
  show Alt = "Alt"
  show Shift = "Shift"
  show (Letter l) = "Letter (" ++ show l ++ ")"
  show Enter = "Enter"
  show (Combo ks) = "Combo " ++ show ks

instance semigroupKeyCombo :: Semigroup KeyCombo where
  (<>) (Combo xs) (Combo ys) = Combo $ sort $ nub $ xs ++ ys
  (<>) (Combo xs) y = Combo $ sort $ nub $ xs ++ [y]
  (<>) x (Combo ys) = Combo $ sort $ nub $ [x] ++ ys
  (<>) x y | x == y = x
           | otherwise = Combo $ sort [x, y]

printKeyComboWin :: KeyCombo -> String
printKeyComboWin Meta = "Ctrl"
printKeyComboWin Alt = "Alt"
printKeyComboWin Shift = "Shift"
printKeyComboWin (Letter c) = fromChar c
printKeyComboWin Enter = "Enter"
printKeyComboWin (Combo ks) = joinWith "+" (printKeyComboWin <$> ks)

printKeyComboLinux :: KeyCombo -> String
printKeyComboLinux = printKeyComboWin

printKeyComboMac :: KeyCombo -> String
printKeyComboMac Meta = fromChar $ fromCharCode 8984
printKeyComboMac Alt = fromChar $ fromCharCode 8997
printKeyComboMac Shift = fromChar $ fromCharCode 8679
printKeyComboMac (Letter c) = fromChar c
printKeyComboMac Enter = "Enter"
printKeyComboMac (Combo ks) = joinWith "" (printKeyComboMac <$> ks)

module Data.KeyCombo
  ( KeyCombo()
  , meta
  , alt
  , shift
  , letter
  , enter
  , combo
  , printKeyComboWin
  , printKeyComboLinux
  , printKeyComboMac
  ) where

import Data.Array (nub, sort, snoc)
import Data.Char (Char(), fromCharCode)
import Data.Foldable (foldl)
import Data.String (charAt, fromChar, joinWith, toUpper)

import qualified Data.String.Unsafe as U

data KeyCombo
  = Meta
  | Alt
  | Shift
  | Letter Char
  | Enter
  | Combo [KeyCombo]

meta :: KeyCombo
meta = Meta

alt :: KeyCombo
alt = Alt

shift :: KeyCombo
shift = Shift

letter :: Char -> KeyCombo
letter = Letter <<< U.charAt 0 <<< toUpper <<< fromChar

enter :: KeyCombo
enter = Enter

combo :: [KeyCombo] -> KeyCombo
combo ks = Combo $ sort $ nub $ foldl snoc [] ks

instance eqKeyCombo :: Eq KeyCombo where
  (==) Meta Meta = true
  (==) Alt Alt = true
  (==) Shift Shift = true
  (==) (Letter x) (Letter y) = x == y
  (==) Enter Enter = true
  (==) (Combo xs) (Combo ys) = xs == ys
  (==) _ _ = false
  (/=) x y = not (x == y)

instance ordKeyCombo :: Ord KeyCombo where
  compare Meta Meta = EQ
  compare Meta _ = LT
  compare Alt Alt = EQ
  compare Alt _ = EQ
  compare Shift Shift = EQ
  compare Shift _ = LT
  compare (Letter x) (Letter y) = compare x y
  compare (Letter _) _ = LT
  compare Enter Enter = EQ
  compare Enter _ = LT
  compare (Combo xs) (Combo ys) = compare xs ys

instance showKeyCombo :: Show KeyCombo where
  show Meta = "Meta"
  show Alt = "Alt"
  show Shift = "Shift"
  show (Letter l) = "Letter (" ++ show l ++ ")"
  show Enter = "Enter"
  show (Combo ks) = "Combo " ++ show ks

instance semigroupKeyCombo :: Semigroup KeyCombo where
  (<>) (Combo xs) (Combo ys) = Combo $ sort $ nub $ xs ++ ys
  (<>) (Combo xs) y = Combo $ sort $ nub $ xs ++ [y]
  (<>) x (Combo ys) = Combo $ sort $ nub $ [x] ++ ys
  (<>) x y | x == y = x
           | otherwise = Combo $ sort [x, y]

printKeyComboWin :: KeyCombo -> String
printKeyComboWin Meta = "Ctrl"
printKeyComboWin Alt = "Alt"
printKeyComboWin Shift = "Shift"
printKeyComboWin (Letter c) = fromChar c
printKeyComboWin Enter = "Enter"
printKeyComboWin (Combo ks) = joinWith "+" (printKeyComboWin <$> ks)

printKeyComboLinux :: KeyCombo -> String
printKeyComboLinux = printKeyComboWin

printKeyComboMac :: KeyCombo -> String
printKeyComboMac Meta = fromChar $ fromCharCode 8984
printKeyComboMac Alt = fromChar $ fromCharCode 8997
printKeyComboMac Shift = fromChar $ fromCharCode 8679
printKeyComboMac (Letter c) = fromChar c
printKeyComboMac Enter = "Enter"
printKeyComboMac (Combo ks) = joinWith "" (printKeyComboMac <$> ks)


Trim help output

Trim help output

-- |
-- | Docopt utility surface.
-- |
-- | The impure part of docopt, providing conventient entry
-- | points and functions to use docopt.
-- |

module Docopt (
    run
  , parse
  , defaultOptions
  , DocoptEff ()
  , Options (..)
  , Argv ()
  ) where

import Prelude
import Debug.Trace
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, throwException, EXCEPTION())
import Control.Applicative (liftA1)
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested ((/\))
import Data.Foldable (any)
import Data.Either (Either(..), either)
import Control.Monad.Eff (Eff())
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Node.FS (FS())
import Node.Process (PROCESS())
import Node.Process as Process
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Text.Wrap (dedent)
import Data.StrMap (StrMap())
import Data.Array as A
import Data.StrMap (member)
import Data.Bifunctor (lmap, bimap)
import Data.String.Yarn (lines, unlines)
import Data.String (trim) as String

import Language.Docopt (Docopt, parseDocopt, evalDocopt)
import Language.Docopt.Value (Value())
import Language.Docopt as D
import Language.Docopt.Env (Env())

type Argv = Array String
type DocoptEff e = ( process :: PROCESS
                   , err     :: EXCEPTION
                   , console :: CONSOLE
                   , fs      :: FS
                   | e
                   )

liftEffA :: ∀ e a. Eff (DocoptEff e) a -> Aff (DocoptEff e) a
liftEffA = liftEff

-- |
-- | Options for a docopt run
-- |

type ParseOptionsObj r = {
  smartOptions :: Boolean     -- ^ parse singleton groups as opts if possible
  | r
}

type Options r = {
  argv         :: Maybe Argv   -- ^ override argv. Defaults to `process.argv`
, env          :: Maybe Env    -- ^ override env.  Defaults to `process.env`
, optionsFirst :: Boolean      -- ^ enable "option-first"
, dontExit     :: Boolean      -- ^ don't exit the process upon failure
, smartOptions :: Boolean      -- ^ parse singleton groups as opts if possible
, stopAt       :: Array String -- ^ stop parsing at these custom EOA markers
, requireFlags :: Boolean      -- ^ do not ignore missing flags
, laxPlacement :: Boolean      -- ^ allow positionals/commands to be appear anywhere
, version      :: Maybe String -- ^ the version string to display
, versionFlags :: Array String -- ^ list of flags that trigger 'version'
, helpFlags    :: Array String -- ^ list of flags that trigger 'help'
}

defaultOptions :: Options {}
defaultOptions = {
  argv:         Nothing
, env:          Nothing
, optionsFirst: false
, dontExit:     false
, smartOptions: false
, stopAt:       []
, laxPlacement: false
, requireFlags: false
, version:      Nothing
, versionFlags: [ "--version" ]
, helpFlags:    [ "--help"    ]
}

-- |
-- | Parse the docopt specification from the given help text.
-- |
parse :: ∀ e r
       . String
      -> ParseOptionsObj r
      -> Eff (DocoptEff e) Docopt
parse helpText opts = do
  either (throwException <<< error) pure do
    parseDocopt helpText opts

data Action a
  = ShowHelp String
  | ShowVersion
  | Return a

-- |
-- | Run docopt on the given help text.
-- |
-- | This either succeeds with the key/value mappings or fails with a
-- | descriptive help message.
-- |
run :: ∀ e r
     . Either Docopt String
    -> Options r
    -> Eff (DocoptEff e) (StrMap Value)
run input opts = do
  argv <- maybe (A.drop 2 <$> Process.argv) pure opts.argv
  env  <- maybe Process.getEnv              pure opts.env

  action <- runEither do
    { program, specification, shortHelp, help } <- case input of
      (Left spec)   -> pure spec
      (Right help') -> parseDocopt help' opts

    bimap
      (fmtHelp shortHelp)
      case _ of
        output | output `has` opts.helpFlags    -> ShowHelp help
        output | output `has` opts.versionFlags -> ShowVersion
        output                                  -> Return output
      (evalDocopt program specification env argv opts)

  case action of
    Return v      -> pure v
    ShowHelp help -> abort 0 (String.trim help)
    ShowVersion   -> abort 0 =<< String.trim <$> maybe readPkgVersion
                                                       pure
                                                       opts.version

  where
    has x = any (_ `member` x)

    -- note: purescript needs the `a` for now:
    abort :: ∀ a. _ -> _ -> _ _ a
    abort code msg
      = let log = if code == 0 then Console.log else Console.error
        in  do
          log msg
          Process.exit code

    runEither = flip either pure \e ->
      if not opts.dontExit
        then abort 1 e
        else throwException $ error $ e

    readPkgVersion = fromMaybe "" <$> readPkgVersionImpl Just Nothing

    fmtHelp shortHelp errmsg
      = errmsg
      <> "\n"
      <> (dedent $ unlines $ ("  " <> _) <$> lines (dedent shortHelp))

foreign import readPkgVersionImpl
  :: ∀ e
   . (String -> Maybe String)
  -> Maybe String
  -> Eff e (Maybe String)

-- |
-- | Docopt utility surface.
-- |
-- | The impure part of docopt, providing conventient entry
-- | points and functions to use docopt.
-- |

module Docopt (
    run
  , parse
  , defaultOptions
  , DocoptEff ()
  , Options (..)
  , Argv ()
  ) where

import Prelude
import Debug.Trace
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, throwException, EXCEPTION())
import Control.Applicative (liftA1)
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested ((/\))
import Data.Foldable (any)
import Data.Either (Either(..), either)
import Control.Monad.Eff (Eff())
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Node.FS (FS())
import Node.Process (PROCESS())
import Node.Process as Process
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Text.Wrap (dedent)
import Data.StrMap (StrMap())
import Data.Array as A
import Data.StrMap (member)
import Data.Bifunctor (lmap, bimap)
import Data.String.Yarn (lines, unlines)

import Language.Docopt (Docopt, parseDocopt, evalDocopt)
import Language.Docopt.Value (Value())
import Language.Docopt as D
import Language.Docopt.Env (Env())

type Argv = Array String
type DocoptEff e = ( process :: PROCESS
                   , err     :: EXCEPTION
                   , console :: CONSOLE
                   , fs      :: FS
                   | e
                   )

liftEffA :: ∀ e a. Eff (DocoptEff e) a -> Aff (DocoptEff e) a
liftEffA = liftEff

-- |
-- | Options for a docopt run
-- |

type ParseOptionsObj r = {
  smartOptions :: Boolean     -- ^ parse singleton groups as opts if possible
  | r
}

type Options r = {
  argv         :: Maybe Argv   -- ^ override argv. Defaults to `process.argv`
, env          :: Maybe Env    -- ^ override env.  Defaults to `process.env`
, optionsFirst :: Boolean      -- ^ enable "option-first"
, dontExit     :: Boolean      -- ^ don't exit the process upon failure
, smartOptions :: Boolean      -- ^ parse singleton groups as opts if possible
, stopAt       :: Array String -- ^ stop parsing at these custom EOA markers
, requireFlags :: Boolean      -- ^ do not ignore missing flags
, laxPlacement :: Boolean      -- ^ allow positionals/commands to be appear anywhere
, version      :: Maybe String -- ^ the version string to display
, versionFlags :: Array String -- ^ list of flags that trigger 'version'
, helpFlags    :: Array String -- ^ list of flags that trigger 'help'
}

defaultOptions :: Options {}
defaultOptions = {
  argv:         Nothing
, env:          Nothing
, optionsFirst: false
, dontExit:     false
, smartOptions: false
, stopAt:       []
, laxPlacement: false
, requireFlags: false
, version:      Nothing
, versionFlags: [ "--version" ]
, helpFlags:    [ "--help"    ]
}

-- |
-- | Parse the docopt specification from the given help text.
-- |
parse :: ∀ e r
       . String
      -> ParseOptionsObj r
      -> Eff (DocoptEff e) Docopt
parse helpText opts = do
  either (throwException <<< error) pure do
    parseDocopt helpText opts

data Action a
  = ShowHelp String
  | ShowVersion
  | Return a

-- |
-- | Run docopt on the given help text.
-- |
-- | This either succeeds with the key/value mappings or fails with a
-- | descriptive help message.
-- |
run :: ∀ e r
     . Either Docopt String
    -> Options r
    -> Eff (DocoptEff e) (StrMap Value)
run input opts = do
  argv <- maybe (A.drop 2 <$> Process.argv) pure opts.argv
  env  <- maybe Process.getEnv              pure opts.env

  action <- runEither do
    { program, specification, shortHelp, help } <- case input of
      (Left spec)   -> pure spec
      (Right help') -> parseDocopt help' opts

    bimap
      (fmtHelp shortHelp)
      case _ of
        output | output `has` opts.helpFlags    -> ShowHelp help
        output | output `has` opts.versionFlags -> ShowVersion
        output                                  -> Return output
      (evalDocopt program specification env argv opts)

  case action of
    ShowHelp help -> abort 0 help
    ShowVersion   -> abort 0 =<< maybe readPkgVersion pure opts.version
    Return v      -> pure v

  where
    has x = any (_ `member` x)

    -- note: purescript needs the `a` for now:
    abort :: ∀ a. _ -> _ -> _ _ a
    abort code msg
      = let log = if code == 0 then Console.log else Console.error
        in  do
          log msg
          Process.exit code

    runEither = flip either pure \e ->
      if not opts.dontExit
        then abort 1 e
        else throwException $ error $ e

    readPkgVersion = fromMaybe "" <$> readPkgVersionImpl Just Nothing

    fmtHelp shortHelp errmsg
      = errmsg
      <> "\n"
      <> (dedent $ unlines $ ("  " <> _) <$> lines (dedent shortHelp))

foreign import readPkgVersionImpl
  :: ∀ e
   . (String -> Maybe String)
  -> Maybe String
  -> Eff e (Maybe String)


Add Wh for watt-hour, closes #70

Add Wh for watt-hour, closes #70

-- | 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, atto, bit, byte, centi, cup, day, deci, degree,
                   exa, femto, foot, giga, gram, gallon, hecto, hertz, hour,
                   inch, joule, kilo, mega, meter, micro, mile, milli, minute,
                   nano, newton, ounce, peta, pico, pint, pound, radian, second,
                   tera, watt, week, yard, (./), pascal, coulomb, volt, farad,
                   ohm, siemens, weber, tesla, henry, lumen, lux, becquerel,
                   gray, sievert, katal, hectare, liter, tablespoon, teaspoon,
                   tonne, electronvolt, ampere, mole, kelvin, candela, month,
                   year)

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
  [ atto ==> ["atto", "a"]
  , 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'.
  , peta ==> ["peta"]
  , mega ==> ["mega"]
  , pico ==> ["pico", "p"]
  , nano ==> ["nano", "n"]
  , micro ==> [ "micro"
              , "µ" -- Micro sign U+00B5
              , "μ" -- Greek small letter mu U+039C
              ]
  , milli ==> ["milli", "m"]
  , centi ==> ["centi", "c"]
  , deci ==> ["deci", "d"]
  , hecto ==> ["hecto", "h"]
  , kilo ==> ["kilo", "k"]
  , mega ==> ["M"]
  , giga ==> ["giga", "G"]
  , tera ==> ["tera", "T"]
  , peta ==> ["P"]
  , 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
  [ radian ==> ["radians", "radian", "rad"]
  , degree ==> ["degrees", "degree", "deg", "°"]
  , hertz ==> ["hertz", "Hz"]
  , newton ==> ["newton", "N"]
  , joule ==> ["joules", "joule", "J"]
  , pascal ==> ["pascal", "Pa"]
  , volt ==> ["volts", "volt", "V"]
  , farad ==> ["farad", "F"]
  , ohm ==> ["ohms", "ohm", "Ω"]
  , sievert ==> ["sievert", "Sv"]
  , weber ==> ["weber", "Wb"]
  , tesla ==> ["tesla", "T"]
  , henry ==> ["henry", "H"]
  , coulomb ==> ["coulomb", "C"]
  , siemens ==> ["siemens", "S"]
  , lumen ==> ["lumen", "lm"]
  , lux ==> ["lux", "lx"]
  , becquerel ==> ["becquerel", "Bq"]
  , gray ==> ["gray", "Gy"]
  , katal ==> ["katal", "kat"]
  , hectare ==> ["hectare", "ha"]
  , liter ==> ["liters", "liter", "L"]
  , tonne ==> ["tonnes", "tonne", "tons", "ton"]
  , electronvolt ==> ["electronvolt", "eV"]
  , ampere ==> ["amperes", "ampere", "A"]
  , mole ==> ["mole", "mol"]
  , kelvin ==> ["kelvin", "K"]
  , candela ==> ["candela", "cd"]
  , watt <> hour ==> ["Wh"]
  , watt ==> ["watts", "watt", "W"]
  , byte ==> ["Bytes", "bytes", "Byte", "byte", "B"]
  , bit ==> ["bits", "bit"]
  , bit ./ second ==> ["bps"]
  , second ==> ["seconds", "second", "sec", "s"]
  , minute ==> ["minutes", "minute", "min"]
  , hour ==> ["hours", "hour", "h"]
  , day ==> ["days", "day"]
  , week ==> ["weeks", "week"]
  , month ==> ["months", "month"]
  , year ==> ["years", "year"]
  , gram ==> ["grams", "gram", "g"]
  , meter ==> ["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
  [ mile ==> ["miles", "mile"]
  , mile ./ hour ==> ["mph"]
  , inch ==> ["inches", "inch", "in"]
  , yard ==> ["yards", "yard", "yd"]
  , foot ==> ["feet", "foot", "ft"]
  , ounce ==> ["ounces", "ounce", "oz"]
  , pound ==> ["pounds", "pound", "lb"]
  , gallon ==> ["gallons", "gallon", "gal"]
  , pint ==> ["pints", "pint"]
  , cup ==> ["cups", "cup"]
  , tablespoon ==> ["tablespoons", "tablespoon", "tbsp"]
  , 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 day
  -- Similarly, the abbreviation 't' for 'tonne' needs special treatment.
  -- Otherwise, 'ft' will be parsed as 'femto tonne' instead of 'feet'.
  <|> string "t" *> pure 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 "**"
    -- these two need to be parsed as keywords in order to allow for other
    -- operators to follow (e.g. 3²*2)
    sqrOp = reserved "²"
    cubOp = reserved "³"
    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, atto, bit, byte, centi, cup, day, deci, degree,
                   exa, femto, foot, giga, gram, gallon, hecto, hertz, hour,
                   inch, joule, kilo, mega, meter, micro, mile, milli, minute,
                   nano, newton, ounce, peta, pico, pint, pound, radian, second,
                   tera, watt, week, yard, (./), pascal, coulomb, volt, farad,
                   ohm, siemens, weber, tesla, henry, lumen, lux, becquerel,
                   gray, sievert, katal, hectare, liter, tablespoon, teaspoon,
                   tonne, electronvolt, ampere, mole, kelvin, candela, month,
                   year)

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
  [ atto ==> ["atto", "a"]
  , 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'.
  , peta ==> ["peta"]
  , mega ==> ["mega"]
  , pico ==> ["pico", "p"]
  , nano ==> ["nano", "n"]
  , micro ==> [ "micro"
              , "µ" -- Micro sign U+00B5
              , "μ" -- Greek small letter mu U+039C
              ]
  , milli ==> ["milli", "m"]
  , centi ==> ["centi", "c"]
  , deci ==> ["deci", "d"]
  , hecto ==> ["hecto", "h"]
  , kilo ==> ["kilo", "k"]
  , mega ==> ["M"]
  , giga ==> ["giga", "G"]
  , tera ==> ["tera", "T"]
  , peta ==> ["P"]
  , 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
  [ radian ==> ["radians", "radian", "rad"]
  , degree ==> ["degrees", "degree", "deg", "°"]
  , hertz ==> ["hertz", "Hz"]
  , newton ==> ["newton", "N"]
  , joule ==> ["joules", "joule", "J"]
  , pascal ==> ["pascal", "Pa"]
  , volt ==> ["volts", "volt", "V"]
  , farad ==> ["farad", "F"]
  , ohm ==> ["ohms", "ohm", "Ω"]
  , sievert ==> ["sievert", "Sv"]
  , weber ==> ["weber", "Wb"]
  , tesla ==> ["tesla", "T"]
  , henry ==> ["henry", "H"]
  , coulomb ==> ["coulomb", "C"]
  , siemens ==> ["siemens", "S"]
  , lumen ==> ["lumen", "lm"]
  , lux ==> ["lux", "lx"]
  , becquerel ==> ["becquerel", "Bq"]
  , gray ==> ["gray", "Gy"]
  , katal ==> ["katal", "kat"]
  , hectare ==> ["hectare", "ha"]
  , liter ==> ["liters", "liter", "L"]
  , tonne ==> ["tonnes", "tonne", "tons", "ton"]
  , electronvolt ==> ["electronvolt", "eV"]
  , ampere ==> ["amperes", "ampere", "A"]
  , mole ==> ["mole", "mol"]
  , kelvin ==> ["kelvin", "K"]
  , candela ==> ["candela", "cd"]
  , watt ==> ["watts", "watt", "W"]
  , byte ==> ["Bytes", "bytes", "Byte", "byte", "B"]
  , bit ==> ["bits", "bit"]
  , bit ./ second ==> ["bps"]
  , second ==> ["seconds", "second", "sec", "s"]
  , minute ==> ["minutes", "minute", "min"]
  , hour ==> ["hours", "hour", "h"]
  , day ==> ["days", "day"]
  , week ==> ["weeks", "week"]
  , month ==> ["months", "month"]
  , year ==> ["years", "year"]
  , gram ==> ["grams", "gram", "g"]
  , meter ==> ["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
  [ mile ==> ["miles", "mile"]
  , mile ./ hour ==> ["mph"]
  , inch ==> ["inches", "inch", "in"]
  , yard ==> ["yards", "yard", "yd"]
  , foot ==> ["feet", "foot", "ft"]
  , ounce ==> ["ounces", "ounce", "oz"]
  , pound ==> ["pounds", "pound", "lb"]
  , gallon ==> ["gallons", "gallon", "gal"]
  , pint ==> ["pints", "pint"]
  , cup ==> ["cups", "cup"]
  , tablespoon ==> ["tablespoons", "tablespoon", "tbsp"]
  , 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 day
  -- Similarly, the abbreviation 't' for 'tonne' needs special treatment.
  -- Otherwise, 'ft' will be parsed as 'femto tonne' instead of 'feet'.
  <|> string "t" *> pure 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 "**"
    -- these two need to be parsed as keywords in order to allow for other
    -- operators to follow (e.g. 3²*2)
    sqrOp = reserved "²"
    cubOp = reserved "³"
    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


Fixed bug occasionally causing infinite loop in FT

module Test.SlamData.Feature.Interactions where

import SlamData.Prelude

import Data.Argonaut (encodeJson)
import Data.Array as Arr
import Data.Map as Map
import Data.String as Str
import Data.String.Regex as Rgx
import Data.StrMap as SM

import Global (encodeURIComponent)

import Selenium.Monad (get, refresh, getCurrentUrl, tryRepeatedlyTo)

import Test.Feature as Feature
import Test.SlamData.Feature.Monad (SlamFeature, getConfig, waitTime)
import Test.SlamData.Feature.XPaths as XPaths
import Test.Utils (appendToCwd)

import XPath as XPath

import Utils (prettyJson)
import Utils.Array (enumerate)

followingLastPreviousCardGripper :: String -> String
followingLastPreviousCardGripper = XPath.following lastPreviousCardGripperXPath
  where
  lastPreviousCardGripperXPath = XPath.last $ XPath.anywhere XPaths.previousCardGripper

launchSlamData ∷ SlamFeature Unit
launchSlamData = get ∘ _.slamdataUrl =<< getConfig

accessWorkspaceWithModifiedURL ∷ (String → String) → SlamFeature Unit
accessWorkspaceWithModifiedURL modifier =
  getCurrentUrl >>= modifier >>> get

mountTestDatabase ∷ SlamFeature Unit
mountTestDatabase = do
  -- If we don't wait for "Configure database" to appear in the toolbar the
  -- wrong item will be clicked for "Mount database" due to a timing issue. Yay.
  Feature.expectPresented (XPath.anywhere XPaths.accessConfigureMount)
  Feature.click (XPath.anywhere XPaths.accessMountDatabase)
  Feature.provideFieldValue (XPath.anywhere XPaths.mountName) "test-mount"
  Feature.selectFromDropdown (XPath.anywhere XPaths.mountType) "MongoDB"
  Feature.click (XPath.anywhere $ XPaths.mountName)
  Feature.provideFieldValue (XPath.index (XPath.anywhere XPaths.mountPort) 1) "63174"
  Feature.provideFieldValue (XPath.index (XPath.anywhere XPaths.mountHost) 1) "localhost"
  Feature.provideFieldValue (XPath.anywhere XPaths.mountDatabase) "testDb"
  Feature.click (XPath.anywhere XPaths.mountButton)

skipGuide ∷ SlamFeature Unit
skipGuide =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText "Skip"

dismissHint ∷ SlamFeature Unit
dismissHint =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Dismiss"

accessFile ∷ String → SlamFeature Unit
accessFile =
  Feature.click ∘ XPath.anywhere ∘ XPaths.accessFile

exploreFile ∷ String → SlamFeature Unit
exploreFile name = do
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "New workspace name") name
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Explore file"

accessBreadcrumb ∷ String → SlamFeature Unit
accessBreadcrumb = Feature.click ∘ XPath.anywhere ∘ XPaths.accessBreadcrumb

browseRootFolder ∷ SlamFeature Unit
browseRootFolder = do
  Feature.click $ XPath.anywhere XPaths.headerGripper
  Feature.click $ XPath.index (XPath.anywhere XPaths.browseRootFolder) 1

browseTestFolder ∷ SlamFeature Unit
browseTestFolder =
  browseRootFolder *> accessFile "test-mount" *> accessFile "testDb"

createWorkspace ∷ SlamFeature Unit
createWorkspace = Feature.click $ XPath.anywhere XPaths.createWorkspace

nameDeck ∷ String → SlamFeature Unit
nameDeck name = do
  flipDeck
  Feature.click $ XPath.anywhere XPaths.renameDeck
  Feature.provideFieldValue (XPath.anywhere $ XPath.nodeWithExactAriaLabel "input" "Deck name") name
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText "Save"

deleteFile ∷ String → SlamFeature Unit
deleteFile name =
  Feature.click (XPath.anywhere $ XPaths.selectFile name)
    *> Feature.click (XPath.anywhere $ XPaths.removeFile name)
    *> Feature.expectNotPresented (XPath.anywhere $ XPaths.selectFile name)

shareFile ∷ String → SlamFeature Unit
shareFile name = do
  Feature.click (XPath.anywhere $ XPaths.selectFile name)
  tryRepeatedlyTo $ clickShareFile <|> clickShareWorkspace
  where
  clickShareFile =
    Feature.clickNotRepeatedly (XPath.anywhere $ XPaths.shareFile name)
  clickShareWorkspace =
    Feature.clickNotRepeatedly (XPath.anywhere $ XPaths.shareFile $ name <> ".slam")

renameFile ∷ String → String → SlamFeature Unit
renameFile oldName newName = do
  selectFile oldName
  clickMove oldName
  Feature.provideFieldValueWithProperties
    (Map.singleton "value" $ Just oldName)
    (XPath.anywhere "input")
    newName
  Feature.click $ XPath.anywhere XPaths.renameButton
  where
  oldWorkspaceName = oldName <> ".slam"

moveFile ∷ String → String → String → SlamFeature Unit
moveFile fileName oldLocation newLocation = do
  selectFile fileName
  clickMove fileName
  Feature.click $ XPath.anywhere XPaths.selectADestinationFolder
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText newLocation
  Feature.click $ XPath.anywhere XPaths.renameButton

clickMove ∷ String → SlamFeature Unit
clickMove name =
  tryRepeatedlyTo $ clickMoveFile <|> clickMoveWorkspace
  where
  clickMoveFile =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.moveFile name
  clickMoveWorkspace =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.moveFile $ name <> ".slam"

uploadFile ∷ String → SlamFeature Unit
uploadFile =
  Feature.provideFileInputValue (XPath.anywhere $ XPaths.uploadFile)
    <=< appendToCwd

provideFileSearchString ∷ String → SlamFeature Unit
provideFileSearchString value =
  Feature.provideFieldValue (XPath.anywhere XPaths.fileSearchInput) value

selectFile ∷ String → SlamFeature Unit
selectFile name =
  tryRepeatedlyTo (selectFile' <|> selectWorkspace)
  where
  selectFile' =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.selectFile name
  selectWorkspace =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.selectFile $ name <> ".slam"

createWorkspaceInTestFolder ∷ String → SlamFeature Unit
createWorkspaceInTestFolder name = do
  browseTestFolder
  createWorkspace
  nameDeck name
  browseTestFolder
  renameFile "Untitled Workspace" name
  accessFile $ name <> ".slam"

createFolder ∷ SlamFeature Unit
createFolder = Feature.click $ XPath.anywhere XPaths.createFolder

deleteFileInTestFolder ∷ String → SlamFeature Unit
deleteFileInTestFolder name = browseTestFolder *> deleteFile name

reopenCurrentWorkspace ∷ SlamFeature Unit
reopenCurrentWorkspace = waitTime 2000 *> refresh

expandNewCardMenu ∷ SlamFeature Unit
expandNewCardMenu = Feature.click (XPath.anywhere XPaths.insertCard)

accessNextCardInLastDeck ∷ SlamFeature Unit
accessNextCardInLastDeck =
  Feature.dragAndDrop
    (XPath.last $ XPath.anywhere $ XPaths.enabledNextCardGripper)
    (XPath.last $ XPath.anywhere $ XPaths.previousCardGripper)

accessPreviousCardInLastDeck ∷ SlamFeature Unit
accessPreviousCardInLastDeck =
  Feature.dragAndDrop
    (XPath.last $ XPath.anywhere $ XPaths.enabledPreviousCardGripper)
    (XPath.last $ XPath.anywhere $ XPaths.nextCardGripper)

insertSearchCardInLastDeck ∷ SlamFeature Unit
insertSearchCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertSearchCard

insertQueryCardInLastDeck ∷ SlamFeature Unit
insertQueryCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertQueryCard

insertMdCardInLastDeck ∷ SlamFeature Unit
insertMdCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertMdCard

insertOpenCardInLastDeck ∷ SlamFeature Unit
insertOpenCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertOpenCard

insertChartOptionsCardInLastDeck ∷ SlamFeature Unit
insertChartOptionsCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertChartOptionsCard

insertDisplayMarkdownCardInLastDeck ∷ SlamFeature Unit
insertDisplayMarkdownCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertDisplayMarkdownCard

insertTableCardInLastDeck ∷ SlamFeature Unit
insertTableCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertTableCard

insertChartCardInLastDeck ∷ SlamFeature Unit
insertChartCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertChartCard

insertCacheCardInLastDeck ∷ SlamFeature Unit
insertCacheCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertCacheCard

insertVariablesCardInLastDeck ∷ SlamFeature Unit
insertVariablesCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertVariablesCard

insertTroubleshootCardInLastDeck ∷ SlamFeature Unit
insertTroubleshootCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertTroubleshootCard

selectBuildChart ∷ SlamFeature Unit
selectBuildChart =
  Feature.click $ followingLastPreviousCardGripper XPaths.selectBuildChart

insertPivotCard ∷ SlamFeature Unit
insertPivotCard =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertPivotCard

insertBuildBarChartCard ∷ SlamFeature Unit
insertBuildBarChartCard =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertBuildBarChartCard

addColumn ∷ String → SlamFeature Unit
addColumn str = do
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Add column"
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel $ "Select " ⊕ str
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

selectInMillerColumns ∷ Array String → SlamFeature Unit
selectInMillerColumns ps = do
  for_ (enumerate $ Arr.filter (\s → Str.length s > 0) ps) \(ix × path) →
    Feature.click $ resourceXPath (ix + one) path
  where
  ariaLabel ∷ String → String
  ariaLabel rPath = "Select " ⊕ rPath

  resourceXPath ∷ Int → String → String
  resourceXPath ix rPath =
    XPath.last
      $ XPath.anywhere
      $ (XPath.nodeAtPosition ix $ XPath.anyWithExactAriaLabel "Column")
      ⊕ "/"
      ⊕ (XPath.anyWithExactAriaLabel $ ariaLabel rPath)

selectFileForLastOpenCard ∷ String → SlamFeature Unit
selectFileForLastOpenCard s =
  selectInMillerColumns $ Str.split "/" s

selectInChartBuilder ∷ Array String → SlamFeature Unit
selectInChartBuilder ps = do
  selectInMillerColumns ps
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

provideSearchStringInLastSearchCard ∷ String → SlamFeature Unit
provideSearchStringInLastSearchCard =
  Feature.provideFieldValue $ XPath.last $ XPath.anywhere XPaths.searchStringInput

provideMdInLastMdCard ∷ String → SlamFeature Unit
provideMdInLastMdCard =
  Feature.provideFieldValue
    $ XPath.last $ XPath.anywhere XPaths.aceEditor

provideQueryInLastQueryCard ∷ String → SlamFeature Unit
provideQueryInLastQueryCard =
  Feature.provideFieldValue
    $ XPath.last $ XPath.anywhere XPaths.aceEditor

provideSaveDestinationInLastCacheCard ∷ String → SlamFeature Unit
provideSaveDestinationInLastCacheCard =
  Feature.provideFieldValue (XPath.last $ XPath.anywhere XPaths.saveDestinationInput)

doSaveInLastCacheCard ∷ SlamFeature Unit
doSaveInLastCacheCard =
  Feature.click (XPath.last $ XPath.anywhere XPaths.saveSubmitButton)

provideFieldValueInLastDeck ∷ String → String → SlamFeature Unit
provideFieldValueInLastDeck labelText =
  Feature.provideFieldValue
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

checkFieldInLastDeck ∷ String → SlamFeature Unit
checkFieldInLastDeck labelText =
  Feature.check
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

uncheckFieldInLastDeck ∷ String → SlamFeature Unit
uncheckFieldInLastDeck labelText =
  Feature.uncheck
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

pushRadioButtonInLastDeck ∷ String → SlamFeature Unit
pushRadioButtonInLastDeck labelText =
  Feature.pushRadioButton
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

selectFromDropdownInLastDeck ∷ String → String → SlamFeature Unit
selectFromDropdownInLastDeck labelText =
  Feature.selectFromDropdown
    $ followingLastPreviousCardGripper
    $ "select" `XPath.withLabelWithExactText` labelText

accessSharingUrl ∷ SlamFeature Unit
accessSharingUrl = Feature.accessUrlFromFieldValue $ XPath.anywhere XPaths.sharingUrl

accessPublishingUrl ∷ SlamFeature Unit
accessPublishingUrl = Feature.accessUrlFromFieldValue $ XPath.anywhere XPaths.publishingUrl

downloadFileAsCSV ∷ String → SlamFeature Unit
downloadFileAsCSV fileName = do
  selectFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadButton
  Feature.click $ XPath.anywhere $ XPaths.cancelButton

downloadFileAsJSON ∷ String → SlamFeature Unit
downloadFileAsJSON fileName = do
  selectFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadFile fileName
  Feature.click $ XPath.anywhere $ XPath.anyWithText "JSON"
  Feature.click $ XPath.anywhere $ XPaths.downloadButton
  Feature.click $ XPath.anywhere $ XPaths.cancelButton

showHiddenFiles ∷ SlamFeature Unit
showHiddenFiles =
  Feature.click $ XPath.anywhere $ XPaths.showHiddenFiles

hideHiddenFiles ∷ SlamFeature Unit
hideHiddenFiles =
  Feature.click $ XPath.anywhere $ XPaths.hideHiddenFiles

type ApiVarName = String
type ApiVarType = String
type ApiVarValue = String

provideApiVariableBindingsForVariablesCard
  ∷ ApiVarName
  → ApiVarType
  → ApiVarValue
  → SlamFeature Unit
provideApiVariableBindingsForVariablesCard name ty val =
  provideValueForVariablesCard name
  *> provideTypeForVariablesCard name ty
  *> provideDefaultValueForVariablesCard name val
  where
  provideValueForVariablesCard ∷ String → SlamFeature Unit
  provideValueForVariablesCard name = do
    Feature.provideFieldValue
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardVariableName)
      name
    Feature.pressEnter
  provideTypeForVariablesCard ∷ String → String → SlamFeature Unit
  provideTypeForVariablesCard name ty = do
    Feature.selectFromDropdown
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardVariableTypeFor name)
      ty
    Feature.pressEnter

  provideDefaultValueForVariablesCard ∷ String → String → SlamFeature Unit
  provideDefaultValueForVariablesCard name val = do
    Feature.provideFieldValue
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardDefaultValueFor name)
      val
    Feature.pressEnter

activateCategoryForChartBuilder ∷ SlamFeature Unit
activateCategoryForChartBuilder =
  Feature.click $ XPath.last $ XPath.anywhere $ XPaths.chartCategorySelector

activateStackForChartBuilder ∷ SlamFeature Unit
activateStackForChartBuilder =
  Feature.click $ XPath.last $ XPath.anywhere $ XPaths.chartStackSelector

flipDeck ∷ SlamFeature Unit
flipDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Flip deck"

trashActiveOrLastCard ∷ SlamFeature Unit
trashActiveOrLastCard =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Delete card"

shareDeck ∷ SlamFeature Unit
shareDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Share deck"

publishDeck ∷ SlamFeature Unit
publishDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Publish deck"

filterDeckAndCardActions ∷ String → SlamFeature Unit
filterDeckAndCardActions =
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "Filter deck and card actions")

filterNextActions ∷ String → SlamFeature Unit
filterNextActions =
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "Filter next actions")

confirmDeckAction ∷ SlamFeature Unit
confirmDeckAction =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

runQuery ∷ SlamFeature Unit
runQuery =
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Run query"

setVarMapForCurrentDeck ∷ SM.StrMap String → SlamFeature Unit
setVarMapForCurrentDeck vm = accessWorkspaceWithModifiedURL \urlStr →
  let
    deckIdRgx = unsafePartial fromRight $ Rgx.regex "\\.slam\\/([^\\/]+)" Rgx.noFlags
    mbDeckId = join $ Rgx.match deckIdRgx urlStr >>= flip Arr.index 1
  in case mbDeckId of
    Nothing → urlStr
    Just did →
      let
        varsValue =
          encodeURIComponent
          $ prettyJson
          $ encodeJson
          $ SM.singleton did vm
      in
       urlStr ⊕ "/?vars=" ⊕ varsValue

module Test.SlamData.Feature.Interactions where

import SlamData.Prelude

import Data.Argonaut (encodeJson)
import Data.Array as Arr
import Data.Map as Map
import Data.String as Str
import Data.String.Regex as Rgx
import Data.StrMap as SM

import Global (encodeURIComponent)

import Selenium.Monad (get, refresh, getCurrentUrl, tryRepeatedlyTo)

import Test.Feature as Feature
import Test.SlamData.Feature.Expectations as Expect
import Test.SlamData.Feature.Monad (SlamFeature, getConfig, waitTime)
import Test.SlamData.Feature.XPaths as XPaths
import Test.Utils (appendToCwd)

import XPath as XPath

import Utils (prettyJson)
import Utils.Array (enumerate)

followingLastPreviousCardGripper :: String -> String
followingLastPreviousCardGripper = XPath.following lastPreviousCardGripperXPath
  where
  lastPreviousCardGripperXPath = XPath.last $ XPath.anywhere XPaths.previousCardGripper

launchSlamData ∷ SlamFeature Unit
launchSlamData = get ∘ _.slamdataUrl =<< getConfig

accessWorkspaceWithModifiedURL ∷ (String → String) → SlamFeature Unit
accessWorkspaceWithModifiedURL modifier =
  getCurrentUrl >>= modifier >>> get

mountTestDatabase ∷ SlamFeature Unit
mountTestDatabase = do
  -- If we don't wait for "Configure database" to appear in the toolbar the
  -- wrong item will be clicked for "Mount database" due to a timing issue. Yay.
  Feature.expectPresented (XPath.anywhere XPaths.accessConfigureMount)
  Feature.click (XPath.anywhere XPaths.accessMountDatabase)
  Feature.provideFieldValue (XPath.anywhere XPaths.mountName) "test-mount"
  Feature.selectFromDropdown (XPath.anywhere XPaths.mountType) "MongoDB"
  Feature.click (XPath.anywhere $ XPaths.mountName)
  Feature.provideFieldValue (XPath.index (XPath.anywhere XPaths.mountPort) 1) "63174"
  Feature.provideFieldValue (XPath.index (XPath.anywhere XPaths.mountHost) 1) "localhost"
  Feature.provideFieldValue (XPath.anywhere XPaths.mountDatabase) "testDb"
  Feature.click (XPath.anywhere XPaths.mountButton)

skipGuide ∷ SlamFeature Unit
skipGuide =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText "Skip"

dismissHint ∷ SlamFeature Unit
dismissHint =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Dismiss"

accessFile ∷ String → SlamFeature Unit
accessFile =
  Feature.click ∘ XPath.anywhere ∘ XPaths.accessFile

exploreFile ∷ String → SlamFeature Unit
exploreFile name = do
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "New workspace name") name
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Explore file"

accessBreadcrumb ∷ String → SlamFeature Unit
accessBreadcrumb = Feature.click ∘ XPath.anywhere ∘ XPaths.accessBreadcrumb

browseRootFolder ∷ SlamFeature Unit
browseRootFolder =
  tryRepeatedlyTo do
    ((Feature.clickNotRepeatedly $ XPath.anywhere XPaths.headerGripper)
     <|>
     (Feature.clickNotRepeatedly $ XPath.index (XPath.anywhere XPaths.browseRootFolder) 1))
    Expect.fileNotRepeatedly "test-mount"

browseTestFolder ∷ SlamFeature Unit
browseTestFolder =
  browseRootFolder *> accessFile "test-mount" *> accessFile "testDb"

createWorkspace ∷ SlamFeature Unit
createWorkspace = Feature.click $ XPath.anywhere XPaths.createWorkspace

nameDeck ∷ String → SlamFeature Unit
nameDeck name = do
  flipDeck
  Feature.click $ XPath.anywhere XPaths.renameDeck
  Feature.provideFieldValue (XPath.anywhere $ XPath.nodeWithExactAriaLabel "input" "Deck name") name
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText "Save"

deleteFile ∷ String → SlamFeature Unit
deleteFile name =
  Feature.click (XPath.anywhere $ XPaths.selectFile name)
    *> Feature.click (XPath.anywhere $ XPaths.removeFile name)
    *> Feature.expectNotPresented (XPath.anywhere $ XPaths.selectFile name)

shareFile ∷ String → SlamFeature Unit
shareFile name = do
  Feature.click (XPath.anywhere $ XPaths.selectFile name)
  tryRepeatedlyTo $ clickShareFile <|> clickShareWorkspace
  where
  clickShareFile =
    Feature.clickNotRepeatedly (XPath.anywhere $ XPaths.shareFile name)
  clickShareWorkspace =
    Feature.clickNotRepeatedly (XPath.anywhere $ XPaths.shareFile $ name <> ".slam")

renameFile ∷ String → String → SlamFeature Unit
renameFile oldName newName = do
  selectFile oldName
  clickMove oldName
  Feature.provideFieldValueWithProperties
    (Map.singleton "value" $ Just oldName)
    (XPath.anywhere "input")
    newName
  Feature.click $ XPath.anywhere XPaths.renameButton
  where
  oldWorkspaceName = oldName <> ".slam"

moveFile ∷ String → String → String → SlamFeature Unit
moveFile fileName oldLocation newLocation = do
  selectFile fileName
  clickMove fileName
  Feature.click $ XPath.anywhere XPaths.selectADestinationFolder
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText newLocation
  Feature.click $ XPath.anywhere XPaths.renameButton

clickMove ∷ String → SlamFeature Unit
clickMove name =
  tryRepeatedlyTo $ clickMoveFile <|> clickMoveWorkspace
  where
  clickMoveFile =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.moveFile name
  clickMoveWorkspace =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.moveFile $ name <> ".slam"

uploadFile ∷ String → SlamFeature Unit
uploadFile =
  Feature.provideFileInputValue (XPath.anywhere $ XPaths.uploadFile)
    <=< appendToCwd

provideFileSearchString ∷ String → SlamFeature Unit
provideFileSearchString value =
  Feature.provideFieldValue (XPath.anywhere XPaths.fileSearchInput) value

selectFile ∷ String → SlamFeature Unit
selectFile name =
  tryRepeatedlyTo (selectFile' <|> selectWorkspace)
  where
  selectFile' =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.selectFile name
  selectWorkspace =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.selectFile $ name <> ".slam"

createWorkspaceInTestFolder ∷ String → SlamFeature Unit
createWorkspaceInTestFolder name = do
  browseTestFolder
  createWorkspace
  nameDeck name
  browseTestFolder
  renameFile "Untitled Workspace" name
  accessFile $ name <> ".slam"

createFolder ∷ SlamFeature Unit
createFolder = Feature.click $ XPath.anywhere XPaths.createFolder

deleteFileInTestFolder ∷ String → SlamFeature Unit
deleteFileInTestFolder name = browseTestFolder *> deleteFile name

reopenCurrentWorkspace ∷ SlamFeature Unit
reopenCurrentWorkspace = waitTime 2000 *> refresh

expandNewCardMenu ∷ SlamFeature Unit
expandNewCardMenu = Feature.click (XPath.anywhere XPaths.insertCard)

accessNextCardInLastDeck ∷ SlamFeature Unit
accessNextCardInLastDeck =
  Feature.dragAndDrop
    (XPath.last $ XPath.anywhere $ XPaths.enabledNextCardGripper)
    (XPath.last $ XPath.anywhere $ XPaths.previousCardGripper)

accessPreviousCardInLastDeck ∷ SlamFeature Unit
accessPreviousCardInLastDeck =
  Feature.dragAndDrop
    (XPath.last $ XPath.anywhere $ XPaths.enabledPreviousCardGripper)
    (XPath.last $ XPath.anywhere $ XPaths.nextCardGripper)

insertSearchCardInLastDeck ∷ SlamFeature Unit
insertSearchCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertSearchCard

insertQueryCardInLastDeck ∷ SlamFeature Unit
insertQueryCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertQueryCard

insertMdCardInLastDeck ∷ SlamFeature Unit
insertMdCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertMdCard

insertOpenCardInLastDeck ∷ SlamFeature Unit
insertOpenCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertOpenCard

insertChartOptionsCardInLastDeck ∷ SlamFeature Unit
insertChartOptionsCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertChartOptionsCard

insertDisplayMarkdownCardInLastDeck ∷ SlamFeature Unit
insertDisplayMarkdownCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertDisplayMarkdownCard

insertTableCardInLastDeck ∷ SlamFeature Unit
insertTableCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertTableCard

insertChartCardInLastDeck ∷ SlamFeature Unit
insertChartCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertChartCard

insertCacheCardInLastDeck ∷ SlamFeature Unit
insertCacheCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertCacheCard

insertVariablesCardInLastDeck ∷ SlamFeature Unit
insertVariablesCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertVariablesCard

insertTroubleshootCardInLastDeck ∷ SlamFeature Unit
insertTroubleshootCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertTroubleshootCard

selectBuildChart ∷ SlamFeature Unit
selectBuildChart =
  Feature.click $ followingLastPreviousCardGripper XPaths.selectBuildChart

insertPivotCard ∷ SlamFeature Unit
insertPivotCard =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertPivotCard

insertBuildBarChartCard ∷ SlamFeature Unit
insertBuildBarChartCard =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertBuildBarChartCard

addColumn ∷ String → SlamFeature Unit
addColumn str = do
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Add column"
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel $ "Select " ⊕ str
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

selectInMillerColumns ∷ Array String → SlamFeature Unit
selectInMillerColumns ps = do
  for_ (enumerate $ Arr.filter (\s → Str.length s > 0) ps) \(ix × path) →
    Feature.click $ resourceXPath (ix + one) path
  where
  ariaLabel ∷ String → String
  ariaLabel rPath = "Select " ⊕ rPath

  resourceXPath ∷ Int → String → String
  resourceXPath ix rPath =
    XPath.last
      $ XPath.anywhere
      $ (XPath.nodeAtPosition ix $ XPath.anyWithExactAriaLabel "Column")
      ⊕ "/"
      ⊕ (XPath.anyWithExactAriaLabel $ ariaLabel rPath)

selectFileForLastOpenCard ∷ String → SlamFeature Unit
selectFileForLastOpenCard s =
  selectInMillerColumns $ Str.split "/" s

selectInChartBuilder ∷ Array String → SlamFeature Unit
selectInChartBuilder ps = do
  selectInMillerColumns ps
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

provideSearchStringInLastSearchCard ∷ String → SlamFeature Unit
provideSearchStringInLastSearchCard =
  Feature.provideFieldValue $ XPath.last $ XPath.anywhere XPaths.searchStringInput

provideMdInLastMdCard ∷ String → SlamFeature Unit
provideMdInLastMdCard =
  Feature.provideFieldValue
    $ XPath.last $ XPath.anywhere XPaths.aceEditor

provideQueryInLastQueryCard ∷ String → SlamFeature Unit
provideQueryInLastQueryCard =
  Feature.provideFieldValue
    $ XPath.last $ XPath.anywhere XPaths.aceEditor

provideSaveDestinationInLastCacheCard ∷ String → SlamFeature Unit
provideSaveDestinationInLastCacheCard =
  Feature.provideFieldValue (XPath.last $ XPath.anywhere XPaths.saveDestinationInput)

doSaveInLastCacheCard ∷ SlamFeature Unit
doSaveInLastCacheCard =
  Feature.click (XPath.last $ XPath.anywhere XPaths.saveSubmitButton)

provideFieldValueInLastDeck ∷ String → String → SlamFeature Unit
provideFieldValueInLastDeck labelText =
  Feature.provideFieldValue
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

checkFieldInLastDeck ∷ String → SlamFeature Unit
checkFieldInLastDeck labelText =
  Feature.check
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

uncheckFieldInLastDeck ∷ String → SlamFeature Unit
uncheckFieldInLastDeck labelText =
  Feature.uncheck
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

pushRadioButtonInLastDeck ∷ String → SlamFeature Unit
pushRadioButtonInLastDeck labelText =
  Feature.pushRadioButton
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

selectFromDropdownInLastDeck ∷ String → String → SlamFeature Unit
selectFromDropdownInLastDeck labelText =
  Feature.selectFromDropdown
    $ followingLastPreviousCardGripper
    $ "select" `XPath.withLabelWithExactText` labelText

accessSharingUrl ∷ SlamFeature Unit
accessSharingUrl = Feature.accessUrlFromFieldValue $ XPath.anywhere XPaths.sharingUrl

accessPublishingUrl ∷ SlamFeature Unit
accessPublishingUrl = Feature.accessUrlFromFieldValue $ XPath.anywhere XPaths.publishingUrl

downloadFileAsCSV ∷ String → SlamFeature Unit
downloadFileAsCSV fileName = do
  selectFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadButton
  Feature.click $ XPath.anywhere $ XPaths.cancelButton

downloadFileAsJSON ∷ String → SlamFeature Unit
downloadFileAsJSON fileName = do
  selectFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadFile fileName
  Feature.click $ XPath.anywhere $ XPath.anyWithText "JSON"
  Feature.click $ XPath.anywhere $ XPaths.downloadButton
  Feature.click $ XPath.anywhere $ XPaths.cancelButton

showHiddenFiles ∷ SlamFeature Unit
showHiddenFiles =
  Feature.click $ XPath.anywhere $ XPaths.showHiddenFiles

hideHiddenFiles ∷ SlamFeature Unit
hideHiddenFiles =
  Feature.click $ XPath.anywhere $ XPaths.hideHiddenFiles

type ApiVarName = String
type ApiVarType = String
type ApiVarValue = String

provideApiVariableBindingsForVariablesCard
  ∷ ApiVarName
  → ApiVarType
  → ApiVarValue
  → SlamFeature Unit
provideApiVariableBindingsForVariablesCard name ty val =
  provideValueForVariablesCard name
  *> provideTypeForVariablesCard name ty
  *> provideDefaultValueForVariablesCard name val
  where
  provideValueForVariablesCard ∷ String → SlamFeature Unit
  provideValueForVariablesCard name = do
    Feature.provideFieldValue
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardVariableName)
      name
    Feature.pressEnter
  provideTypeForVariablesCard ∷ String → String → SlamFeature Unit
  provideTypeForVariablesCard name ty = do
    Feature.selectFromDropdown
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardVariableTypeFor name)
      ty
    Feature.pressEnter

  provideDefaultValueForVariablesCard ∷ String → String → SlamFeature Unit
  provideDefaultValueForVariablesCard name val = do
    Feature.provideFieldValue
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardDefaultValueFor name)
      val
    Feature.pressEnter

activateCategoryForChartBuilder ∷ SlamFeature Unit
activateCategoryForChartBuilder =
  Feature.click $ XPath.last $ XPath.anywhere $ XPaths.chartCategorySelector

activateStackForChartBuilder ∷ SlamFeature Unit
activateStackForChartBuilder =
  Feature.click $ XPath.last $ XPath.anywhere $ XPaths.chartStackSelector

flipDeck ∷ SlamFeature Unit
flipDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Flip deck"

trashActiveOrLastCard ∷ SlamFeature Unit
trashActiveOrLastCard =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Delete card"

shareDeck ∷ SlamFeature Unit
shareDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Share deck"

publishDeck ∷ SlamFeature Unit
publishDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Publish deck"

filterDeckAndCardActions ∷ String → SlamFeature Unit
filterDeckAndCardActions =
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "Filter deck and card actions")

filterNextActions ∷ String → SlamFeature Unit
filterNextActions =
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "Filter next actions")

confirmDeckAction ∷ SlamFeature Unit
confirmDeckAction =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

runQuery ∷ SlamFeature Unit
runQuery =
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Run query"

setVarMapForCurrentDeck ∷ SM.StrMap String → SlamFeature Unit
setVarMapForCurrentDeck vm = accessWorkspaceWithModifiedURL \urlStr →
  let
    deckIdRgx = unsafePartial fromRight $ Rgx.regex "\\.slam\\/([^\\/]+)" Rgx.noFlags
    mbDeckId = join $ Rgx.match deckIdRgx urlStr >>= flip Arr.index 1
  in case mbDeckId of
    Nothing → urlStr
    Just did →
      let
        varsValue =
          encodeURIComponent
          $ prettyJson
          $ encodeJson
          $ SM.singleton did vm
      in
       urlStr ⊕ "/?vars=" ⊕ varsValue


Parse UserCredentials with generics

Parse UserCredentials with generics

Achievement unlocked ;-). This should make wrapping more of the API less
of a hassle. Also see http://www.purescript.org/learn/generic/ for
support of null values (may be more readable than manual parsing of
tweets - although that could be performance sensitive).

Process for parsing now looks like:
- fetch some data with a spike in javascript
- copy js object from console,
- assign that object in Purescript
- let compiler tell us the types, copy-paste
- jsonify the object (or copy json directly from firebase if it is a
  type from the db) and write a test to ensure parsing works as expected.

module Test.AuthDataSpec (authDataSpec) where

import Prelude
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Test.Spec (describe, it, pending, Spec())
import Test.Spec.Assertions (shouldEqual)
import Data.Foreign
import Data.Foreign.Generic
import Data.Foreign.Class
import Data.Either
import Data.Maybe
import Data.Generic

-- convert authdata (from twitter to start with) to a purescript authdata record
-- sample data at https://boiling-heat-7831.firebaseapp.com/authspike.html
newtype UserCredentials = UserCredentials {
          provider :: String
          , uid :: String
          , token :: String
          , expires :: Int
          }

-- ProviderUserProfile = TwitterProfile TwitterProfileRecord | GoogleProfile GoogleProfileRecord | etc

data AuthenticationStatus = LoggedOut | LoggedIn UserCredentials -- | LoggedIn UserCredentials ProviderUserProfile

derive instance genericUserCredentials :: Generic UserCredentials

instance showUserCredentials :: Show UserCredentials where
  show = gShow

instance eqUserCredentials :: Eq UserCredentials where
  eq = gEq

jsonOptions :: Options
jsonOptions = defaultOptions { unwrapNewtypes = true }

instance isForeignUserCredentials :: IsForeign UserCredentials where
  read = readGeneric jsonOptions

derive instance authenticationStatusIsGeneric :: Generic AuthenticationStatus

instance authenticationShow :: Show AuthenticationStatus where
  show = gShow

instance authenticationeq :: Eq AuthenticationStatus where
  eq = gEq

instance authenticationStatusIsForeign :: IsForeign AuthenticationStatus where
  read value | isNull value  = return LoggedOut
  read value = do
    credentials <- read value
    return $ LoggedIn credentials -- (UserCredentials {provider, uid, token, auth, expires })

authDataSpec :: forall eff. Spec (eff) Unit
authDataSpec = do

  describe "Authentication status" do
   it "parses null to LoggedOut" do
      let nullStatus = readJSON "null" :: Either ForeignError AuthenticationStatus
      case nullStatus of
        Left e -> throwError $ error $ show e
        Right s -> s `shouldEqual` LoggedOut
   it "parses a record to LoggedIn" do
      let nullStatus = readJSON twitterLoggedInJson :: Either ForeignError AuthenticationStatus
      case nullStatus of
        Left e -> throwError $ error $ show e
        Right s -> s `shouldEqual` (LoggedIn record)

-- approximation. The empty objects have a lot of provider specific data in them
-- e.g. the 'twitter' field has user profile picture etc. different for google etc.
-- so watch out when building a parser for that part.
twitterLoggedInJson :: String
twitterLoggedInJson = """{ "provider": "twitter", "uid": "twitter:16594263", "twitter": {}, "token": "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ…", "auth": {}, "expires": 1454431083 }"""

record :: UserCredentials
record = UserCredentials { provider: "twitter", uid: "twitter:16594263", token: "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ…", expires: 1454431083 }

-- twitter has: displayName: "Willem van den Ende, id: 165 etc, username: mostalive, profileImageUrl
-- and accessToken and accessTokenSecret. not sure if we need those.
-- auth has : {provider: "twitter", uid : "twitter:16etc"}

module Test.AuthDataSpec (authDataSpec) where

import Prelude
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Test.Spec (describe, it, pending, Spec())
import Test.Spec.Assertions (shouldEqual)
import Data.Foreign
import Data.Foreign.Class
import Data.Either
import Data.Maybe
import Data.Generic

type TweetSpec = forall eff. Spec (eff) Unit
-- convert authdata (from twitter to start with) to a purescript authdata record
-- sample data at https://boiling-heat-7831.firebaseapp.com/authspike.html
newtype UserCredentials = UserCredentials {
          provider :: String
          , uid :: String
          , token :: String
          , auth :: {}
          , expires :: Int
          }

record :: UserCredentials
record = UserCredentials { provider: "twitter", uid: "twitter:16594263", token: "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ…", auth: {}, expires: 1454431083 }

-- twitter has: displayName: "Willem van den Ende, id: 165 etc, username: mostalive, profileImageUrl
-- and accessToken and accessTokenSecret. not sure if we need those.
-- auth has : {provider: "twitter", uid : "twitter:16etc"}

-- ProviderUserProfile = TwitterProfile TwitterProfileRecord | GoogleProfile GoogleProfileRecord | etc

data AuthenticationStatus = LoggedOut | LoggedIn UserCredentials -- | LoggedIn UserCredentials ProviderUserProfile

derive instance genericUserCredentials :: Generic UserCredentials

instance showUserCredentials :: Show UserCredentials where
  show = gShow

instance eqUserCredentials :: Eq UserCredentials where
  eq = gEq

derive instance authenticationStatusIsGeneric :: Generic AuthenticationStatus

instance authenticationShow :: Show AuthenticationStatus where
  show = gShow

instance authenticationeq :: Eq AuthenticationStatus where
  eq = gEq

instance authenticationStatusIsForeign :: IsForeign AuthenticationStatus where
  read value | isNull value  = return LoggedOut
  read value = do
    provider <- readProp "provider" value
    uid <- readProp "uid" value
    token <- readProp "token" value
    expires <- readProp "expires" value
    let auth = {}
    return $ LoggedIn (UserCredentials {provider, uid, token, auth, expires })

authDataSpec :: TweetSpec
authDataSpec = do

  describe "Authentication status" do
   it "parses null to LoggedOut" do
      let nullStatus = readJSON "null" :: Either ForeignError AuthenticationStatus
      case nullStatus of
        Left e -> throwError $ error $ show e
        Right s -> s `shouldEqual` LoggedOut
   it "parses a record to LoggedIn" do
      let nullStatus = readJSON twitterLoggedInJson :: Either ForeignError AuthenticationStatus
      case nullStatus of
        Left e -> throwError $ error $ show e
        Right s -> s `shouldEqual` (LoggedIn record)

-- approximation. The empty objects have a lot of provider specific data in them
-- e.g. the 'twitter' field has user profile picture etc. different for google etc.
-- so watch out when building a parser for that part.
twitterLoggedInJson = """{ "provider": "twitter", "uid": "twitter:16594263", "twitter": {}, "token": "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ…", "auth": {}, "expires": 1454431083 }"""