Use simple transform to speed up reference parsing

module Language.Docopt.SpecParser.Lexer where

import Prelude
import Data.Array as A
import Debug.Trace
import Debug.Profile
import Data.List as L
import Data.Monoid (mempty)
import Data.Functor (($>))
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (State, evalState)
import Control.MonadPlus (guard)
import Data.Either (Either(..), fromRight)
import Data.Identity (Identity())
import Data.Foldable (foldMap)
import Data.List (List(..), many, catMaybes, toUnfoldable, (:), some)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.String (fromCharArray, trim)
import Data.String (singleton) as String
import Data.String.Regex (Regex(), regex)
import Data.String.Regex (parseFlags, replace) as Regex
import Partial.Unsafe (unsafePartial)
import Data.String.Ext ((^=))
import Language.Docopt.SpecParser.Base (lowerAlphaNum, alphaNum, alpha, space,
                                        lowerAlpha, upperAlpha, string',
                                        getPosition, getInput, spaces, eol)
import Language.Docopt.SpecParser.State (ParserState)
import Text.Parsing.Parser (ParseError, Parser, PState(..), ParserT(..),
                            runParserT, parseFailed, fail, runParser) as P
import Text.Parsing.Parser.Combinators ((<?>), notFollowedBy, try, choice,
                                        lookAhead, optional, between, manyTill
                                        ) as P
import Text.Parsing.Parser.Pos (Position, initialPos) as P
import Text.Parsing.Parser.String (skipSpaces, anyChar, string, char, oneOf,
                                  whiteSpace, eof, noneOf, satisfy) as P

-- | Optimal: Faster P.skipSpaces since it does not accumulate into a list.
skipSpaces = go
  where
    go = (do
      P.satisfy \c -> c == '\n' || c == '\r' || c == ' ' || c == '\t'
      go
    ) <|> pure unit

-- | Optimal: Translate [[<anything>-]options] to @anything
-- | this saves us looking ahead repeatedly when parsing '['.
referenceRegex :: Regex
referenceRegex
  = unsafePartial $ fromRight $
      regex
        "\\[(([^\\]](?!\\s*-?\\s*options\\s*))*?.?)\\s*-?\\s*options\\s*\\]"
        (Regex.parseFlags "gmi")

data Mode = Usage | Descriptions

isDescMode :: Mode -> Boolean
isDescMode Descriptions = true
isDescMode _            = false

isUsageMode :: Mode -> Boolean
isUsageMode Usage = true
isUsageMode _     = false

lex :: Mode -> String -> Either P.ParseError (List PositionedToken)
lex m input = do
  -- perform a simple transformation to avoid 'manyTill' and safe some millis
  -- lexing. Hopefully this won't be necessary when purescript-parsing improves
  -- performance, a faster parsing library shows up or the purescript compiler
  -- improves in performance.
  let
    input' = if isUsageMode m
                then Regex.replace referenceRegex "@$1" input
                else input

  profileA "lex spec" \_->
    P.runParser input' (parseTokens m)

lexDescs :: String -> Either P.ParseError (List PositionedToken)
lexDescs = lex Descriptions

lexUsage :: String -> Either P.ParseError (List PositionedToken)
lexUsage = lex Usage

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | Dash
  | VBar
  | Colon
  | Comma
  | Newline
  | TripleDot
  | Reference String
  | LOpt String (Maybe { name :: String, optional :: Boolean })
  | SOpt Char (Array Char) (Maybe { name :: String, optional :: Boolean })
  | Tag String (Maybe String)
  | Name String
  | ShoutName String
  | AngleName String
  | Garbage Char
  | DoubleDash

prettyPrintToken :: Token -> String
prettyPrintToken LParen        = show '('
prettyPrintToken RParen        = show ')'
prettyPrintToken LSquare       = show '['
prettyPrintToken RSquare       = show ']'
prettyPrintToken Dash          = show '-'
prettyPrintToken VBar          = show '|'
prettyPrintToken Newline       = show '\n'
prettyPrintToken Colon         = show ':'
prettyPrintToken Comma         = show ','
prettyPrintToken TripleDot     = "..."
prettyPrintToken DoubleDash    = "--"
prettyPrintToken (Reference r) = "Reference " <> show r
prettyPrintToken (Garbage   c) = "Garbage "   <> show c
prettyPrintToken (Tag k v)     = "Tag "       <> k <> " "  <> (show v)
prettyPrintToken (Name      n) = "Name "      <> show n
prettyPrintToken (ShoutName n) = "ShoutName " <> show n
prettyPrintToken (AngleName n) = "AngleName " <> show n
prettyPrintToken (LOpt n arg)
  = "--" <> n
         <> (fromMaybe "" do
              a <- arg
              pure $ if a.optional then "[" else ""
                <> a.name
                <> if a.optional then "]" else ""
            )
