Make tag value optional

Make tag value optional

module Language.Docopt.Parser.Lexer where

import Debug.Trace
import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import Control.Plus (empty)
import Control.Monad.State (State(), evalState, get)
import Control.Monad.Trans
import Data.Foldable (foldl)
import Data.String as Str
import Text.Parsing.Parser as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Token as P
import Text.Parsing.Parser.Pos as P
import Text.Parsing.Parser.String as P
import Data.List as L
import Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray, fromChar, trim)
import Data.List (List(..), (:), fromList, many)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Language.Docopt.Parser.Base
import Language.Docopt.Parser.State
import Data.Tuple
import Data.Int
import Data.Int as I
import Global (isNaN, readFloat)

lex :: String -> Either P.ParseError (List PositionedToken)
lex = flip P.runParser parseTokens

data NumberLiteral = FloatLiteral Number | IntLiteral Int

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | LAngle
  | RAngle
  | Dash
  | VBar
  | Colon
  | Comma
  | Equal
  | TripleDot
  | LOpt String (Maybe String)
  | SOpt Char (Array Char) (Maybe String)
  | Tag String (Maybe String)
  | Name String
  | ShoutName String
  | AngleName String
  | Word String
  | StringLiteral String
  | NumberLiteral NumberLiteral
  | Garbage Char
  | DoubleDash

prettyPrintToken :: Token -> String
prettyPrintToken LParen            = show '('
prettyPrintToken RParen            = show ')'
prettyPrintToken LSquare           = show '['
prettyPrintToken RSquare           = show ']'
prettyPrintToken LAngle            = show '<'
prettyPrintToken RAngle            = show '>'
prettyPrintToken Dash              = show '-'
prettyPrintToken VBar              = show '|'
prettyPrintToken Colon             = show ':'
prettyPrintToken Comma             = show ','
prettyPrintToken Equal             = show '='
prettyPrintToken TripleDot         = "..."
prettyPrintToken DoubleDash        = "--"
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 (StringLiteral s) = "String "    ++ show s
prettyPrintToken (NumberLiteral n) = "Number "    ++ show n
prettyPrintToken (Word w)          = "Word "      ++ show w
prettyPrintToken (LOpt n a)        = "--" ++ n
                                          ++ " " ++ (show a)
prettyPrintToken (SOpt n s a)      = "-"  ++ (fromCharArray (A.cons n s))
                                          ++ " " ++ (show a)

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

instance eqNumberLiteral :: Eq NumberLiteral where
  eq (FloatLiteral n) (FloatLiteral n') = eq n n'
  eq (IntLiteral n)   (IntLiteral n')   = eq n n'

instance showNumberLiteral :: Show NumberLiteral where
  show (FloatLiteral n) = show n
  show (IntLiteral n)   = show n

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 LAngle            LAngle             = true
  eq RAngle            RAngle             = true
  eq VBar              VBar               = true
  eq Colon             Colon              = true
  eq Comma             Comma              = true
  eq Dash              Dash               = true
  eq Equal             Equal              = true
  eq DoubleDash        DoubleDash         = true
  eq TripleDot         TripleDot          = true
  eq (LOpt n a)        (LOpt n' a')       = (n == n') && (a == a')
  eq (SOpt n s a)      (SOpt n' s' a')    = (n == n') && (s' == s') && (a == a')
  eq (StringLiteral s) (StringLiteral s') = s == s'
  eq (AngleName n)     (AngleName n')     = n == n'
  eq (ShoutName n)     (ShoutName n')     = n == n'
  eq (Word w)          (Word w')          = w == w'
  eq (Name n)          (Name n')          = n == n'
  eq (Garbage c)       (Garbage c')       = c == c'
  eq (NumberLiteral n) (NumberLiteral n') = n == n'
  eq _ _                                  = false

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

parseTokens :: P.Parser String (L.List PositionedToken)
parseTokens = do
  P.skipSpaces
  L.many parsePositionedToken
  <* P.eof

parsePositionedToken :: P.Parser String PositionedToken
parsePositionedToken = P.try $ do
  pos <- getPosition
  tok <- parseToken
  return $ PositionedToken { sourcePos: pos, token: tok }

parseToken :: P.Parser String Token
parseToken = P.choice
  [ P.try $ P.char   '('   *> pure LParen
  , P.try $ P.char   ')'   *> pure RParen
  , P.try $ tag
  , P.try $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '|'   *> pure VBar
  , P.try $ P.char   ':'   *> pure Colon
  , P.try $ P.char   ','   *> pure Comma
  , P.try $ longOption
  , P.try $ shortOption
  , P.try $ AngleName <$> angleName
  , P.try $ P.char   '<'   *> pure LAngle
  , P.try $ P.char   '>'   *> pure RAngle
  , P.try $ P.string "--"  *> pure DoubleDash
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.char   '='   *> pure Equal
  , P.try $ P.string "..." *> pure TripleDot
  , P.try $ numberLiteral
  , P.try $ stringLiteral
  , P.try $ ShoutName <$> (shoutName <* P.notFollowedBy alpha)
  , P.try $ Name      <$> (name      <* P.notFollowedBy alpha)
  , P.try $ Word      <$> (word      <* space)
  , P.try $ Garbage   <$> P.anyChar
  ]
  <* P.skipSpaces

 where

  whitespace :: P.Parser String Unit
  whitespace = do
    P.satisfy \c -> c == '\n' || c == '\r' || c == ' ' || c == '\t'
    pure unit

  tag :: P.Parser String Token
  tag =
    P.between
      (P.char '[')
      (P.char ']')
      (withValue <|> withoutValue)

    where
      withValue = do
        many whitespace
        k <- fromCharArray <$> do A.many (P.noneOf [':'])
        P.char ':'
        many whitespace
        v <- trim <<< fromCharArray <$> do A.some $ P.noneOf [']']
        many whitespace
        return (Tag k (Just v))
      withoutValue = do
        k <- trim <<< fromCharArray <$> do A.some $ P.noneOf [']']
        return (Tag k Nothing)

  stringLiteral :: P.Parser String Token
  stringLiteral = StringLiteral <$> do
    P.choice [
      P.between (P.char '\'') (P.char '\'') (p '\'')
    , P.between (P.char '"') (P.char '"') (p '"')
    ]
    where
      p :: Char -> P.Parser String String
      p c = fromCharArray <$> do
        A.many $ P.noneOf [c]

  numberLiteral :: P.Parser String Token
  numberLiteral = NumberLiteral <$> do
    P.choice [
      P.try $ FloatLiteral <$> floatLiteral
    , P.try $ IntLiteral   <$> intLiteral
    ]
    where
      floatLiteral = do
        x <- fromCharArray <$> (A.some num)
        P.char '.'
        xs <- fromCharArray <$> (A.some num)

        -- there is no "safe" version yet, afaik
        let n = readFloat $ x ++ "." ++ xs
        if isNaN n
           then P.fail "Could not parse float"
           else pure n

      intLiteral = do
        x <- fromCharArray <$> (A.some num)
        case (I.fromString x) of
          Just n  -> return n
          Nothing -> P.fail "Could not parse integer"

  name :: P.Parser String String
  name = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> A.many identLetter

  word :: P.Parser String String
  word = fromCharArray <$> do
    (A.some $ P.choice [
      identLetter
    , P.oneOf [ '.', '-', '_' ]
    ])

  angleName :: P.Parser String String
  angleName = do
    P.char '<'
    name <- fromCharArray <$> do
      A.some $ P.choice [
        identLetter
      , P.oneOf [ '-', '|', ':', '[', ']', '(', ')' ]
      ]
    P.char '>'
    pure name

  shoutName :: P.Parser String String
  shoutName = do
    name <- fromCharArray <$> do
      A.cons
        <$> upperAlpha
        <*> (A.many $ regex "[A-Z_-]")
    P.notFollowedBy lowerAlpha
    pure name

  shortOption :: P.Parser String Token
  shortOption = do
    P.char '-'
    x  <- alphaNum
    xs <- A.many alphaNum
    arg <- P.choice [

      -- Parse <flag>=<value>, i.e.: `-foo=bar`
      P.try $ Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        P.choice [
          P.try angleName
        , P.try shoutName
        , P.try name
        ]

      -- Parse <flag><VALUE>, i.e.: `-foo<bar>`
    , P.try $ Just <$> angleName

      -- Otherwise assume no argument given. We might be proven wrong at a later
      -- stage (parsing / solving), but as far as the lexer is concerned, this
      -- token bears no arguments.
    , pure Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.lookAhead $ P.choice [
      P.eof
    , P.try $ void $ P.whiteSpace
    , P.try $ void $ P.char ','
    , P.try $ void $ P.char '|'
    , P.try $ void $ P.char '['
    , P.try $ void $ P.char '('
    , P.try $ void $ P.string "..."
    ]

    pure $ SOpt x xs arg

  longOption :: P.Parser String Token
  longOption = do
    P.string "--"
    name' <- fromCharArray <$> do
      A.cons
        <$> alphaNum
        <*> (A.many $ P.choice [
              alphaNum
            , P.oneOf [ '-' ] <* P.lookAhead alphaNum
            ])
    arg <- P.choice [

      -- Parse <flag>=<value>, i.e.: `--foo=bar`
      P.try $ Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        P.choice [
          P.try angleName
        , P.try shoutName
        , P.try name
        ]

      -- Parse <flag><VALUE>, i.e.: `-foo<bar>`
    , P.try $ Just <$> angleName

      -- Otherwise assume no argument given. We might be proven wrong at a later
      -- stage (parsing / solving), but as far as the lexer is concerned, this
      -- token bears no arguments.
    , pure Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.lookAhead $ P.choice [
      P.eof
    , P.try $ void $ P.whiteSpace
    , P.try $ void $ P.char ','
    , P.try $ void $ P.char '|'
    , P.try $ void $ P.char '['
    , P.try $ void $ P.char '('
    , P.try $ void $ P.string "..."
    ]

    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 }) ->
  return $ 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 :: forall a. Token -> TokenParser Unit
match tok = token (\tok' -> if (tok' == tok) then Just unit else Nothing)
            P.<?> prettyPrintToken tok

anyToken = token $ Just

eof :: TokenParser Unit
eof = P.notFollowedBy anyToken

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

langle :: TokenParser Unit
langle = match LAngle

rangle :: TokenParser Unit
rangle = match RAngle

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

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

equal :: TokenParser Unit
equal = match Equal

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

lopt :: TokenParser { name :: String
                    , arg  :: Maybe String }
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 String }
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.<?> "default"
  where
    go (Tag k (Just v)) | Str.toUpper k == Str.toUpper s = Just v
    go _                                                 = Nothing

word :: TokenParser String
word = token go P.<?> "word"
  where
    go (Word n) = Just n
    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

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.Parser.Lexer where

import Debug.Trace
import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import Control.Plus (empty)
import Control.Monad.State (State(), evalState, get)
import Control.Monad.Trans
import Data.Foldable (foldl)
import Data.String as Str
import Text.Parsing.Parser as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Token as P
import Text.Parsing.Parser.Pos as P
import Text.Parsing.Parser.String as P
import Data.List as L
import Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray, fromChar, trim)
import Data.List (List(..), (:), fromList, many)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Language.Docopt.Parser.Base
import Language.Docopt.Parser.State
import Data.Tuple
import Data.Int
import Data.Int as I
import Global (isNaN, readFloat)

lex :: String -> Either P.ParseError (List PositionedToken)
lex = flip P.runParser parseTokens

data NumberLiteral = FloatLiteral Number | IntLiteral Int

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | LAngle
  | RAngle
  | Dash
  | VBar
  | Colon
  | Comma
  | Equal
  | TripleDot
  | LOpt String (Maybe String)
  | SOpt Char (Array Char) (Maybe String)
  | Tag String String
  | Name String
  | ShoutName String
  | AngleName String
  | Word String
  | StringLiteral String
  | NumberLiteral NumberLiteral
  | Garbage Char
  | DoubleDash

prettyPrintToken :: Token -> String
prettyPrintToken LParen            = show '('
prettyPrintToken RParen            = show ')'
prettyPrintToken LSquare           = show '['
prettyPrintToken RSquare           = show ']'
prettyPrintToken LAngle            = show '<'
prettyPrintToken RAngle            = show '>'
prettyPrintToken Dash              = show '-'
prettyPrintToken VBar              = show '|'
prettyPrintToken Colon             = show ':'
prettyPrintToken Comma             = show ','
prettyPrintToken Equal             = show '='
prettyPrintToken TripleDot         = "..."
prettyPrintToken DoubleDash        = "--"
prettyPrintToken (Garbage   c)     = "Garbage "   ++ show c
prettyPrintToken (Tag k v)         = "Tag "       ++ k ++ " "  ++ v
prettyPrintToken (Name      n)     = "Name "      ++ show n
prettyPrintToken (ShoutName n)     = "ShoutName " ++ show n
prettyPrintToken (AngleName n)     = "AngleName " ++ show n
prettyPrintToken (StringLiteral s) = "String "    ++ show s
prettyPrintToken (NumberLiteral n) = "Number "    ++ show n
prettyPrintToken (Word w)          = "Word "      ++ show w
prettyPrintToken (LOpt n a)        = "--" ++ n
                                          ++ " " ++ (show a)
prettyPrintToken (SOpt n s a)      = "-"  ++ (fromCharArray (A.cons n s))
                                          ++ " " ++ (show a)

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

instance eqNumberLiteral :: Eq NumberLiteral where
  eq (FloatLiteral n) (FloatLiteral n') = eq n n'
  eq (IntLiteral n)   (IntLiteral n')   = eq n n'

instance showNumberLiteral :: Show NumberLiteral where
  show (FloatLiteral n) = show n
  show (IntLiteral n)   = show n

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 LAngle            LAngle             = true
  eq RAngle            RAngle             = true
  eq VBar              VBar               = true
  eq Colon             Colon              = true
  eq Comma             Comma              = true
  eq Dash              Dash               = true
  eq Equal             Equal              = true
  eq DoubleDash        DoubleDash         = true
  eq TripleDot         TripleDot          = true
  eq (LOpt n a)        (LOpt n' a')       = (n == n') && (a == a')
  eq (SOpt n s a)      (SOpt n' s' a')    = (n == n') && (s' == s') && (a == a')
  eq (StringLiteral s) (StringLiteral s') = s == s'
  eq (AngleName n)     (AngleName n')     = n == n'
  eq (ShoutName n)     (ShoutName n')     = n == n'
  eq (Word w)          (Word w')          = w == w'
  eq (Name n)          (Name n')          = n == n'
  eq (Garbage c)       (Garbage c')       = c == c'
  eq (NumberLiteral n) (NumberLiteral n') = n == n'
  eq _ _                                  = false

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

parseTokens :: P.Parser String (L.List PositionedToken)
parseTokens = do
  P.skipSpaces
  L.many parsePositionedToken
  <* P.eof

parsePositionedToken :: P.Parser String PositionedToken
parsePositionedToken = P.try $ do
  pos <- getPosition
  tok <- parseToken
  return $ PositionedToken { sourcePos: pos, token: tok }

parseToken :: P.Parser String Token
parseToken = P.choice
  [ P.try $ P.char   '('   *> pure LParen
  , P.try $ P.char   ')'   *> pure RParen
  , P.try $ tag
  , P.try $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '|'   *> pure VBar
  , P.try $ P.char   ':'   *> pure Colon
  , P.try $ P.char   ','   *> pure Comma
  , P.try $ longOption
  , P.try $ shortOption
  , P.try $ AngleName <$> angleName
  , P.try $ P.char   '<'   *> pure LAngle
  , P.try $ P.char   '>'   *> pure RAngle
  , P.try $ P.string "--"  *> pure DoubleDash
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.char   '='   *> pure Equal
  , P.try $ P.string "..." *> pure TripleDot
  , P.try $ numberLiteral
  , P.try $ stringLiteral
  , P.try $ ShoutName <$> (shoutName <* P.notFollowedBy alpha)
  , P.try $ Name      <$> (name      <* P.notFollowedBy alpha)
  , P.try $ Word      <$> (word      <* space)
  , P.try $ Garbage   <$> P.anyChar
  ]
  <* P.skipSpaces

 where

  whitespace :: P.Parser String Unit
  whitespace = do
    P.satisfy \c -> c == '\n' || c == '\r' || c == ' ' || c == '\t'
    pure unit

  tag :: P.Parser String Token
  tag =
    P.between
      (P.char '[')
      (P.char ']')
      do
        many whitespace
        k <- fromCharArray <$> do A.many (P.noneOf [':'])
        P.char ':'
        many whitespace
        v <- trim <<< fromCharArray <$> do A.some $ P.noneOf [']']
        many whitespace
        return (Tag k v)

  stringLiteral :: P.Parser String Token
  stringLiteral = StringLiteral <$> do
    P.choice [
      P.between (P.char '\'') (P.char '\'') (p '\'')
    , P.between (P.char '"') (P.char '"') (p '"')
    ]
    where
      p :: Char -> P.Parser String String
      p c = fromCharArray <$> do
        A.many $ P.noneOf [c]

  numberLiteral :: P.Parser String Token
  numberLiteral = NumberLiteral <$> do
    P.choice [
      P.try $ FloatLiteral <$> floatLiteral
    , P.try $ IntLiteral   <$> intLiteral
    ]
    where
      floatLiteral = do
        x <- fromCharArray <$> (A.some num)
        P.char '.'
        xs <- fromCharArray <$> (A.some num)

        -- there is no "safe" version yet, afaik
        let n = readFloat $ x ++ "." ++ xs
        if isNaN n
           then P.fail "Could not parse float"
           else pure n

      intLiteral = do
        x <- fromCharArray <$> (A.some num)
        case (I.fromString x) of
          Just n  -> return n
          Nothing -> P.fail "Could not parse integer"

  name :: P.Parser String String
  name = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> A.many identLetter

  word :: P.Parser String String
  word = fromCharArray <$> do
    (A.some $ P.choice [
      identLetter
    , P.oneOf [ '.', '-', '_' ]
    ])

  angleName :: P.Parser String String
  angleName = do
    P.char '<'
    name <- fromCharArray <$> do
      A.some $ P.choice [
        identLetter
      , P.oneOf [ '-', '|', ':', '[', ']', '(', ')' ]
      ]
    P.char '>'
    pure name

  shoutName :: P.Parser String String
  shoutName = do
    name <- fromCharArray <$> do
      A.cons
        <$> upperAlpha
        <*> (A.many $ regex "[A-Z_-]")
    P.notFollowedBy lowerAlpha
    pure name

  shortOption :: P.Parser String Token
  shortOption = do
    P.char '-'
    x  <- alphaNum
    xs <- A.many alphaNum
    arg <- P.choice [

      -- Parse <flag>=<value>, i.e.: `-foo=bar`
      P.try $ Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        P.choice [
          P.try angleName
        , P.try shoutName
        , P.try name
        ]

      -- Parse <flag><VALUE>, i.e.: `-foo<bar>`
    , P.try $ Just <$> angleName

      -- Otherwise assume no argument given. We might be proven wrong at a later
      -- stage (parsing / solving), but as far as the lexer is concerned, this
      -- token bears no arguments.
    , pure Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.lookAhead $ P.choice [
      P.eof
    , P.try $ void $ P.whiteSpace
    , P.try $ void $ P.char ','
    , P.try $ void $ P.char '|'
    , P.try $ void $ P.char '['
    , P.try $ void $ P.char '('
    , P.try $ void $ P.string "..."
    ]

    pure $ SOpt x xs arg

  longOption :: P.Parser String Token
  longOption = do
    P.string "--"
    name' <- fromCharArray <$> do
      A.cons
        <$> alphaNum
        <*> (A.many $ P.choice [
              alphaNum
            , P.oneOf [ '-' ] <* P.lookAhead alphaNum
            ])
    arg <- P.choice [

      -- Parse <flag>=<value>, i.e.: `--foo=bar`
      P.try $ Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        P.choice [
          P.try angleName
        , P.try shoutName
        , P.try name
        ]

      -- Parse <flag><VALUE>, i.e.: `-foo<bar>`
    , P.try $ Just <$> angleName

      -- Otherwise assume no argument given. We might be proven wrong at a later
      -- stage (parsing / solving), but as far as the lexer is concerned, this
      -- token bears no arguments.
    , pure Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.lookAhead $ P.choice [
      P.eof
    , P.try $ void $ P.whiteSpace
    , P.try $ void $ P.char ','
    , P.try $ void $ P.char '|'
    , P.try $ void $ P.char '['
    , P.try $ void $ P.char '('
    , P.try $ void $ P.string "..."
    ]

    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 }) ->
  return $ 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 :: forall a. Token -> TokenParser Unit
match tok = token (\tok' -> if (tok' == tok) then Just unit else Nothing)
            P.<?> prettyPrintToken tok

anyToken = token $ Just

eof :: TokenParser Unit
eof = P.notFollowedBy anyToken

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

langle :: TokenParser Unit
langle = match LAngle

rangle :: TokenParser Unit
rangle = match RAngle

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

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

equal :: TokenParser Unit
equal = match Equal

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

lopt :: TokenParser { name :: String
                    , arg  :: Maybe String }
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 String }
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.<?> "default"
  where
    go (Tag k v) | Str.toUpper k == Str.toUpper s = Just v
    go _                                          = Nothing

word :: TokenParser String
word = token go P.<?> "word"
  where
    go (Word n) = Just n
    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

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


scatter fix

scatter fix

module SlamData.Workspace.Card.BuildChart.Scatter.Eval
  ( eval
  , module SlamData.Workspace.Card.BuildChart.Scatter.Model
  ) where

import SlamData.Prelude

import Color as C

import Data.Argonaut (JArray, Json, cursorGet, toString)
import Data.Array as A
import Data.Foldable as F
import Data.Lens ((^?))
import Data.Map as M
import Data.Set as Set

import Global (infinity)

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

import Quasar.Types (FilePath)

import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Workspace.Card.BuildChart.Common.Eval (type (>>))
import SlamData.Workspace.Card.BuildChart.Common.Eval as BCE
import SlamData.Workspace.Card.BuildChart.Scatter.Model (Model, ScatterR)
import SlamData.Workspace.Card.CardType.ChartType (ChartType(Scatter))
import SlamData.Workspace.Card.BuildChart.Aggregation as Ag
import SlamData.Workspace.Card.BuildChart.ColorScheme (colors, getTransparentColor)
import SlamData.Workspace.Card.BuildChart.Semantics (analyzeJson, semanticsToNumber)
import SlamData.Workspace.Card.Eval.CardEvalT as CET
import SlamData.Workspace.Card.Port as Port

import Utils.Array (enumerate)

eval
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ Model
  → FilePath
  → CET.CardEvalT m Port.Port
eval Nothing _ =
  QE.throw "Please select axis to aggregate"
eval (Just conf) resource = do
  records ← BCE.records resource
  pure $ Port.ChartInstructions (buildScatter conf records) Scatter

type ScatterSeries =
  { name ∷ Maybe String
  , items ∷ Array {x ∷ Number, y ∷ Number, r ∷ Number}
  }

buildScatterData ∷ ScatterR → JArray → Array ScatterSeries
buildScatterData r records = series
  where
  -- | maybe series >> array xs × array ys × array rs
  dataMap ∷ Maybe String >> (Array Number × Array Number × Array Number)
  dataMap =
    foldl dataMapFoldFn M.empty records

  dataMapFoldFn
    ∷ Maybe String >> (Array Number × Array Number × Array Number)
    → Json
    → Maybe String >> (Array Number × Array Number × Array Number)
  dataMapFoldFn acc js =
    let
      mbSeries = toString =<< flip cursorGet js =<< r.series
      xs =
        foldMap A.singleton
          $ semanticsToNumber =<< analyzeJson =<< cursorGet r.abscissa js
      ys =
        foldMap A.singleton
          $ semanticsToNumber =<< analyzeJson =<< cursorGet r.ordinate js
      rs =
        foldMap A.singleton
          $ semanticsToNumber =<< analyzeJson =<< flip cursorGet js =<< r.size

      alterSeriesFn
        ∷ Maybe (Array Number × Array Number × Array Number)
        → Maybe (Array Number × Array Number × Array Number)
      alterSeriesFn Nothing =
        Just $ xs × ys × rs
      alterSeriesFn (Just (xxs × yys × rrs)) =
        Just $ (xxs ⊕ xs) × (yys ⊕ ys) × (rrs ⊕ rs)
    in
      M.alter alterSeriesFn mbSeries acc

  series ∷ Array ScatterSeries
  series =
    foldMap mkScatterSeries $ M.toList dataMap

  mkScatterSeries
    ∷ Maybe String × (Array Number × Array Number × Array Number)
    → Array ScatterSeries
  mkScatterSeries (name × items) =
    [{ name
     , items: adjustSymbolSizes $ mkScatterItem items
     }]

  mkScatterItem
    ∷ (Array Number × Array Number × Array Number)
    → Array {x ∷ Number, y ∷ Number, r ∷ Number }
  mkScatterItem (xs × ys × rs)
    | A.null xs = []
    | A.null ys = []
    | otherwise =
      let
        len =
          max (A.length xs) $ max (A.length ys) (A.length rs)

        abscissas =
          case r.abscissaAggregation of
            Nothing → xs
            Just ag →
              let
                v = Ag.runAggregation ag xs
              in
                map (const v) $ A.range 0 $ len - 1
        ordinates =
          case r.ordinateAggregation of
            Nothing → ys
            Just ag →
              let
                v = Ag.runAggregation ag ys
              in
                map (const v) $ A.range 0 $ len - 1

        sizes =
          case join $ r.sizeAggregation of
            Just ag →
              let
                v = Ag.runAggregation ag rs
              in
                map (const v) $ A.range 0 $ len - 1
            Nothing
              | A.null rs →
                map (\_ → r.minSize) rs
            Nothing →
              rs
        zipped = A.zip abscissas $ A.zip ordinates sizes
      in
        zipped <#> \(x × y × r) → {x, y, r}

  adjustSymbolSizes
    ∷ Array {x ∷ Number, y ∷ Number, r ∷ Number}
    → Array {x ∷ Number, y ∷ Number, r ∷ Number}
  adjustSymbolSizes items =
    let
      minValue =
        fromMaybe (-1.0 * infinity) $ map _.r $ F.maximumBy (\a b → compare a.r b.r) items
      maxValue =
        fromMaybe infinity $ map _.r $ F.maximumBy (\a b → compare a.r b.r) items
      distance =
        maxValue - minValue
      sizeDistance =
        r.maxSize - r.minSize

      relativeSize ∷ Number → Number
      relativeSize val =
        r.maxSize - sizeDistance / distance * (maxValue - val)
    in
      map (\x → x{r = relativeSize x.r}) items

buildScatter ∷ ScatterR → JArray → DSL OptionI
buildScatter r records = do
  E.tooltip do
    E.triggerAxis
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12
    E.axisPointer do
      E.crossAxisPointer
      E.crossStyle do
        E.color $ C.rgba 170 170 170 0.6
        E.widthNum 0.2
        E.solidLine
  E.colors colors

  E.xAxis valueAxis
  E.yAxis valueAxis

  E.legend do
    E.textStyle $ E.fontFamily "Ubuntu, sans"
    E.items $ map ET.strItem seriesNames

  E.series series

  where
  scatterData ∷ Array (Int × ScatterSeries)
  scatterData = enumerate $ buildScatterData r records

  valueAxis ∷ ∀ i. DSL (ETP.AxisI i)
  valueAxis = do
    E.axisType ET.Value
    E.axisLabel $ E.textStyle $ E.fontFamily "Ubuntu, sans"
    E.axisLine $ E.lineStyle do
      E.color $ C.rgba 184 184 184 1.0
      E.width 1
    E.splitLine $ E.lineStyle do
      E.color $ C.rgba 204 204 204 0.2
      E.width 1

  seriesNames ∷ Array String
  seriesNames =
    A.fromFoldable $ foldMap (snd ⋙ _.name ⋙ Set.fromFoldable) scatterData

  series ∷ ∀ i. DSL (scatter ∷ ETP.I|i)
  series = for_ scatterData \(ix × serie) → E.scatter do
    for_ serie.name E.name
    for_ (A.index colors $ mod ix $ A.length colors) \color → do
      E.itemStyle $ E.normal $ E.color $ getTransparentColor color 0.5
    E.symbol ET.Circle
    E.buildItems $ for_ serie.items \item → E.addItem $ E.buildValues do
      E.addValue item.x
      E.addValue item.y
      E.addValue item.r

module SlamData.Workspace.Card.BuildChart.Scatter.Eval
  ( eval
  , module SlamData.Workspace.Card.BuildChart.Scatter.Model
  ) where

import SlamData.Prelude

import Color as C

import Data.Argonaut (JArray, Json, cursorGet, toString)
import Data.Array as A
import Data.Foldable as F
import Data.Lens ((^?))
import Data.Map as M
import Data.Set as Set

import Global (infinity)

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

import Quasar.Types (FilePath)

import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Workspace.Card.BuildChart.Common.Eval (type (>>))
import SlamData.Workspace.Card.BuildChart.Common.Eval as BCE
import SlamData.Workspace.Card.BuildChart.Scatter.Model (Model, ScatterR)
import SlamData.Workspace.Card.CardType.ChartType (ChartType(Scatter))
import SlamData.Workspace.Card.BuildChart.Aggregation as Ag
import SlamData.Workspace.Card.BuildChart.ColorScheme (colors, getTransparentColor)
import SlamData.Workspace.Card.BuildChart.Semantics (analyzeJson, semanticsToNumber)
import SlamData.Workspace.Card.Eval.CardEvalT as CET
import SlamData.Workspace.Card.Port as Port

import Utils.Array (enumerate)

eval
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ Model
  → FilePath
  → CET.CardEvalT m Port.Port
eval Nothing _ =
  QE.throw "Please select axis to aggregate"
eval (Just conf) resource = do
  records ← BCE.records resource
  pure $ Port.ChartInstructions (buildScatter conf records) Scatter

type ScatterSeries =
  { name ∷ Maybe String
  , items ∷ Array {x ∷ Number, y ∷ Number, r ∷ Number}
  }

buildScatterData ∷ ScatterR → JArray → Array ScatterSeries
buildScatterData r records = series
  where
  -- | maybe series >> array xs × array ys × array rs
  dataMap ∷ Maybe String >> (Array Number × Array Number × Array Number)
  dataMap =
    foldl dataMapFoldFn M.empty records

  dataMapFoldFn
    ∷ Maybe String >> (Array Number × Array Number × Array Number)
    → Json
    → Maybe String >> (Array Number × Array Number × Array Number)
  dataMapFoldFn acc js =
    let
      mbSeries = toString =<< flip cursorGet js =<< r.series
      xs =
        foldMap A.singleton
          $ semanticsToNumber =<< analyzeJson =<< cursorGet r.abscissa js
      ys =
        foldMap A.singleton
          $ semanticsToNumber =<< analyzeJson =<< cursorGet r.ordinate js
      rs =
        foldMap A.singleton
          $ semanticsToNumber =<< analyzeJson =<< flip cursorGet js =<< r.size

      alterSeriesFn
        ∷ Maybe (Array Number × Array Number × Array Number)
        → Maybe (Array Number × Array Number × Array Number)
      alterSeriesFn Nothing =
        Just $ xs × ys × rs
      alterSeriesFn (Just (xxs × yys × rrs)) =
        Just $ (xxs ⊕ xs) × (yys ⊕ ys) × (rrs ⊕ rs)
    in
      M.alter alterSeriesFn mbSeries acc

  series ∷ Array ScatterSeries
  series =
    foldMap mkScatterSeries $ M.toList dataMap

  mkScatterSeries
    ∷ Maybe String × (Array Number × Array Number × Array Number)
    → Array ScatterSeries
  mkScatterSeries (name × items) =
    [{ name
     , items: adjustSymbolSizes $ mkScatterItem items
     }]

  mkScatterItem
    ∷ (Array Number × Array Number × Array Number)
    → Array {x ∷ Number, y ∷ Number, r ∷ Number }
  mkScatterItem (xs × ys × rs)
    | A.null xs = []
    | A.null ys = []
    | otherwise =
      let
        abscissas = maybe xs (\ag → A.singleton $ Ag.runAggregation ag xs) r.abscissaAggregation
        ordinates = maybe ys (\ag → A.singleton $ Ag.runAggregation ag ys) r.ordinateAggregation
        sizes = maybe rs (\ag → A.singleton $ Ag.runAggregation ag rs) $ join $ r.sizeAggregation
      in do
        x ← abscissas
        y ← ordinates
        r ← sizes
        pure {x, y, r}

  adjustSymbolSizes
    ∷ Array {x ∷ Number, y ∷ Number, r ∷ Number}
    → Array {x ∷ Number, y ∷ Number, r ∷ Number}
  adjustSymbolSizes items =
    let
      minValue =
        fromMaybe (-1.0 * infinity) $ map _.r $ F.maximumBy (\a b → compare a.r b.r) items
      maxValue =
        fromMaybe infinity $ map _.r $ F.maximumBy (\a b → compare a.r b.r) items
      distance =
        maxValue - minValue
      sizeDistance =
        r.maxSize - r.minSize

      relativeSize ∷ Number → Number
      relativeSize val =
        r.maxSize - sizeDistance / distance * (maxValue - val)
    in
      map (\x → x{r = relativeSize x.r}) items

buildScatter ∷ ScatterR → JArray → DSL OptionI
buildScatter r records = do
  E.tooltip do
    E.triggerAxis
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12
    E.axisPointer do
      E.crossAxisPointer
      E.crossStyle do
        E.color $ C.rgba 170 170 170 0.6
        E.widthNum 0.2
        E.solidLine
  E.colors colors

  E.xAxis valueAxis
  E.yAxis valueAxis

  E.legend do
    E.textStyle $ E.fontFamily "Ubuntu, sans"
    E.items $ map ET.strItem seriesNames

  E.series series

  where
  scatterData ∷ Array (Int × ScatterSeries)
  scatterData = enumerate $ buildScatterData r records

  valueAxis ∷ ∀ i. DSL (ETP.AxisI i)
  valueAxis = do
    E.axisType ET.Value
    E.axisLabel $ E.textStyle $ E.fontFamily "Ubuntu, sans"
    E.axisLine $ E.lineStyle do
      E.color $ C.rgba 184 184 184 1.0
      E.width 1
    E.splitLine $ E.lineStyle do
      E.color $ C.rgba 204 204 204 0.2
      E.width 1

  seriesNames ∷ Array String
  seriesNames =
    A.fromFoldable $ foldMap (snd ⋙ _.name ⋙ Set.fromFoldable) scatterData

  series ∷ ∀ i. DSL (scatter ∷ ETP.I|i)
  series = for_ scatterData \(ix × serie) → E.scatter do
    for_ serie.name E.name
    for_ (A.index colors $ mod ix $ A.length colors) \color → do
      E.itemStyle $ E.normal $ E.color $ getTransparentColor color 0.5
    E.symbol ET.Circle
    E.buildItems $ for_ serie.items \item → E.addItem $ E.buildValues do
      E.addValue item.x
      E.addValue item.y
      E.addValue item.r