prettyPrintToken (SOpt n s arg)
  = "-" <> (fromCharArray (A.cons n s))
        <> (fromMaybe "" do
              a <- arg
              pure $ if a.optional then "[" else ""
                <> a.name
                <> if a.optional then "]" else ""
            )

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance eqToken :: Eq Token where
  eq LParen            LParen             = true
  eq RParen            RParen             = true
  eq LSquare           LSquare            = true
  eq RSquare           RSquare            = true
  eq VBar              VBar               = true
  eq Colon             Colon              = true
  eq Comma             Comma              = true
  eq Dash              Dash               = true
  eq DoubleDash        DoubleDash         = true
  eq TripleDot         TripleDot          = true
  eq Newline           Newline            = true
  eq (Reference r)     (Reference r')     = r == r'
  eq (LOpt n arg)      (LOpt n' arg')
    = (n == n')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              pure $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (SOpt n s arg)    (SOpt n' s' arg')
    = (n == n') && (s' == s')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              pure $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (AngleName n)     (AngleName n')     = n == n'
  eq (ShoutName n)     (ShoutName n')     = n == n'
  eq (Name n)          (Name n')          = n == n'
  eq (Garbage c)       (Garbage c')       = c == c'
  eq _ _                                  = false

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos: pos, token: tok }) =
    (show tok) <> " at " <> (show pos)

parseTokens :: Mode -> P.Parser String (L.List PositionedToken)
parseTokens m = do
  skipSpaces
  xs <- many do
    parsePositionedToken (if isDescMode m
                                then parseDescriptionToken
                                else parseUsageToken)
  P.eof <|> void do
    i <- getInput
    P.fail $ "Unexpected input: " <> i
  pure xs

parsePositionedToken :: (P.Parser String Token) -> P.Parser String PositionedToken
parsePositionedToken p = do
  pos <- getPosition
  tok <- p
  pure $ PositionedToken { sourcePos: pos, token: tok }

parseUsageToken :: P.Parser String Token
parseUsageToken = P.choice [
    P.char   '('   $> LParen
  , P.char   ')'   $> RParen
  , P.char   ']'   $> RSquare
  , P.char   '|'   $> VBar
  , P.char   ':'   $> Colon
  , P.char   ','   $> Comma
  , P.string "..." $> TripleDot
  , P.char   '['   $> LSquare
  , _reference
  , P.try _longOption
  , P.try _shortOption
  , P.try _eoa
  , P.try _stdin
  , P.try $ AngleName <$> _angleName
  , P.try $ ShoutName <$> _shoutName
  , P.try $ Name      <$> _name
  ]
  <* skipSpaces -- skip spaces *AND* newlines

parseDescriptionToken :: P.Parser String Token
parseDescriptionToken = P.choice [
    P.char   ','   $> Comma
  , P.string "..." $> TripleDot
  , P.try _longOption
  , P.try _shortOption
  , P.try $ AngleName <$> _angleName
  , P.try $ ShoutName <$> _shoutName
  , P.try $ Name      <$> _name
  , P.try _tag
  , P.try _reference
  , P.try $ eol      $> Newline
  , P.try $ Garbage <$> P.anyChar
  ]
  <* spaces -- skip only spaces ' ' and '\t'

white :: P.Parser String Unit
white = void $ P.oneOf [ '\n', '\r', ' ', '\t' ]

_stdin :: P.Parser String Token
_stdin = do
  P.char '-'
  -- Ensure the argument is correctly bounded
  P.eof <|> (P.lookAhead $ P.choice $ P.try <$> [
    void $ white
  , void $ P.char '|'
  , void $ P.char ']'
  , void $ P.char ')'
  , void $ P.string "..."
  ])
  pure Dash

_eoa :: P.Parser String Token
_eoa = do
  P.string "--"
  -- Ensure the argument is correctly bounded
  P.eof <|> (P.lookAhead $ P.choice $ P.try <$> [
    void $ white
  , void $ P.char ']'
  , void $ P.char ')'
  ])
  pure DoubleDash

_reference :: P.Parser String Token
_reference = Reference <$> do
  P.char '@'
  foldMap String.singleton <$> many (P.noneOf [' ', '\n'])

_tag :: P.Parser String Token
_tag = P.between (P.char '[') (P.char ']') do
  P.choice $ P.try <$> [
    withValue
  , withoutValue
  ]

  where
    withValue = do
      many white
      k <- foldMap String.singleton <$> many (P.noneOf [':'])
      P.char ':'
      many white
      v <- trim <<< foldMap String.singleton <$> some (P.noneOf [']'])
      many white
      pure (Tag k (Just v))
    withoutValue = do
      k <- trim <<< foldMap String.singleton <$> some (P.noneOf [']'])
      pure (Tag k Nothing)

_shoutName :: P.Parser String String
_shoutName = do
  n <- foldMap String.singleton <$> do
    (:)
      <$> upperAlpha
      <*> (many (upperAlpha <|> P.oneOf ['-', '_']))
  P.notFollowedBy lowerAlpha
  pure n

_name :: P.Parser String String
_name = do
  foldMap String.singleton <$> do
    (:)
      <$> alphaNum
      <*> many do
            P.choice $ P.try <$> [
              identLetter
            , P.char '.' <* (P.notFollowedBy $ P.string "..")
            , P.oneOf [ '-', '_' ]
          ]

_angleName :: P.Parser String String
_angleName = do
  P.char '<'
  n <- foldMap String.singleton <$> do
    some $ P.choice [
      identLetter
      -- disallow swallowing new `<`s in order to avoid creating hard to trace
      -- errors for the user
    , P.noneOf [ '<', '>' ]
    ]
  P.char '>'
  pure $ "<" <> n <> ">"

_shortOption :: P.Parser String Token
_shortOption = do
  let validChar = alphaNum <|> P.oneOf [ '?' ]

  P.char '-'
  x  <- validChar
  xs <- A.many validChar

  arg <- P.choice $ P.try <$> [

    -- Case 1: -foo=BAR
    Just <$> do
      P.char '='
      n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
      pure  { name:     n
            , optional: false
            }

    -- Case 2: Option[=ARG]
  , Just <$> do
      P.char '['
      P.optional $ P.char '='
      n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
      P.char ']'
      pure  { name:     n
            , optional: true
            }

    -- Case 3: Option<ARG>
  , Just <$> do
      n <- _angleName
      pure { name:     n
            , optional: false
            }

  , pure Nothing
  ]

  -- Ensure the argument is correctly bounded
  P.eof <|> (P.lookAhead $ P.choice $ [
    void $ white
  , void $ P.char '|'
  , void $ P.string "..."
  , void $ P.char ']'
  , void $ P.char ')'
  , void $ P.char ',' -- desc mode only
  ])

  pure $ SOpt x xs arg

_longOption :: P.Parser String Token
_longOption = do
  P.string "--"

  name' <- foldMap String.singleton <$> do
    (:)
      <$> alphaNum
      <*> (many $ P.choice [
            alphaNum
          , P.oneOf [ '-' ] <* P.lookAhead alphaNum
          ])

  arg <- P.choice $ P.try <$> [

    -- Case 1: OPTION=ARG
    Just <$> do
      P.char '='
      n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
      pure { name:     n
              , optional: false
              }

    -- Case 2: Option[=ARG]
  , Just <$> do
      P.char '['
      P.optional $ P.char '='
      n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
      P.char ']'
      pure { name:     n
              , optional: true
              }

  , pure Nothing
  ]

  -- Ensure the argument is correctly bounded
  P.eof <|> (P.lookAhead $ P.choice $ [
    void $ white
  , void $ P.char '|'
  , void $ P.string "..."
  , void $ P.char ']'
  , void $ P.char ')'
  , void $ P.char ',' -- desc mode only
  ])

  pure $ LOpt name' arg

identStart :: P.Parser String Char
identStart = alpha

identLetter :: P.Parser String Char
identLetter = alphaNum <|> P.oneOf ['_', '-']

flag :: P.Parser String Char
flag = lowerAlphaNum

-- | Parser that  parses a stream of tokens
type TokenParser a = P.ParserT (List PositionedToken) (State ParserState) a

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> TokenParser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  pure $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      case test tok of
        Just a ->
          let nextpos =
                case xs of
                  Cons (PositionedToken { sourcePos: npos }) _ -> npos
                  Nil -> ppos
          in
            { consumed: true
            , input: xs
            , result: Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "expected token, met EOF"

-- | Match the token at the head of the stream
match :: Token -> TokenParser Unit
match tok = token (guard <<< (_ == tok)) P.<?> prettyPrintToken tok

anyToken :: TokenParser Token
anyToken = token $ Just

eof :: TokenParser Unit
eof = P.notFollowedBy anyToken P.<?> "EOF"

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

dash :: TokenParser Unit
dash = match Dash

doubleDash :: TokenParser Unit
doubleDash = match DoubleDash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

newline :: TokenParser Unit
newline = match Newline

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

garbage :: TokenParser Unit
garbage = token go P.<?> "garbage"
  where
    go (Garbage _) = Just unit
    go _           = Nothing

lopt :: TokenParser { name :: String
                    , arg  :: Maybe { name :: String
                                    , optional :: Boolean
                                    } }
lopt = token go P.<?> "long-option"
  where
    go (LOpt n a) = Just { name: n, arg: a }
    go _          = Nothing

sopt :: TokenParser { flag  :: Char
                    , stack :: Array Char
                    , arg   :: Maybe { name :: String
                                     , optional :: Boolean
                                     } }
sopt = token go P.<?> "short-option"
  where
    go (SOpt n s a) = Just { flag: n , stack: s , arg: a }
    go _ = Nothing

name :: TokenParser String
name = token go P.<?> "name"
  where
    go (Name n) = Just n
    go _        = Nothing

tag :: String -> TokenParser String
tag s = token go P.<?> ("tag: " <> s)
  where
    go (Tag k (Just v)) | k ^= s = Just v
    go _                         = Nothing

reference :: TokenParser String
reference = token go P.<?> "reference"
  where
    go (Reference r) = Just r
    go _             = Nothing

angleName :: TokenParser String
angleName = token go P.<?> "<name>"
  where
    go (AngleName n) = Just n
    go _             = Nothing

shoutName :: TokenParser String
shoutName = token go P.<?> "NAME"
  where
    go (ShoutName n) = Just n
    go _             = Nothing

-- | Return the next token's position w/o consuming anything
nextTokPos :: TokenParser P.Position
nextTokPos = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  pure $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      { consumed: false
      , input: toks
      , result: Right ppos
      , position: pos }
    _ -> P.parseFailed toks pos "expected token, met EOF"

runTokenParser :: forall a.
                  (List PositionedToken)
                -> TokenParser a
                -> Either P.ParseError a
runTokenParser s =
  flip evalState ({ indentation: 0, line: 0 })
        <<< P.runParserT (P.PState { input: s, position: P.initialPos })

module Language.Docopt.SpecParser.Lexer where

import Prelude
import Data.Array as A
import Debug.Trace
import Debug.Profile
import Data.List as L
import Data.Monoid (mempty)
import Data.Functor (($>))
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Monad.State (State, evalState)
import Control.Monad.State.Trans (StateT())
import Control.MonadPlus (guard)
import Data.Either (Either(..))
import Data.Identity (Identity())
import Data.Foldable (foldMap)
import Data.List (List(..), many, catMaybes, toUnfoldable, (:), some)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.String (fromCharArray, trim)
import Data.String (singleton) as String
import Data.String.Ext ((^=))
import Language.Docopt.SpecParser.Base (lowerAlphaNum, alphaNum, alpha, space,
                                        lowerAlpha, upperAlpha, string',
                                        getPosition, getInput, spaces, eol)
import Language.Docopt.SpecParser.State (ParserState)
import Text.Parsing.Parser (ParseError, Parser, PState(..), ParserT(..),
                            runParserT, parseFailed, fail, runParser) as P
import Text.Parsing.Parser.Combinators ((<?>), notFollowedBy, try, choice,
                                        lookAhead, optional, between, manyTill
                                        ) as P
import Text.Parsing.Parser.Pos (Position, initialPos) as P
import Text.Parsing.Parser.String (skipSpaces, anyChar, string, char, oneOf,
                                  whiteSpace, eof, noneOf, satisfy) as P

-- | faster P.skipSpaces
-- | TODO: move
skipSpaces = go
  where
    go = (do
      P.satisfy \c -> c == '\n' || c == '\r' || c == ' ' || c == '\t'
      go
    ) <|> pure unit

data Mode = Usage | Descriptions

isDescMode :: Mode -> Boolean
isDescMode Descriptions = true
isDescMode _            = false

isUsageMode :: Mode -> Boolean
isUsageMode Usage = true
isUsageMode _     = false

lex :: Mode -> String -> Either P.ParseError (List PositionedToken)
lex m input = do
  profileA "lex spec" \_->
    P.runParser input (parseTokens m)

lexDescs :: String -> Either P.ParseError (List PositionedToken)
lexDescs = lex Descriptions

lexUsage :: String -> Either P.ParseError (List PositionedToken)
lexUsage = lex Usage

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | Dash
  | VBar
  | Colon
  | Comma
  | Newline
  | TripleDot
  | Reference String
  | LOpt String (Maybe { name :: String, optional :: Boolean })
  | SOpt Char (Array Char) (Maybe { name :: String, optional :: Boolean })
  | Tag String (Maybe String)
  | Name String
  | ShoutName String
  | AngleName String
  | Garbage Char
  | DoubleDash

prettyPrintToken :: Token -> String
prettyPrintToken LParen        = show '('
prettyPrintToken RParen        = show ')'
prettyPrintToken LSquare       = show '['
prettyPrintToken RSquare       = show ']'
prettyPrintToken Dash          = show '-'
prettyPrintToken VBar          = show '|'
prettyPrintToken Newline       = show '\n'
prettyPrintToken Colon         = show ':'
prettyPrintToken Comma         = show ','
prettyPrintToken TripleDot     = "..."
prettyPrintToken DoubleDash    = "--"
prettyPrintToken (Reference r) = "Reference " <> show r
prettyPrintToken (Garbage   c) = "Garbage "   <> show c
prettyPrintToken (Tag k v)     = "Tag "       <> k <> " "  <> (show v)
prettyPrintToken (Name      n) = "Name "      <> show n
prettyPrintToken (ShoutName n) = "ShoutName " <> show n
prettyPrintToken (AngleName n) = "AngleName " <> show n
prettyPrintToken (LOpt n arg)
  = "--" <> n
         <> (fromMaybe "" do
              a <- arg
              pure $ if a.optional then "[" else ""
                <> a.name
                <> if a.optional then "]" else ""
            )
prettyPrintToken (SOpt n s arg)
  = "-" <> (fromCharArray (A.cons n s))
        <> (fromMaybe "" do
              a <- arg
              pure $ if a.optional then "[" else ""
                <> a.name
                <> if a.optional then "]" else ""
            )

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance eqToken :: Eq Token where
  eq LParen            LParen             = true
  eq RParen            RParen             = true
  eq LSquare           LSquare            = true
  eq RSquare           RSquare            = true
  eq VBar              VBar               = true
  eq Colon             Colon              = true
  eq Comma             Comma              = true
  eq Dash              Dash               = true
  eq DoubleDash        DoubleDash         = true
  eq TripleDot         TripleDot          = true
  eq Newline           Newline            = true
  eq (Reference r)     (Reference r')     = r == r'
  eq (LOpt n arg)      (LOpt n' arg')
    = (n == n')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              pure $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (SOpt n s arg)    (SOpt n' s' arg')
    = (n == n') && (s' == s')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              pure $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (AngleName n)     (AngleName n')     = n == n'
  eq (ShoutName n)     (ShoutName n')     = n == n'
  eq (Name n)          (Name n')          = n == n'
  eq (Garbage c)       (Garbage c')       = c == c'
  eq _ _                                  = false

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos: pos, token: tok }) =
    (show tok) <> " at " <> (show pos)

parseTokens :: Mode -> P.Parser String (L.List PositionedToken)
parseTokens m = do
  skipSpaces
  xs <- many do
    parsePositionedToken (if isDescMode m
                                then parseDescriptionToken
                                else parseUsageToken)
  P.eof <|> void do
    i <- getInput
    P.fail $ "Unexpected input: " <> i
  pure xs

parsePositionedToken :: (P.Parser String Token) -> P.Parser String PositionedToken
parsePositionedToken p = do
  pos <- getPosition
  tok <- p
  pure $ PositionedToken { sourcePos: pos, token: tok }

parseUsageToken :: P.Parser String Token
parseUsageToken = P.choice [
    P.char   '('   $> LParen
  , P.char   ')'   $> RParen
  , P.char   ']'   $> RSquare
  , P.char   '|'   $> VBar
  , P.char   ':'   $> Colon
  , P.char   ','   $> Comma
  , P.string "..." $> TripleDot
  , P.try _longOption
  , P.try _shortOption
  , P.try _eoa
  , P.try _stdin
  , P.try $ AngleName <$> _angleName
  , P.try $ ShoutName <$> _shoutName
  , P.try $ Name      <$> _name
  , P.try _reference
  , P.char   '['   $> LSquare
  ]
  <* skipSpaces -- skip spaces *AND* newlines

parseDescriptionToken :: P.Parser String Token
parseDescriptionToken = P.choice [
    P.char   ','   $> Comma
  , P.string "..." $> TripleDot
  , P.try _longOption
  , P.try _shortOption
  , P.try $ AngleName <$> _angleName
  , P.try $ ShoutName <$> _shoutName
  , P.try $ Name      <$> _name
  , P.try _tag
  , P.try _reference
  , P.try $ eol      $> Newline
  , P.try $ Garbage <$> P.anyChar
  ]
  <* spaces -- skip only spaces ' ' and '\t'

white :: P.Parser String Unit
white = void $ P.oneOf [ '\n', '\r', ' ', '\t' ]

_stdin :: P.Parser String Token
_stdin = do
  P.char '-'
  -- Ensure the argument is correctly bounded
  P.eof <|> (P.lookAhead $ P.choice $ P.try <$> [
    void $ white
  , void $ P.char '|'
  , void $ P.char ']'
  , void $ P.char ')'
  , void $ P.string "..."
  ])
  pure Dash

_eoa :: P.Parser String Token
_eoa = do
  P.string "--"
  -- Ensure the argument is correctly bounded
  P.eof <|> (P.lookAhead $ P.choice $ P.try <$> [
    void $ white
  , void $ P.char ']'
  , void $ P.char ')'
  ])
  pure DoubleDash

_reference :: P.Parser String Token
_reference = Reference <$> do
  P.between (P.char '[') (P.char ']') go

  where
    go = do
      skipSpaces
      foldMap String.singleton <$> do
        flip P.manyTill (P.lookAhead end) do
          P.noneOf [ ']' ]
      <* end <* skipSpaces

    end = do
      P.optional $ P.string "-"
      string' "options"
      P.optional $ P.string "..."

_tag :: P.Parser String Token
_tag = P.between (P.char '[') (P.char ']') do
  P.choice $ P.try <$> [
    withValue
  , withoutValue
  ]

  where
    withValue = do
      many white
      k <- foldMap String.singleton <$> many (P.noneOf [':'])
      P.char ':'
      many white
      v <- trim <<< foldMap String.singleton <$> some (P.noneOf [']'])
      many white
      pure (Tag k (Just v))
    withoutValue = do
      k <- trim <<< foldMap String.singleton <$> some (P.noneOf [']'])
      pure (Tag k Nothing)

_shoutName :: P.Parser String String
_shoutName = do
  n <- foldMap String.singleton <$> do
    (:)
      <$> upperAlpha
      <*> (many (upperAlpha <|> P.oneOf ['-', '_']))
  P.notFollowedBy lowerAlpha
  pure n

_name :: P.Parser String String
_name = do
  foldMap String.singleton <$> do
    (:)
      <$> alphaNum
      <*> many do
            P.choice $ P.try <$> [
              identLetter
            , P.char '.' <* (P.notFollowedBy $ P.string "..")
            , P.oneOf [ '-', '_' ]
          ]

_angleName :: P.Parser String String
_angleName = do
  P.char '<'
  n <- foldMap String.singleton <$> do
    some $ P.choice [
      identLetter
      -- disallow swallowing new `<`s in order to avoid creating hard to trace
      -- errors for the user
    , P.noneOf [ '<', '>' ]
    ]
  P.char '>'
  pure $ "<" <> n <> ">"

_shortOption :: P.Parser String Token
_shortOption = do
  let validChar = alphaNum <|> P.oneOf [ '?' ]

  P.char '-'
  x  <- validChar
  xs <- A.many validChar

  arg <- P.choice $ P.try <$> [

    -- Case 1: -foo=BAR
    Just <$> do
      P.char '='
      n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
      pure  { name:     n
            , optional: false
            }

    -- Case 2: Option[=ARG]
  , Just <$> do
      P.char '['
      P.optional $ P.char '='
      n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
      P.char ']'
      pure  { name:     n
            , optional: true
            }

    -- Case 3: Option<ARG>
  , Just <$> do
      n <- _angleName
      pure { name:     n
            , optional: false
            }

  , pure Nothing
  ]

  -- Ensure the argument is correctly bounded
  P.eof <|> (P.lookAhead $ P.choice $ [
    void $ white
  , void $ P.char '|'
  , void $ P.string "..."
  , void $ P.char ']'
  , void $ P.char ')'
  , void $ P.char ',' -- desc mode only
  ])

  pure $ SOpt x xs arg

_longOption :: P.Parser String Token
_longOption = do
  P.string "--"

  name' <- foldMap String.singleton <$> do
    (:)
      <$> alphaNum
      <*> (many $ P.choice [
            alphaNum
          , P.oneOf [ '-' ] <* P.lookAhead alphaNum
          ])

  arg <- P.choice $ P.try <$> [

    -- Case 1: OPTION=ARG
    Just <$> do
      P.char '='
      n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
      pure { name:     n
              , optional: false
              }

    -- Case 2: Option[=ARG]
  , Just <$> do
      P.char '['
      P.optional $ P.char '='
      n <- P.choice $ P.try <$> [ _angleName, _shoutName, _name ]
      P.char ']'
      pure { name:     n
              , optional: true
              }

  , pure Nothing
  ]

  -- Ensure the argument is correctly bounded
  P.eof <|> (P.lookAhead $ P.choice $ [
    void $ white
  , void $ P.char '|'
  , void $ P.string "..."
  , void $ P.char ']'
  , void $ P.char ')'
  , void $ P.char ',' -- desc mode only
  ])

  pure $ LOpt name' arg

identStart :: P.Parser String Char
identStart = alpha

identLetter :: P.Parser String Char
identLetter = alphaNum <|> P.oneOf ['_', '-']

flag :: P.Parser String Char
flag = lowerAlphaNum

-- | Parser that  parses a stream of tokens
type TokenParser a = P.ParserT (List PositionedToken) (State ParserState) a

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> TokenParser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  pure $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      case test tok of
        Just a ->
          let nextpos =
                case xs of
                  Cons (PositionedToken { sourcePos: npos }) _ -> npos
                  Nil -> ppos
          in
            { consumed: true
            , input: xs
            , result: Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "expected token, met EOF"

-- | Match the token at the head of the stream
match :: Token -> TokenParser Unit
match tok = token (guard <<< (_ == tok)) P.<?> prettyPrintToken tok

anyToken :: P.ParserT (List PositionedToken)
                      (StateT { indentation :: Int , line :: Int } Identity )
                      Token
anyToken = token $ Just

eof :: TokenParser Unit
eof = P.notFollowedBy anyToken P.<?> "EOF"

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

dash :: TokenParser Unit
dash = match Dash

doubleDash :: TokenParser Unit
doubleDash = match DoubleDash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

newline :: TokenParser Unit
newline = match Newline

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

garbage :: TokenParser Unit
garbage = token go P.<?> "garbage"
  where
    go (Garbage _) = Just unit
    go _           = Nothing

lopt :: TokenParser { name :: String
                    , arg  :: Maybe { name :: String
                                    , optional :: Boolean
                                    } }
lopt = token go P.<?> "long-option"
  where
    go (LOpt n a) = Just { name: n, arg: a }
    go _          = Nothing

sopt :: TokenParser { flag  :: Char
                    , stack :: Array Char
                    , arg   :: Maybe { name :: String
                                     , optional :: Boolean
                                     } }
sopt = token go P.<?> "short-option"
  where
    go (SOpt n s a) = Just { flag: n , stack: s , arg: a }
    go _ = Nothing

name :: TokenParser String
name = token go P.<?> "name"
  where
    go (Name n) = Just n
    go _        = Nothing

tag :: String -> TokenParser String
tag s = token go P.<?> ("tag: " <> s)
  where
    go (Tag k (Just v)) | k ^= s = Just v
    go _                         = Nothing

reference :: TokenParser String
reference = token go P.<?> "reference"
  where
    go (Reference r) = Just r
    go _             = Nothing

angleName :: TokenParser String
angleName = token go P.<?> "<name>"
  where
    go (AngleName n) = Just n
    go _             = Nothing

shoutName :: TokenParser String
shoutName = token go P.<?> "NAME"
  where
    go (ShoutName n) = Just n
    go _             = Nothing

-- | Return the next token's position w/o consuming anything
nextTokPos :: TokenParser P.Position
nextTokPos = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  pure $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      { consumed: false
      , input: toks
      , result: Right ppos
      , position: pos }
    _ -> P.parseFailed toks pos "expected token, met EOF"

runTokenParser :: forall a.
                  (List PositionedToken)
                -> TokenParser a
                -> Either P.ParseError a
runTokenParser s =
  flip evalState ({ indentation: 0, line: 0 })
        <<< P.runParserT (P.PState { input: s, position: P.initialPos })


Count steps

Count steps

module Components.App
  ( mkApp
  ) where

import Lambda.Prelude

import Components.Alert (Level(..))
import Components.Alert as Alert
import Components.ConsistencyError as ConsistencyError
import Components.Controls as Controls
import Components.Definitions as Definitions
import Components.Expressions as Expressions
import Components.Footer as Footer
import Components.Help as Help
import Components.Input as Input
import Components.ParseError as ParseError
import Data.Array as Array
import Data.Foldable (intercalate)
import Data.Grammar (pluralizeWith)
import Data.List as List
import Effect.Save (FileName(..), saveTextAs)
import Lambda.Language.History (History)
import Lambda.Language.History as History
import Lambda.Language.Name (Name)
import Lambda.Language.Nameless as Nameless
import Lambda.Language.Parse (parseAll, parseDefinition, parseStatement, unsafeParse)
import Lambda.Language.Pretty (Rep(..), toggle, pretty, toString)
import Lambda.Language.Syntax (Statement(..), Definition(..), fromDef)
import Lambda.Language.Syntax as Syntax
import Lambda.Language.World (World)
import Lambda.Language.World as World
import Lambda.Machine (Machine)
import Lambda.Machine as Machine
import React.Basic (JSX)
import React.Basic as React
import React.Basic.DOM as R
import React.Basic.Hooks (Component, component, mkReducer, useReducer)
import React.Basic.Hooks as Hooks

-- | Manages text-input, global definitions, semantic consistency
-- | (world field), and machine state, if any.
type State =
  { text :: String
  , defs :: Array Definition
  , world :: World
  , machine :: Maybe Machine
  , history :: History
  , rep :: Rep
  , alert :: Maybe (Tuple Level JSX)
  , steps :: Maybe Int
  }

mkApp :: Component {}
mkApp = do
  reducer <- mkReducer update
  component "App" \_ -> Hooks.do
    state /\ dispatch <- useReducer initialState reducer
    pure $ R.div
      { className: "container"
      , children:
        [ row $ R.h2
          { className: "page-header"
          , children: [R.text "Lambda Machine"]
          }
        , row $ case state.alert of
            Nothing ->
              React.empty
            Just (Tuple level body) ->
              Alert.component
                { level
                , child: body
                , dismiss: dispatch DismissAlert
                }
        , row $ Input.component
          { text: state.text
          , onChange: dispatch <<< UpdateText
          , onSubmit: dispatch ParseText
          , onHelp: dispatch ShowHelp
          }
        , row $ R.h3_ [R.text "Definitions"]
        , row $ Definitions.component
          { defs: state.defs
          , rep: state.rep
          , onDelete: dispatch <<< DeleteDef
          }
        , split
          (stepsHeader state.steps)
          (Controls.component
            { machine: state.machine
            , onStep: dispatch <<< Step
            , onClear: dispatch Clear
            , onSave: save state
            , onSugar: dispatch ToggleSugar
            , rep: state.rep
            }
          )
        , row $ Expressions.component
          { history: state.history
          , rep: state.rep
          }
        , row $ Footer.component {}
        ]
      }

-- | Row containing a single full-width element
row :: JSX -> JSX
row child =
  R.div
    { className: "row"
    , children: [R.div {className: "col-sm-12", children: [child]}]
    }

-- | Row containing two equal-width elements
split :: JSX -> JSX -> JSX
split lhs rhs =
  R.div
    { className: "row"
    , children:
      [ R.div {className: "col-sm-6", children: [lhs]}
      , R.div {className: "col-sm-6", children: [rhs]}
      ]
    }

-- | Default set of global definitions
prelude :: Array Definition
prelude =
  unsafeParse parseDefinition <$>
    [ "identity x = x"
    , "const x y = x"
    , "fix f = f (fix f)"
    , "true t f = t"
    , "false t f = f"
    , "and x y = x y false"
    , "or x y = x true y"
    , "not x = x false true"
    , "succ n s z = s (n s z)"
    , "pred n s z = n (λg. λh. h (g s)) (λu. z) (λu. u)"
    , "add m n s z = m s (n s z)"
    , "mul m n s z = m (n s) z"
    , "zero? n = n (λx. false) true"
    , "foldr f z l = l f z"
    , "any = foldr or false"
    , "all = foldr and true"
    , "cons x xs f z = f x (xs f z)"
    , "nil f z = z"
    , "iterate f x = cons x (iterate f (f x))"
    , "repeat x = cons x (repeat x)"
    ]

-- | Set of user-driven events
data Action
  = ShowHelp
  | DismissAlert
  | UpdateText String
  | ParseText
  | DeleteDef Name
  | AddDef Definition
  | SetExpr Syntax.Expression
  | Step Machine
  | Clear
  | ToggleSugar

-- | Empty state with default global definitions
initialState :: State
initialState =
  { text: ""
  , defs: prelude
  , world: World.new $ defsToGlobals prelude
  , machine: Nothing
  , history: History.empty
  , rep: Raw
  , alert: Nothing
  , steps: Nothing
  }

-- | Update `State` in response to an `Action`
update :: State -> Action -> State
update s = case _ of
  ShowHelp -> showHelp s
  DismissAlert -> dismissAlert s
  UpdateText text -> updateText text s
  ParseText -> parseText s
  DeleteDef name -> deleteDef name s
  AddDef def -> addDef def s
  SetExpr expr -> setExpr expr s
  Step machine -> step machine s
  Clear -> clear s
  ToggleSugar -> toggleSugar s

-- | Present the tutorial alert
showHelp :: State -> State
showHelp =
  _ {alert = pure $ Tuple Info $ Help.component {} }

-- | Dismiss any alert
dismissAlert :: State -> State
dismissAlert =
  _ {alert = Nothing}

-- | Update input text
updateText :: String -> State -> State
updateText text =
  _ {alert = Nothing, text = text}

-- | Attempt to parse the input. Input may be a definition, an
-- | expression, or malformed, in which case, we'll surface a
-- | syntax error.
parseText :: State -> State
parseText s
  | s.text == "" = s
parseText s =
  case parseAll parseStatement s.text of
    Left error -> s
      { alert = pure
        $ Tuple Danger
        $ ParseError.component
          { input: s.text
          , error
          }
      }
    Right (Define def) ->
      addDef def s
    Right (Eval syntax) ->
      setExpr syntax s

-- | Attempt to delete a global definition. If the input or any other
-- | global definition depends on it, we'll refuse to delete the
-- | definition and present an error message.
deleteDef :: Name -> State -> State
deleteDef name s = case World.undefine name s.world of
  Left error -> s
    { alert = pure
      $ Tuple Danger
      $ ConsistencyError.component
        { error
        }
    }
  Right world -> s
    { defs = deleteByName name s.defs
    , world = world
    , alert = Nothing
    }

-- | Remove a definition by name. Used when deleting a definition or
-- | redefining an extant definition.
deleteByName :: Name -> Array Definition -> Array Definition
deleteByName name = Array.filter $ (_ /= name) <<< _.name <<< un Definition

-- | Attempt to add a new global definition. If the definition depends
-- | on undefined names, present an error message.
addDef :: Definition -> State -> State
addDef def s = case World.define name nameless s.world of
  Left error -> s
    { alert = pure
      $ Tuple Danger
      $ ConsistencyError.component
        { error
        }
    }
  Right world -> s
    { text = ""
    , defs = deleteByName name s.defs `Array.snoc` def
    , world = world
    , alert = Nothing
    }
 where
  { expr, name } = fromDef def
  nameless = Nameless.from expr

-- | Attempt to set the main expression. If the expression depends on
-- | undefined names, present an error message.
setExpr :: Syntax.Expression -> State -> State
setExpr syntax s =
  case World.focus expr s.world of
    Left error -> s
      { alert = pure
        $ Tuple Danger
        $ ConsistencyError.component
          { error
          }
      }
    Right world ->
      let
        machine = Machine.new globals expr
        snapshot = Machine.snapshot machine
      in s
        { text = ""
        , world = world
        , machine = pure machine
        , history = History.new snapshot
        , alert = Nothing
        , steps = Just 0
        }
 where
  expr = Nameless.from syntax
  globals = defsToGlobals s.defs

-- | Convert `Definition`s to pairs of names and expressions.
defsToGlobals :: Array Definition -> Array (Tuple Name Nameless.Expression)
defsToGlobals = map \def ->
  let {expr, name} = fromDef def
  in Tuple name $ Nameless.from expr

-- | Do one step of evaluation and update the history.
step :: Machine -> State -> State
step m0 s =  s
  { machine = pure m
  , history = history
  , steps = (1 + _) <$> s.steps
  }
 where
  m = Machine.step m0
  snapshot = Machine.snapshot m
  history = History.add snapshot s.history

-- | Unload the `Machine` and unset the main expression
clear :: State -> State
clear s = s
  { world = World.unfocus s.world
  , machine = Nothing
  , history = History.empty
  , steps = Nothing
  }

-- | Toggle syntactic sugar for Church numerals and lists.
toggleSugar :: State -> State
toggleSugar s = s {rep = toggle s.rep}

-- | Download the state as a text file.
save :: State -> Effect Unit
save {rep, defs, history} =
  saveTextAs text $ FileName "evaluation.txt"
 where
  text = intercalate "\n" $ fold
    [ toString <<< pretty rep <$> defs
    , pure ""
    , Array.fromFoldable $ List.reverse $ History.toStrings rep history
    ]

stepsHeader :: Maybe Int -> JSX
stepsHeader = case _ of
  Nothing -> R.h3
    { className: "text-muted"
    , children: [R.text "Steps"]
    }
  Just n -> R.h3_
    [ R.text $ fold
      [ show n
      , " "
      , pluralizeWith "s" n "Step"
      ]
    ]

module Components.App
  ( mkApp
  ) where

import Lambda.Prelude

import Components.Alert (Level(..))
import Components.Alert as Alert
import Components.ConsistencyError as ConsistencyError
import Components.Controls as Controls
import Components.Definitions as Definitions
import Components.Expressions as Expressions
import Components.Footer as Footer
import Components.Help as Help
import Components.Input as Input
import Components.ParseError as ParseError
import Data.Array as Array
import Data.Foldable (intercalate)
import Data.List as List
import Effect.Save (FileName(..), saveTextAs)
import Lambda.Language.History (History)
import Lambda.Language.History as History
import Lambda.Language.Name (Name)
import Lambda.Language.Nameless as Nameless
import Lambda.Language.Parse (parseAll, parseDefinition, parseStatement, unsafeParse)
import Lambda.Language.Pretty (Rep(..), toggle, pretty, toString)
import Lambda.Language.Syntax (Statement(..), Definition(..), fromDef)
import Lambda.Language.Syntax as Syntax
import Lambda.Language.World (World)
import Lambda.Language.World as World
import Lambda.Machine (Machine)
import Lambda.Machine as Machine
import React.Basic (JSX)
import React.Basic as React
import React.Basic.DOM as R
import React.Basic.Hooks (Component, component, mkReducer, useReducer)
import React.Basic.Hooks as Hooks

-- | Manages text-input, global definitions, semantic consistency
-- | (world field), and machine state, if any.
type State =
  { text :: String
  , defs :: Array Definition
  , world :: World
  , machine :: Maybe Machine
  , history :: History
  , rep :: Rep
  , alert :: Maybe (Tuple Level JSX)
  }

mkApp :: Component {}
mkApp = do
  reducer <- mkReducer update
  component "App" \_ -> Hooks.do
    state /\ dispatch <- useReducer initialState reducer
    pure $ R.div
      { className: "container"
      , children:
        [ row $ R.h2
          { className: "page-header"
          , children: [R.text "Lambda Machine"]
          }
        , row $ case state.alert of
            Nothing ->
              React.empty
            Just (Tuple level body) ->
              Alert.component
                { level
                , child: body
                , dismiss: dispatch DismissAlert
                }
        , row $ Input.component
          { text: state.text
          , onChange: dispatch <<< UpdateText
          , onSubmit: dispatch ParseText
          , onHelp: dispatch ShowHelp
          }
        , row $ R.h3_ [R.text "Definitions"]
        , row $ Definitions.component
          { defs: state.defs
          , rep: state.rep
          , onDelete: dispatch <<< DeleteDef
          }
        , split
          (R.h3_ [R.text "Evaluation"])
          (Controls.component
            { machine: state.machine
            , onStep: dispatch <<< Step
            , onClear: dispatch Clear
            , onSave: save state
            , onSugar: dispatch ToggleSugar
            , rep: state.rep
            }
          )
        , row $ Expressions.component
          { history: state.history
          , rep: state.rep
          }
        , row $ Footer.component {}
        ]
      }

-- | Row containing a single full-width element
row :: JSX -> JSX
row child =
  R.div
    { className: "row"
    , children: [R.div {className: "col-sm-12", children: [child]}]
    }

-- | Row containing two equal-width elements
split :: JSX -> JSX -> JSX
split lhs rhs =
  R.div
    { className: "row"
    , children:
      [ R.div {className: "col-sm-6", children: [lhs]}
      , R.div {className: "col-sm-6", children: [rhs]}
      ]
    }

-- | Default set of global definitions
prelude :: Array Definition
prelude =
  unsafeParse parseDefinition <$>
    [ "identity x = x"
    , "const x y = x"
    , "fix f = f (fix f)"
    , "true t f = t"
    , "false t f = f"
    , "and x y = x y false"
    , "or x y = x true y"
    , "not x = x false true"
    , "succ n s z = s (n s z)"
    , "pred n f x = n (λg. λh. h (g f)) (λu. x) (λu. u)"
    , "add m n s z = m s (n s z)"
    , "mul m n s z = m (n s) z"
    , "zero? n = n (λx. false) true"
    , "foldr f z l = l f z"
    , "any = foldr or false"
    , "all = foldr and true"
    , "cons x xs f z = f x (xs f z)"
    , "nil f z = z"
    , "iterate f x = cons x (iterate f (f x))"
    , "repeat x = cons x (repeat x)"
    ]

-- | Set of user-driven events
data Action
  = ShowHelp
  | DismissAlert
  | UpdateText String
  | ParseText
  | DeleteDef Name
  | AddDef Definition
  | SetExpr Syntax.Expression
  | Step Machine
  | Clear
  | ToggleSugar

-- | Empty state with default global definitions
initialState :: State
initialState =
  { text: ""
  , defs: prelude
  , world: World.new $ defsToGlobals prelude
  , machine: Nothing
  , history: History.empty
  , rep: Raw
  , alert: Nothing
  }

-- | Update `State` in response to an `Action`
update :: State -> Action -> State
update s = case _ of
  ShowHelp -> showHelp s
  DismissAlert -> dismissAlert s
  UpdateText text -> updateText text s
  ParseText -> parseText s
  DeleteDef name -> deleteDef name s
  AddDef def -> addDef def s
  SetExpr expr -> setExpr expr s
  Step machine -> step machine s
  Clear -> clear s
  ToggleSugar -> toggleSugar s

-- | Present the tutorial alert
showHelp :: State -> State
showHelp =
  _ {alert = pure $ Tuple Info $ Help.component {} }

-- | Dismiss any alert
dismissAlert :: State -> State
dismissAlert =
  _ {alert = Nothing}

-- | Update input text
updateText :: String -> State -> State
updateText text =
  _ {alert = Nothing, text = text}

-- | Attempt to parse the input. Input may be a definition, an
-- | expression, or malformed, in which case, we'll surface a
-- | syntax error.
parseText :: State -> State
parseText s
  | s.text == "" = s
parseText s =
  case parseAll parseStatement s.text of
    Left error -> s
      { alert = pure
        $ Tuple Danger
        $ ParseError.component
          { input: s.text
          , error
          }
      }
    Right (Define def) ->
      addDef def s
    Right (Eval syntax) ->
      setExpr syntax s

-- | Attempt to delete a global definition. If the input or any other
-- | global definition depends on it, we'll refuse to delete the
-- | definition and present an error message.
deleteDef :: Name -> State -> State
deleteDef name s = case World.undefine name s.world of
  Left error -> s
    { alert = pure
      $ Tuple Danger
      $ ConsistencyError.component
        { error
        }
    }
  Right world -> s
    { defs = deleteByName name s.defs
    , world = world
    , alert = Nothing
    }

-- | Remove a definition by name. Used when deleting a definition or
-- | redefining an extant definition.
deleteByName :: Name -> Array Definition -> Array Definition
deleteByName name = Array.filter $ (_ /= name) <<< _.name <<< un Definition

-- | Attempt to add a new global definition. If the definition depends
-- | on undefined names, present an error message.
addDef :: Definition -> State -> State
addDef def s = case World.define name nameless s.world of
  Left error -> s
    { alert = pure
      $ Tuple Danger
      $ ConsistencyError.component
        { error
        }
    }
  Right world -> s
    { text = ""
    , defs = deleteByName name s.defs `Array.snoc` def
    , world = world
    , alert = Nothing
    }
 where
  { expr, name } = fromDef def
  nameless = Nameless.from expr

-- | Attempt to set the main expression. If the expression depends on
-- | undefined names, present an error message.
setExpr :: Syntax.Expression -> State -> State
setExpr syntax s =
  case World.focus expr s.world of
    Left error -> s
      { alert = pure
        $ Tuple Danger
        $ ConsistencyError.component
          { error
          }
      }
    Right world ->
      let
        machine = Machine.new globals expr
        snapshot = Machine.snapshot machine
      in s
        { text = ""
        , world = world
        , machine = pure machine
        , history = History.new snapshot
        , alert = Nothing
        }
 where
  expr = Nameless.from syntax
  globals = defsToGlobals s.defs

-- | Convert `Definition`s to pairs of names and expressions.
defsToGlobals :: Array Definition -> Array (Tuple Name Nameless.Expression)
defsToGlobals = map \def ->
  let {expr, name} = fromDef def
  in Tuple name $ Nameless.from expr

-- | Do one step of evaluation and update the history.
step :: Machine -> State -> State
step m0 s =  s
  { machine = pure m
  , history = history
  }
 where
  m = Machine.step m0
  snapshot = Machine.snapshot m
  history = History.add snapshot s.history

-- | Unload the `Machine` and unset the main expression
clear :: State -> State
clear s = s
  { world = World.unfocus s.world
  , machine = Nothing
  , history = History.empty
  }

-- | Toggle syntactic sugar for Church numerals and lists.
toggleSugar :: State -> State
toggleSugar s = s {rep = toggle s.rep}

-- | Download the state as a text file.
save :: State -> Effect Unit
save {rep, defs, history} =
  saveTextAs text $ FileName "evaluation.txt"
 where
  text = intercalate "\n" $ fold
    [ toString <<< pretty rep <$> defs
    , pure ""
    , Array.fromFoldable $ List.reverse $ History.toStrings rep history
    ]


header gripper

header gripper

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Header.Gripper.Component where

import SlamData.Prelude

import Control.Monad.Aff.Bus as Bus
import Control.Monad.Rec.Class (forever)

import Data.Int as Int
import Data.Nullable as N

import DOM.Event.Event as DEE
import DOM.Event.EventTarget as Etr
import DOM.Event.MouseEvent as DEM
import DOM.Event.Types as DET
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes as Etp
import DOM.HTML.Types as Ht
import DOM.HTML.Window as Win
import DOM.Node.ParentNode as Pn
import DOM.Node.Types as Dt

import CSS.Geometry (marginTop)
import CSS.Size (px)
import CSS.String (fromString)
import CSS.Stylesheet (CSS, (?), keyframesFromTo)
import CSS.Animation (animation, iterationCount, normalAnimationDirection, forwards)
import CSS.Time (sec)
import CSS.Transition (easeOut)

import Halogen as H
import Halogen.HTML.CSS as CSS
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA

import SlamData.Monad (Slam)
import SlamData.Wiring as Wiring

import Unsafe.Coerce (unsafeCoerce)

data Query a
  = Init a
  | StartDragging DET.MouseEvent a
  | StopDragging a
  | ChangePosition Number a
  | Animated a
  | Notify State a

data Direction = Up | Down

data State
  = Closed
  | Opened
  | Dragging Direction Number Number
  | Opening Number
  | Closing Number

data Message = Notify State

initialState ∷ State
initialState = Closed

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Slam

comp ∷ String → H.Component State Query Slam
comp querySelector = H.lifecycleComponent
  { initialState: const Closed
  , render: render querySelector
  , eval: eval querySelector
  , initializer: Just $ H.action Init
  , finalizer: Nothing
  , receiver: const Nothing
  }

render ∷ String → State → HTML
render sel state =
  HH.div
    [ HP.classes
        [ HH.ClassName "header-gripper"
        , HH.ClassName $ className state
        ]
    , HE.onMouseDown $ HE.input StartDragging
    , ARIA.label $ label state
    ]
    [ CSS.stylesheet $ renderStyles sel state ]
  where
  label ∷ State → String
  label = case _ of
    Closed → "Show header"
    Opening _ →  "Show header"
    Dragging Down _ _ → "Show header"
    _ → "Hide header"

  className ∷ State → String
  className = case _ of
    Opened → "sd-header-gripper-opened"
    Closed → "sd-header-gripper-closed"
    Opening _ → "sd-header-gripper-opening"
    Closing _ → "sd-header-gripper-closing"
    Dragging Down _ _ → "sd-header-gripper-dragging-down"
    Dragging Up _ _ → "sd-header-gripper-dragging-up"

maxMargin ∷ Number
maxMargin = 70.0

animationDuration ∷ Number
animationDuration = 0.5

renderStyles ∷ String → State → CSS
renderStyles sel Closed = do
  (fromString sel) ? (marginTop $ px (-maxMargin))
renderStyles sel Opened = do
  (fromString sel) ? (marginTop $ px zero)
renderStyles sel (Opening startPos) = do
  let
    marginTo = zero
    marginFrom = startPos - maxMargin
  mkAnimation sel marginFrom marginTo
renderStyles sel (Closing startPos) = do
  let
    marginTo = -maxMargin
    marginFrom = startPos - maxMargin
  mkAnimation sel marginFrom marginTo
renderStyles sel (Dragging _ start current) = do
  (fromString sel) ? do
    marginTop $ px (-maxMargin + current - start)

mkAnimation ∷ String → Number → Number → CSS
mkAnimation sel marginFrom marginTo = do
  let
    marginFromStyle = marginTop $ px marginFrom
    marginToStyle = marginTop $ px marginTo
  (fromString sel) ? do
    keyframesFromTo "header-gripper-margin" marginFromStyle marginToStyle
    animation
      (fromString "header-gripper-margin")
      (sec animationDuration)
      easeOut
      (sec zero)
      (iterationCount one)
      normalAnimationDirection
      forwards

eval ∷ String → (Query ~> DSL)
eval sel (Init next) = do
  doc ←
    H.liftEff
      $ window
      >>= Win.document

  mbNavEl ←
    H.liftEff
      $ Pn.querySelector sel (Ht.htmlDocumentToParentNode doc)
      <#> N.toMaybe
  let
    evntify ∷ ∀ a. a → { clientY ∷ Number }
    evntify = unsafeCoerce

    docTarget = Ht.htmlDocumentToEventTarget doc

    attachMouseUp f =
      Etr.addEventListener Etp.mouseup (Etr.eventListener f) false docTarget
    attachMouseMove f =
      Etr.addEventListener Etp.mousemove (Etr.eventListener f) false docTarget

    handleMouseUp e =
      pure $ H.action $ StopDragging
    handleMouseMove e = do
      pure $ H.action $ ChangePosition (evntify e).clientY

  H.subscribe $ H.eventSource attachMouseUp handleMouseUp
  H.subscribe $ H.eventSource attachMouseMove handleMouseMove

  for_ mbNavEl \navEl →
    let
      attachAnimationEnd f =
        Etr.addEventListener Etp.animationend (Etr.eventListener f) false
          $ Dt.elementToEventTarget navEl

      handleAnimationEnd e =
        pure $ H.action Animated
    in
      H.subscribe $ H.eventSource attachAnimationEnd handleAnimationEnd

  { auth } ← H.liftH Wiring.expose
  forever $ const (H.put $ Closing maxMargin) =<< H.liftAff (Bus.read auth.signIn)
  pure next
eval _ (StartDragging evt next) = do
  H.liftEff $ DEE.preventDefault $ DET.mouseEventToEvent evt
  let pos = Int.toNumber $ DEM.clientY evt
  H.get >>= case _ of
    Closed → H.put (Dragging Down pos pos)
    Opened → H.put (Dragging Up (pos - maxMargin) pos)
    _ → pure unit
  H.get >>= H.raise ∘ Notify
  pure next
eval _ (StopDragging next) = do
  astate ← H.get
  case astate of
    Dragging dir s current →
      let
        nextState Down = Opening
        nextState Up = Closing
      in
        H.put (nextState dir $ current - s)
    _ → pure unit
  pure next
eval _ (ChangePosition num next) = do
  astate ← H.get
  let
    toSet s =
      let diff = num - s
      in s + if diff < 0.0 then 0.0 else if diff > maxMargin then maxMargin else diff
    direction oldPos oldDir =
      if num ≡ oldPos then oldDir else if num > oldPos then Down  else Up
  case astate of
    Dragging oldDir s old →
      H.put (Dragging (direction old oldDir) s $ toSet s)
    _ → pure unit
  pure next
eval _ (Animated next) = do
  astate ← H.get
  case astate of
    Opening _ → H.put Opened
    Closing _ → H.put Closed
    _ → pure unit
  H.get >>= raise ∘ Notify
  pure next

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Header.Gripper.Component where

import SlamData.Prelude

import Control.Monad.Aff.Bus as Bus
import Control.Monad.Rec.Class (forever)

import Data.Nullable as N
import DOM.Event.EventTarget as Etr
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes as Etp
import DOM.HTML.Types as Ht
import DOM.HTML.Window as Win
import DOM.Node.ParentNode as Pn
import DOM.Node.Types as Dt

import CSS.Geometry (marginTop)
import CSS.Size (px)
import CSS.String (fromString)
import CSS.Stylesheet (CSS, (?), keyframesFromTo)
import CSS.Animation (animation, iterationCount, normalAnimationDirection, forwards)
import CSS.Time (sec)
import CSS.Transition (easeOut)

import Halogen as H
import Halogen.Component.Utils (raise)
import Halogen.HTML.CSS as CSS
--import Halogen.HTML.Events.Handler as HEH
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA

import SlamData.Monad (Slam)
import SlamData.Wiring as Wiring

import Unsafe.Coerce (unsafeCoerce)

data Query a
  = Init a
  | StartDragging Number a
  | StopDragging a
  | ChangePosition Number a
  | Animated a
  | Notify State a

data Direction = Up | Down

data State
  = Closed
  | Opened
  | Dragging Direction Number Number
  | Opening Number
  | Closing Number

initialState ∷ State
initialState = Closed

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Slam

comp ∷ String → H.Component State Query Slam
comp querySelector = H.lifecycleComponent
  { render: render querySelector
  , eval: eval querySelector
  , initializer: Just (H.action Init)
  , finalizer: Nothing
  }

render ∷ String → State → HTML
render sel state =
  HH.div
    [ HP.classes
        [ HH.ClassName "header-gripper"
        , HH.ClassName $ className state
        ]
        -- TODO: preventDefault
--    , HE.onMouseDown \evt →
--        HEH.preventDefault $> Just (H.action $ StartDragging evt.clientY)
    , ARIA.label $ label state
    ]
    [ CSS.stylesheet $ renderStyles sel state ]
  where
  label ∷ State → String
  label Closed = "Show header"
  label (Opening _) = "Show header"
  label (Dragging Down _ _) = "Show header"
  label _ = "Hide header"

  className ∷ State → String
  className Opened = "sd-header-gripper-opened"
  className Closed = "sd-header-gripper-closed"
  className (Opening _) = "sd-header-gripper-opening"
  className (Closing _) = "sd-header-gripper-closing"
  className (Dragging Down _ _) = "sd-header-gripper-dragging-down"
  className (Dragging Up _ _) = "sd-header-gripper-dragging-up"

maxMargin ∷ Number
maxMargin = 70.0

animationDuration ∷ Number
animationDuration = 0.5

renderStyles ∷ String → State → CSS
renderStyles sel Closed = do
  (fromString sel) ? (marginTop $ px (-maxMargin))
renderStyles sel Opened = do
  (fromString sel) ? (marginTop $ px zero)
renderStyles sel (Opening startPos) = do
  let
    marginTo = zero
    marginFrom = startPos - maxMargin
  mkAnimation sel marginFrom marginTo
renderStyles sel (Closing startPos) = do
  let
    marginTo = -maxMargin
    marginFrom = startPos - maxMargin
  mkAnimation sel marginFrom marginTo
renderStyles sel (Dragging _ start current) = do
  (fromString sel) ? do
    marginTop $ px (-maxMargin + current - start)

mkAnimation ∷ String → Number → Number → CSS
mkAnimation sel marginFrom marginTo = do
  let
    marginFromStyle = marginTop $ px marginFrom
    marginToStyle = marginTop $ px marginTo
  (fromString sel) ? do
    keyframesFromTo "header-gripper-margin" marginFromStyle marginToStyle
    animation
      (fromString "header-gripper-margin")
      (sec animationDuration)
      easeOut
      (sec zero)
      (iterationCount one)
      normalAnimationDirection
      forwards

eval ∷ String → (Query ~> DSL)
eval sel (Init next) = do
  doc ←
    H.liftEff
      $ window
      >>= Win.document

  mbNavEl ←
    H.liftEff
      $ Pn.querySelector sel (Ht.htmlDocumentToParentNode doc)
      <#> N.toMaybe
  let
    evntify ∷ ∀ a. a → { clientY ∷ Number }
    evntify = unsafeCoerce

    docTarget = Ht.htmlDocumentToEventTarget doc

    attachMouseUp f =
      Etr.addEventListener Etp.mouseup (Etr.eventListener f) false docTarget
    attachMouseMove f =
      Etr.addEventListener Etp.mousemove (Etr.eventListener f) false docTarget

    handleMouseUp e =
      pure $ H.action $ StopDragging
    handleMouseMove e = do
      pure $ H.action $ ChangePosition (evntify e).clientY

  H.subscribe $ H.eventSource attachMouseUp handleMouseUp
  H.subscribe $ H.eventSource attachMouseMove handleMouseMove

  for_ mbNavEl \navEl →
    let
      attachAnimationEnd f =
        Etr.addEventListener Etp.animationend (Etr.eventListener f) false
          $ Dt.elementToEventTarget navEl

      handleAnimationEnd e =
        pure $ H.action Animated
    in
      H.subscribe $ H.eventSource attachAnimationEnd handleAnimationEnd

  { auth } ← H.liftH Wiring.expose
  forever $ const (H.put $ Closing maxMargin) =<< H.liftAff (Bus.read auth.signIn)
  pure next
eval _ (StartDragging pos next) = do
  astate ← H.get
  case astate of
    Closed → H.put (Dragging Down pos pos)
    Opened → H.put (Dragging Up (pos - maxMargin) pos)
    _ → pure unit
  H.get >>= raise ∘ H.action ∘ Notify
  pure next
eval _ (StopDragging next) = do
  astate ← H.get
  case astate of
    Dragging dir s current →
      let
        nextState Down = Opening
        nextState Up = Closing
      in
        H.put (nextState dir $ current - s)
    _ → pure unit
  pure next
eval _ (ChangePosition num next) = do
  astate ← H.get
  let
    toSet s =
      let diff = num - s
      in s + if diff < 0.0 then 0.0 else if diff > maxMargin then maxMargin else diff
    direction oldPos oldDir =
      if num ≡ oldPos then oldDir else if num > oldPos then Down  else Up
  case astate of
    Dragging oldDir s old →
      H.put (Dragging (direction old oldDir) s $ toSet s)
    _ → pure unit
  pure next
eval _ (Animated next) = do
  astate ← H.get
  case astate of
    Opening _ → H.put Opened
    Closing _ → H.put Closed
    _ → pure unit
  H.get >>= raise ∘ H.action ∘ Notify
  pure next

eval _ (Notify _ next) =
  pure next


Type for Main

Type for Main

module Main where

import Views.Stack as Stack
import Views.Queue as Queue
import Views.Set as Set
import CodeSnippet as CS
import Prelude (bind, (/), ($), (<$>), const, pure, (<<<), (==), (<>), Unit)
import Pux (start, renderToDOM, EffModel, noEffects, mapState, mapEffects)
import Pux.Html as H
import Pux.Html.Attributes as HA
import Pux.Html.Events as HE
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Array ((:))
import Data.Either (Either(..))
import Data.Eq (class Eq)
import Data.Functor (map)
import Data.Maybe (Maybe(..))
import Data.Set (Set, insert, delete, empty, member)
import Debug.Trace (spy)
import Network.HTTP.Affjax (AJAX)
import Signal ((~>))
import Signal.Channel (CHANNEL)
import Signal.Time (every, second, Time())

data Page = StackPage
          | QueuePage
          | SetPage

derive instance eqPage :: Eq Page

type State = { stackModel :: Stack.Model
             , queueModel :: Queue.Model
             , setModel :: Set.Model
             , currPage :: Maybe Page
             , currLanguage :: CS.Language
             , availableLanguages :: Set CS.Language
             }

initialState :: State
initialState = { stackModel : Stack.initModel
               , queueModel : Queue.initModel
               , setModel : Set.initModel
               , currPage : Nothing
               , currLanguage : CS.Purescript
               , availableLanguages : empty
               }

data Action = ChangePage Page
            | ChangeLanguage CS.Language
            | PageCheck CS.Language (Either String CS.SourceCode)
            | StackAction Stack.Action
            | QueueAction Queue.Action
            | SetAction Set.Action
            | Tick Time

updateStack :: State -> Stack.Action
            -> EffModel State Action (channel :: CHANNEL, err :: EXCEPTION, ajax :: AJAX)
updateStack state staction =
  let
    updated = Stack.update staction state.stackModel
  in
   mapEffects StackAction $ mapState (\s -> state { stackModel = s}) $ updated

updateQueue :: State -> Queue.Action
            -> EffModel State Action (channel :: CHANNEL, err :: EXCEPTION, ajax :: AJAX)
updateQueue state quaction =
  let
    updated = Queue.update quaction state.queueModel
  in
   mapEffects QueueAction $ mapState (\s -> state { queueModel = s}) $ updated

updateSet :: State -> Set.Action
          -> EffModel State Action (channel :: CHANNEL, err :: EXCEPTION, ajax :: AJAX)
updateSet state saction =
  let
    updated = Set.update saction state.setModel
  in
   mapEffects SetAction $ mapState (\s -> state { setModel = s}) $ updated

getSource :: forall eff. Page -> CS.Language -> Aff (ajax :: AJAX | eff) Action
getSource StackPage lang =
  StackAction <<< Stack.LoadCode <$> CS.getFile "Stack" lang
getSource QueuePage lang =
  QueueAction <<< Queue.LoadCode <$> CS.getFile "Queue" lang
getSource SetPage lang =
  SetAction <<< Set.LoadCode <$> CS.getFile "Set" lang

checkSources :: forall eff. Page -> Array (Aff (ajax :: AJAX | eff) Action)
checkSources StackPage =
  map (\lang -> PageCheck lang <$> CS.getFile "Stack" lang) CS.allLangs
checkSources QueuePage =
  map (\lang -> PageCheck lang <$> CS.getFile "Queue" lang) CS.allLangs
checkSources SetPage =
  map (\lang -> PageCheck lang <$> CS.getFile "Set" lang) CS.allLangs

update :: Action -> State
       -> EffModel State Action _
update (PageCheck lang (Right code)) state =
   noEffects $ state { availableLanguages = insert lang state.availableLanguages}
update (PageCheck lang (Left err)) state =
   noEffects $ state { availableLanguages = delete lang state.availableLanguages}
update (ChangeLanguage lang) state =
  case state.currPage of
    Nothing -> noEffects $ state { currLanguage = lang }
    Just page ->
      { state: state { currLanguage = lang }
      , effects: pure $ getSource page lang
      }
update (ChangePage page) state =
  { state: state { currPage = Just page }
  , effects: getSource page state.currLanguage : checkSources page
  }
update (StackAction staction) state =
  updateStack state staction
update (QueueAction quaction) state =
  updateQueue state quaction
update (SetAction saction) state =
  updateSet state saction
update (Tick time) state =
  case state.currPage of
    Nothing -> noEffects state
    Just StackPage ->
      updateStack state (Stack.Tick time)
    Just QueuePage ->
      updateQueue state (Queue.Tick time)
    Just SetPage ->
      updateSet state (Set.Tick time)

dsBtn :: State -> String -> Page -> H.Html Action
dsBtn state name token =
  let
    baseClasses = "pure-button pure-button-primary"
    allClasses =
      case state.currPage of
        Nothing -> baseClasses
        Just page -> if page == token
                     then baseClasses <> " pure-button-active"
                     else baseClasses
  in
   H.button [ HA.className allClasses
            , HE.onClick (const $ ChangePage token)
            ] [ H.text name ]

langBtn :: State -> String -> CS.Language -> H.Html Action
langBtn state name token =
  let
    baseClasses = "pure-button pure-button-danger"
    allClasses = if state.currLanguage == token
                 then baseClasses <> " pure-button-active"
                 else if member token state.availableLanguages
                      then baseClasses
                      else baseClasses <> " pure-button-disabled"
  in
   H.button [ HA.className allClasses
            , HE. onClick (const $ ChangeLanguage token)
            ] [ H.text name ]

view :: State -> H.Html Action
view state =
  let
    dbf = dsBtn state
    lbf = langBtn state
    dataDiv = H.div [ HA.className "pure-u-1-1" ] [ dbf "Stack / List" StackPage
                                                  , dbf "Queue" QueuePage
                                                  , dbf "Set / Binary Tree" SetPage
                                                  ]
    langDiv = H.div [ HA.className "pure-u-1-1" ] [ lbf "Purescript" CS.Purescript
                                                  , lbf "Elm" CS.Elm
                                                  , lbf "Haskell" CS.Haskell
                                                  , lbf "Idris" CS.Idris
                                                  , lbf "Clojure" CS.Clojure
                                                  , lbf "Scheme" CS.Scheme
                                                  , lbf "Elixir" CS.Elixir
                                                  , lbf "Scala" CS.Scala
                                                  ]
    renderDiv =
      case state.currPage of
        Nothing -> H.div [ HA.className "pure-u-1-1" ] [ H.text "Please select a data structure"]
        Just StackPage -> StackAction <$> Stack.view state.stackModel
        Just QueuePage -> QueueAction <$> Queue.view state.queueModel
        Just SetPage -> SetAction <$> Set.view state.setModel
  in
   H.div [ ] [ dataDiv, langDiv, renderDiv ]

main :: Eff (channel :: CHANNEL, ajax :: AJAX, err :: EXCEPTION) Unit
main = do
  app <- start
    { initialState: initialState
    , update: update
    , view: view
    , inputs: [ every (second / 60.0) ~> Tick ]
    }
  renderToDOM "#app" app.html

module Main where

import Views.Stack as Stack
import Views.Queue as Queue
import Views.Set as Set
import CodeSnippet as CS
import Prelude (bind, (/), ($), (<$>), const, pure, (<<<), (==), (<>))
import Pux (start, renderToDOM, EffModel, noEffects, mapState, mapEffects)
import Pux.Html as H
import Pux.Html.Attributes as HA
import Pux.Html.Events as HE
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Array ((:))
import Data.Either (Either(..))
import Data.Eq (class Eq)
import Data.Functor (map)
import Data.Maybe (Maybe(..))
import Data.Set (Set, insert, delete, empty, member)
import Debug.Trace (spy)
import Network.HTTP.Affjax (AJAX)
import Signal ((~>))
import Signal.Channel (CHANNEL)
import Signal.Time (every, second, Time())

data Page = StackPage
          | QueuePage
          | SetPage

derive instance eqPage :: Eq Page

type State = { stackModel :: Stack.Model
             , queueModel :: Queue.Model
             , setModel :: Set.Model
             , currPage :: Maybe Page
             , currLanguage :: CS.Language
             , availableLanguages :: Set CS.Language
             }

initialState :: State
initialState = { stackModel : Stack.initModel
               , queueModel : Queue.initModel
               , setModel : Set.initModel
               , currPage : Nothing
               , currLanguage : CS.Purescript
               , availableLanguages : empty
               }

data Action = ChangePage Page
            | ChangeLanguage CS.Language
            | PageCheck CS.Language (Either String CS.SourceCode)
            | StackAction Stack.Action
            | QueueAction Queue.Action
            | SetAction Set.Action
            | Tick Time

updateStack :: State -> Stack.Action
            -> EffModel State Action (channel :: CHANNEL, err :: EXCEPTION, ajax :: AJAX)
updateStack state staction =
  let
    updated = Stack.update staction state.stackModel
  in
   mapEffects StackAction $ mapState (\s -> state { stackModel = s}) $ updated

updateQueue :: State -> Queue.Action
            -> EffModel State Action (channel :: CHANNEL, err :: EXCEPTION, ajax :: AJAX)
updateQueue state quaction =
  let
    updated = Queue.update quaction state.queueModel
  in
   mapEffects QueueAction $ mapState (\s -> state { queueModel = s}) $ updated

updateSet :: State -> Set.Action
          -> EffModel State Action (channel :: CHANNEL, err :: EXCEPTION, ajax :: AJAX)
updateSet state saction =
  let
    updated = Set.update saction state.setModel
  in
   mapEffects SetAction $ mapState (\s -> state { setModel = s}) $ updated

getSource :: forall eff. Page -> CS.Language -> Aff (ajax :: AJAX | eff) Action
getSource StackPage lang =
  StackAction <<< Stack.LoadCode <$> CS.getFile "Stack" lang
getSource QueuePage lang =
  QueueAction <<< Queue.LoadCode <$> CS.getFile "Queue" lang
getSource SetPage lang =
  SetAction <<< Set.LoadCode <$> CS.getFile "Set" lang

checkSources :: forall eff. Page -> Array (Aff (ajax :: AJAX | eff) Action)
checkSources StackPage =
  map (\lang -> PageCheck lang <$> CS.getFile "Stack" lang) CS.allLangs
checkSources QueuePage =
  map (\lang -> PageCheck lang <$> CS.getFile "Queue" lang) CS.allLangs
checkSources SetPage =
  map (\lang -> PageCheck lang <$> CS.getFile "Set" lang) CS.allLangs

update :: Action -> State
       -> EffModel State Action _
update (PageCheck lang (Right code)) state =
   noEffects $ state { availableLanguages = insert lang state.availableLanguages}
update (PageCheck lang (Left err)) state =
   noEffects $ state { availableLanguages = delete lang state.availableLanguages}
update (ChangeLanguage lang) state =
  case state.currPage of
    Nothing -> noEffects $ state { currLanguage = lang }
    Just page ->
      { state: state { currLanguage = lang }
      , effects: pure $ getSource page lang
      }
update (ChangePage page) state =
  { state: state { currPage = Just page }
  , effects: getSource page state.currLanguage : checkSources page
  }
update (StackAction staction) state =
  updateStack state staction
update (QueueAction quaction) state =
  updateQueue state quaction
update (SetAction saction) state =
  updateSet state saction
update (Tick time) state =
  case state.currPage of
    Nothing -> noEffects state
    Just StackPage ->
      updateStack state (Stack.Tick time)
    Just QueuePage ->
      updateQueue state (Queue.Tick time)
    Just SetPage ->
      updateSet state (Set.Tick time)

dsBtn :: State -> String -> Page -> H.Html Action
dsBtn state name token =
  let
    baseClasses = "pure-button pure-button-primary"
    allClasses =
      case state.currPage of
        Nothing -> baseClasses
        Just page -> if page == token
                     then baseClasses <> " pure-button-active"
                     else baseClasses
  in
   H.button [ HA.className allClasses
            , HE.onClick (const $ ChangePage token)
            ] [ H.text name ]

langBtn :: State -> String -> CS.Language -> H.Html Action
langBtn state name token =
  let
    baseClasses = "pure-button pure-button-danger"
    allClasses = if state.currLanguage == token
                 then baseClasses <> " pure-button-active"
                 else if member token state.availableLanguages
                      then baseClasses
                      else baseClasses <> " pure-button-disabled"
  in
   H.button [ HA.className allClasses
            , HE. onClick (const $ ChangeLanguage token)
            ] [ H.text name ]

view :: State -> H.Html Action
view state =
  let
    dbf = dsBtn state
    lbf = langBtn state
    dataDiv = H.div [ HA.className "pure-u-1-1" ] [ dbf "Stack / List" StackPage
                                                  , dbf "Queue" QueuePage
                                                  , dbf "Set / Binary Tree" SetPage
                                                  ]
    langDiv = H.div [ HA.className "pure-u-1-1" ] [ lbf "Purescript" CS.Purescript
                                                  , lbf "Elm" CS.Elm
                                                  , lbf "Haskell" CS.Haskell
                                                  , lbf "Idris" CS.Idris
                                                  , lbf "Clojure" CS.Clojure
                                                  , lbf "Scheme" CS.Scheme
                                                  , lbf "Elixir" CS.Elixir
                                                  , lbf "Scala" CS.Scala
                                                  ]
    renderDiv =
      case state.currPage of
        Nothing -> H.div [ HA.className "pure-u-1-1" ] [ H.text "Please select a data structure"]
        Just StackPage -> StackAction <$> Stack.view state.stackModel
        Just QueuePage -> QueueAction <$> Queue.view state.queueModel
        Just SetPage -> SetAction <$> Set.view state.setModel
  in
   H.div [ ] [ dataDiv, langDiv, renderDiv ]

main = do
  app <- start
    { initialState: initialState
    , update: update
    , view: view
    , inputs: [ every (second / 60.0) ~> Tick ]
    }
  renderToDOM "#app" app.html


k, but tooltip is formatted

k, but tooltip is formatted

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Setups.Chart.Candlestick.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.Candlestick.Model
  ) where

import SlamData.Prelude

import Data.Argonaut (JArray, Json, decodeJson, (.?))
import Data.Array as A
import Data.List as L
import Data.Lens ((^?))
import Data.Map as M

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)

import SlamData.Workspace.Card.CardType.ChartType (ChartType(Candlestick))
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis (Axes)
import SlamData.Workspace.Card.Setups.Axis as Ax
import SlamData.Workspace.Card.Setups.Chart.Candlestick.Model (ModelR, Model)
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors)
import SlamData.Workspace.Card.Setups.Chart.Common as SCC
import SlamData.Workspace.Card.Setups.Chart.Common.Positioning as BCP
--import SlamData.Workspace.Card.Setups.Chart.Common.Tooltip as CCT
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics as Sem
--import SlamData.Workspace.Card.Setups.Transform as T
--import SlamData.Workspace.Card.Setups.Transform.Aggregation as Ag

import SqlSquare as Sql

import Utils.Foldable (enumeratedFor_)

type Item =
  { dimension ∷ String
  , high ∷ Number
  , low ∷ Number
  , open ∷ Number
  , close ∷ Number
  , parallel ∷ Maybe String
  }

decodeItem ∷ Json → String ⊹ Item
decodeItem = decodeJson >=> \obj → do
  dimension ← map (fromMaybe "" ∘ Sem.maybeString) $ obj .? "dimension"
  high ← map (fromMaybe zero ∘ Sem.maybeNumber) $ obj .? "high"
  low ← map (fromMaybe zero ∘ Sem.maybeNumber) $ obj .? "low"
  open ← map (fromMaybe zero ∘ Sem.maybeNumber) $ obj .? "open"
  close ← map (fromMaybe zero ∘ Sem.maybeNumber) $ obj .? "close"
  parallel ← map Sem.maybeString $ obj .? "parallel"
  pure { dimension, high, low, open, close, parallel }

eval ∷ ∀ m. BCE.ChartSetupEval ModelR m
eval = BCE.chartSetupEval (SCC.buildBasicSql buildProjections buildGroupBy) buildCandlestick

buildProjections ∷ ModelR → L.List (Sql.Projection Sql.Sql)
buildProjections r = L.fromFoldable
  [ r.dimension # SCC.jcursorPrj # Sql.as "dimension"
  , r.high # SCC.jcursorPrj # Sql.as "high" # SCC.applyTransform r.high
  , r.low # SCC.jcursorPrj # Sql.as "low" # SCC.applyTransform r.low
  , r.open # SCC.jcursorPrj # Sql.as "open" # SCC.applyTransform r.open
  , r.close # SCC.jcursorPrj # Sql.as "close" # SCC.applyTransform r.close
  , r.parallel # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "parallel"
  ]

buildGroupBy ∷ ModelR → Maybe (Sql.GroupBy Sql.Sql)
buildGroupBy r =
  SCC.groupBy $ L.fromFoldable $ A.catMaybes
    [ r.parallel <#> SCC.jcursorSql
    , Just $ r.dimension # SCC.jcursorSql
    ]

buildCandlestick ∷ ModelR → Axes → JArray → Port.Port
buildCandlestick m axes jarr =
  Port.ChartInstructions
    { options: kOptions axes m $ buildKData jarr
    , chartType: Candlestick
    }

type HLOC a =
  { low ∷ a
  , high ∷ a
  , open ∷ a
  , close ∷ a
  }

type Series = String >> HLOC Number

type OnOneGrid =
  { w ∷ Maybe Number
  , h ∷ Maybe Number
  , x ∷ Maybe Number
  , y ∷ Maybe Number
  , name ∷ Maybe String
  , fontSize ∷ Maybe Int
  , items ∷ Series
  }

buildKData ∷ JArray → Array OnOneGrid
buildKData =
  BCP.adjustRectangularPositions
  ∘ oneGrids
  ∘ foldMap (foldMap A.singleton ∘ decodeItem)
  where
  oneGrids ∷ Array Item → Array OnOneGrid
  oneGrids =
    BCE.groupOn _.parallel
      ⋙ map \(name × is) →
        { name
        , x: Nothing
        , y: Nothing
        , w: Nothing
        , h: Nothing
        , fontSize: Nothing
        , items: M.fromFoldable $ map toPoint is
        }
  toPoint ∷ Item → String × HLOC Number
  toPoint {dimension, high, low, open, close } =
    dimension × { high, low, open, close }

kOptions ∷ Axes → ModelR → Array OnOneGrid → DSL OptionI
kOptions axes r kData = do
  E.tooltip do
    E.triggerAxis
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12
{-    E.formatterAxis $ foldMap \fmt →
      CCT.tableRows
        [ D.jcursorLabel r.dimension × fmt.name
        , D.jcursorLabel r.open × CCT.formatValueIx 0 fmt
        , D.jcursorLabel r.close × CCT.formatValueIx 1 fmt
        , D.jcursorLabel r.low × CCT.formatValueIx 2 fmt
        , D.jcursorLabel r.high × CCT.formatValueIx 3 fmt
        ]
-}
  BCP.rectangularTitles kData
  BCP.rectangularGrids kData

  E.colors colors

  E.xAxes xAxes
  E.yAxes yAxes
  E.series series

  where
  xValues ∷ OnOneGrid → Array String
  xValues  = sortX ∘ foldMap A.singleton ∘ M.keys ∘ _.items

  xAxisType ∷ Ax.AxisType
  xAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType <$> (r.dimension ^? D._value ∘ D._projection) <*> pure axes

  sortX ∷ Array String → Array String
  sortX = A.sortBy $ Ax.compareWithAxisType xAxisType

  xAxes = enumeratedFor_ kData \(ix × serie) → E.addXAxis do
    E.gridIndex ix
    E.axisType ET.Category
    E.axisLabel $ E.textStyle $ E.fontFamily "Ubuntu, sans"
    E.items $ map ET.strItem $ xValues serie

  yAxes = enumeratedFor_ kData \(ix × _) → E.addYAxis do
    E.gridIndex ix
    E.axisType ET.Value

  series = enumeratedFor_  kData \(ix × serie) → E.candlestick do
    for_ serie.name E.name
    E.xAxisIndex ix
    E.yAxisIndex ix
    E.buildItems $ for_ (xValues serie) \dim →
      for_ (M.lookup dim serie.items) \{high, low, open, close} → E.addItem $ E.buildValues do
        E.addValue open
        E.addValue close
        E.addValue low
        E.addValue high

{-
buildCandlestickData ∷ ModelR → JArray → CandlestickData
buildCandlestickData r records = series
  where
  dataMap ∷ Maybe String >> String >> HLOC (Array Number)
  dataMap =
    foldl dataMapFoldFn Map.empty records

  dataMapFoldFn
    ∷ Maybe String >> String >> HLOC (Array Number)
    → Json
    → Maybe String >> String >> HLOC (Array Number)
  dataMapFoldFn acc js =
    let
      getMaybeString = Sem.getMaybeString js
      getValues = Sem.getValues js
    in case getMaybeString =<< (r.dimension ^? D._value ∘ D._projection)  of
      Nothing → acc
      Just dimKey →
        let
          high =
            getValues $ r.high ^? D._value ∘ D._projection
          low =
            getValues $ r.low ^? D._value ∘ D._projection
          open =
            getValues $ r.open ^? D._value ∘ D._projection
          close =
            getValues $ r.close ^? D._value ∘ D._projection

          hloc = {high, low, open, close}

          mbParallel =
            getMaybeString =<< (preview $ D._value ∘ D._projection) =<< r.parallel

          alterParallelFn
            ∷ Maybe (String >> HLOC (Array Number))
            → Maybe (String >> HLOC (Array Number))
          alterParallelFn Nothing =
            Just $ Map.singleton dimKey hloc
          alterParallelFn (Just parallel) =
            Just $ Map.alter alterDimFn dimKey parallel

          alterDimFn
            ∷ Maybe (HLOC (Array Number))
            → Maybe (HLOC (Array Number))
          alterDimFn Nothing = Just $ hloc
          alterDimFn (Just r') =
            Just { high: high ⊕ r'.high
                 , low: low ⊕ r'.low
                 , open: open ⊕ r'.open
                 , close: close ⊕ r'.close
                 }
        in
          Map.alter alterParallelFn mbParallel acc

  rawSeries ∷ CandlestickData
  rawSeries =
    foldMap mkOneGridData $ Map.toList dataMap

  mkOneGridData
    ∷ Maybe String × (String >> HLOC (Array Number))
    → Array OnOneGrid
  mkOneGridData (name × mp) =
    [ { x: Nothing
      , y: Nothing
      , w: Nothing
      , h: Nothing
      , fontSize: Nothing
      , name
      , items: map aggregateHLOC mp
      } ]

  aggregateHLOC ∷ HLOC (Array Number) → HLOC Number
  aggregateHLOC rr =
    { high:
        flip Ag.runAggregation rr.high
        $ fromMaybe Ag.Sum $ r.high ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation
    , low:
        flip Ag.runAggregation rr.low
        $ fromMaybe Ag.Sum $ r.low ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation
    , open:
        flip Ag.runAggregation rr.open
        $ fromMaybe Ag.Sum $ r.open ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation
    , close:
        flip Ag.runAggregation rr.close
        $ fromMaybe Ag.Sum $ r.close ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation
    }

  series ∷ CandlestickData
  series = BCP.adjustRectangularPositions rawSeries

buildCandlestick ∷ Ax.Axes → ModelR → JArray → DSL OptionI
buildCandlestick axes r records = do
-}

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Setups.Chart.Candlestick.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.Candlestick.Model
  ) where

import SlamData.Prelude

import Data.Argonaut (JArray, Json, decodeJson, (.?))
import Data.Array as A
import Data.List as L

import ECharts.Monad (DSL)
--import ECharts.Commands as E
--import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)

import SlamData.Workspace.Card.CardType.ChartType (ChartType(Candlestick))
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis (Axes)
import SlamData.Workspace.Card.Setups.Chart.Candlestick.Model (ModelR, Model)
--import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors)
import SlamData.Workspace.Card.Setups.Chart.Common as SCC
--import SlamData.Workspace.Card.Setups.Chart.Common.Positioning as BCP
--import SlamData.Workspace.Card.Setups.Chart.Common.Tooltip as CCT
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
--import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics as Sem
--import SlamData.Workspace.Card.Setups.Transform as T
--import SlamData.Workspace.Card.Setups.Transform.Aggregation as Ag

import SqlSquare as Sql

--import Utils.Foldable (enumeratedFor_)

type Item =
  { dimension ∷ String
  , high ∷ Number
  , low ∷ Number
  , open ∷ Number
  , close ∷ Number
  , parallel ∷ Maybe String
  }

decodeItem ∷ Json → String ⊹ Item
decodeItem = decodeJson >=> \obj → do
  dimension ← map (fromMaybe "" ∘ Sem.maybeString) $ obj .? "dimension"
  high ← map (fromMaybe zero ∘ Sem.maybeNumber) $ obj .? "high"
  low ← map (fromMaybe zero ∘ Sem.maybeNumber) $ obj .? "low"
  open ← map (fromMaybe zero ∘ Sem.maybeNumber) $ obj .? "open"
  close ← map (fromMaybe zero ∘ Sem.maybeNumber) $ obj .? "close"
  parallel ← map Sem.maybeString $ obj .? "parallel"
  pure { dimension, high, low, open, close, parallel }

eval ∷ ∀ m. BCE.ChartSetupEval ModelR m
eval = BCE.chartSetupEval (SCC.buildBasicSql buildProjections buildGroupBy) buildCandlestick

buildProjections ∷ ModelR → L.List (Sql.Projection Sql.Sql)
buildProjections r = L.fromFoldable
  [ r.dimension # SCC.jcursorPrj # Sql.as "dimension"
  , r.high # SCC.jcursorPrj # Sql.as "high" # SCC.applyTransform r.high
  , r.low # SCC.jcursorPrj # Sql.as "low" # SCC.applyTransform r.low
  , r.open # SCC.jcursorPrj # Sql.as "open" # SCC.applyTransform r.open
  , r.close # SCC.jcursorPrj # Sql.as "close" # SCC.applyTransform r.close
  , r.parallel # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "parallel"
  ]

buildGroupBy ∷ ModelR → Maybe (Sql.GroupBy Sql.Sql)
buildGroupBy r =
  SCC.groupBy $ L.fromFoldable $ A.catMaybes
    [ r.parallel <#> SCC.jcursorSql
    , Just $ r.dimension # SCC.jcursorSql
    ]

buildCandlestick ∷ ModelR → Axes → JArray → Port.Port
buildCandlestick m axes jarr =
  Port.ChartInstructions
    { options: kOptions axes m $ buildKData jarr
    , chartType: Candlestick
    }

type HLOC a =
  { low ∷ a
  , high ∷ a
  , open ∷ a
  , close ∷ a
  }

type Series = String >> HLOC Number

type OnOneGrid =
  { w ∷ Maybe Number
  , h ∷ Maybe Number
  , x ∷ Maybe Number
  , y ∷ Maybe Number
  , name ∷ Maybe String
  , fontSize ∷ Maybe Int
  , items ∷ Series
  }

buildKData ∷ JArray → Array OnOneGrid
buildKData _ = [ ]

kOptions ∷ Axes → ModelR → Array OnOneGrid → DSL OptionI
kOptions axes r kData =
  pure unit
{-
buildCandlestickData ∷ ModelR → JArray → CandlestickData
buildCandlestickData r records = series
  where
  dataMap ∷ Maybe String >> String >> HLOC (Array Number)
  dataMap =
    foldl dataMapFoldFn Map.empty records

  dataMapFoldFn
    ∷ Maybe String >> String >> HLOC (Array Number)
    → Json
    → Maybe String >> String >> HLOC (Array Number)
  dataMapFoldFn acc js =
    let
      getMaybeString = Sem.getMaybeString js
      getValues = Sem.getValues js
    in case getMaybeString =<< (r.dimension ^? D._value ∘ D._projection)  of
      Nothing → acc
      Just dimKey →
        let
          high =
            getValues $ r.high ^? D._value ∘ D._projection
          low =
            getValues $ r.low ^? D._value ∘ D._projection
          open =
            getValues $ r.open ^? D._value ∘ D._projection
          close =
            getValues $ r.close ^? D._value ∘ D._projection

          hloc = {high, low, open, close}

          mbParallel =
            getMaybeString =<< (preview $ D._value ∘ D._projection) =<< r.parallel

          alterParallelFn
            ∷ Maybe (String >> HLOC (Array Number))
            → Maybe (String >> HLOC (Array Number))
          alterParallelFn Nothing =
            Just $ Map.singleton dimKey hloc
          alterParallelFn (Just parallel) =
            Just $ Map.alter alterDimFn dimKey parallel

          alterDimFn
            ∷ Maybe (HLOC (Array Number))
            → Maybe (HLOC (Array Number))
          alterDimFn Nothing = Just $ hloc
          alterDimFn (Just r') =
            Just { high: high ⊕ r'.high
                 , low: low ⊕ r'.low
                 , open: open ⊕ r'.open
                 , close: close ⊕ r'.close
                 }
        in
          Map.alter alterParallelFn mbParallel acc

  rawSeries ∷ CandlestickData
  rawSeries =
    foldMap mkOneGridData $ Map.toList dataMap

  mkOneGridData
    ∷ Maybe String × (String >> HLOC (Array Number))
    → Array OnOneGrid
  mkOneGridData (name × mp) =
    [ { x: Nothing
      , y: Nothing
      , w: Nothing
      , h: Nothing
      , fontSize: Nothing
      , name
      , items: map aggregateHLOC mp
      } ]

  aggregateHLOC ∷ HLOC (Array Number) → HLOC Number
  aggregateHLOC rr =
    { high:
        flip Ag.runAggregation rr.high
        $ fromMaybe Ag.Sum $ r.high ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation
    , low:
        flip Ag.runAggregation rr.low
        $ fromMaybe Ag.Sum $ r.low ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation
    , open:
        flip Ag.runAggregation rr.open
        $ fromMaybe Ag.Sum $ r.open ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation
    , close:
        flip Ag.runAggregation rr.close
        $ fromMaybe Ag.Sum $ r.close ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation
    }

  series ∷ CandlestickData
  series = BCP.adjustRectangularPositions rawSeries

buildCandlestick ∷ Ax.Axes → ModelR → JArray → DSL OptionI
buildCandlestick axes r records = do
  E.tooltip do
    E.triggerAxis
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12
    E.formatterAxis $ foldMap \fmt →
      CCT.tableRows
        [ D.jcursorLabel r.dimension × fmt.name
        , D.jcursorLabel r.open × CCT.formatValueIx 0 fmt
        , D.jcursorLabel r.close × CCT.formatValueIx 1 fmt
        , D.jcursorLabel r.low × CCT.formatValueIx 2 fmt
        , D.jcursorLabel r.high × CCT.formatValueIx 3 fmt
        ]

  BCP.rectangularTitles candlestickData
  BCP.rectangularGrids candlestickData

  E.colors colors

  E.xAxes xAxes
  E.yAxes yAxes
  E.series series

  where
  candlestickData ∷ CandlestickData
  candlestickData = buildCandlestickData r records

  xValues ∷ OnOneGrid → Array String
  xValues  = sortX ∘ foldMap A.singleton ∘ Map.keys ∘ _.items

  xAxisType ∷ Ax.AxisType
  xAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType <$> (r.dimension ^? D._value ∘ D._projection) <*> pure axes

  sortX ∷ Array String → Array String
  sortX = A.sortBy $ Ax.compareWithAxisType xAxisType

  xAxes = enumeratedFor_ candlestickData \(ix × serie) → E.addXAxis do
    E.gridIndex ix
    E.axisType ET.Category
    E.axisLabel $ E.textStyle $ E.fontFamily "Ubuntu, sans"
    E.items $ map ET.strItem $ xValues serie

  yAxes = enumeratedFor_ candlestickData \(ix × _) → E.addYAxis do
    E.gridIndex ix
    E.axisType ET.Value

  series = enumeratedFor_  candlestickData \(ix × serie) → E.candlestick do
    for_ serie.name E.name
    E.xAxisIndex ix
    E.yAxisIndex ix
    E.buildItems $ for_ (xValues serie) \dim →
      for_ (Map.lookup dim serie.items) \{high, low, open, close} → E.addItem $ E.buildValues do
        E.addValue open
        E.addValue close
        E.addValue low
        E.addValue high
-}