Do not allow '<' inside '< ... >'

Do not allow '<' inside '< ... >'

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, fromMaybe, isNothing)
import Data.String.Ext ((^=))
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)

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 = flip P.runParser (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
  | 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 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
              return $ 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
              return $ 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 (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'
              return $ (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'
              return $ (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
  P.skipSpaces
  xs <- L.many $ parsePositionedToken m
  P.eof <|> void do
    i <- getInput
    P.fail $ "Unexpected input: " ++ i
  return xs

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

parseToken :: Mode -> P.Parser String Token
parseToken m = P.choice (P.try <$> A.concat [
    [ P.char   '('   *> pure LParen
    , P.char   ')'   *> pure RParen
    ]
  , if isDescMode m then [ tag ] else []
  , [ reference
    , P.char   '['   *> pure LSquare
    , P.char   ']'   *> pure RSquare
    , P.char   '|'   *> pure VBar
    , P.char   ':'   *> pure Colon
    , P.char   ','   *> pure Comma
    , longOption
    , shortOption
    , AngleName <$> angleName
    , P.string "--"  *> pure DoubleDash
    , P.char   '-'   *> pure Dash
    , P.string "..." *> pure TripleDot
    , ShoutName <$> shoutName
    , Name      <$> name
    ]
  , if isDescMode m
        then [ Garbage <$> P.anyChar ]
        else []
  ])
  <* P.skipSpaces

 where

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

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

    where
      go = do
        many space
        x <- fromCharArray <<< fromList <$> do
          flip P.manyTill (P.lookAhead $ P.try end) do
            P.noneOf [']']
        end
        many space
        return x

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

  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)

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

  name :: P.Parser String String
  name = do
    n  <- alphaNum
    ns <- do
      A.many $ P.try $ do
        P.choice $ P.try <$> [
          identLetter
        , P.char '.' <* (P.notFollowedBy $ P.string "..")
        , P.oneOf [ '-', '_' ]
      ]
    return $ fromCharArray (n A.: ns)

  angleName :: P.Parser String String
  angleName = do
    P.char '<'
    n <- fromCharArray <$> do
      A.some $ P.choice [
        identLetter
        -- disallow swallowing new `<`s in order to avoid creating hard to trace
        -- errors for the user
      , P.try $ P.noneOf [ '<', '>' ]
      ]
    P.char '>'
    return n

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

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

      -- Case 1: OPTION = ARG
      Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        return { name:     n
               , optional: false
               }

      -- Case 2: Option[ = ARG ]
    , Just <$> do
        P.char '[' <* many space
        -- XXX: Drop the spaces?
        P.optional (many space *> P.char '=' <* many space)
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 3: Option[ARG]
    , Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '[' <* many space
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 4: Option<ARG>
    , Just <$> do
        n <- angleName
        return { name:     n
               , optional: false
               }

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

    return $ 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 $ P.try <$> [

      -- Case 1: OPTION = ARG
      Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        return { name:     n
               , optional: false
               }

      -- Case 2: Option[ = ARG ]
    , Just <$> do
        P.char '[' <* many space
        -- XXX: Drop the spaces?
        P.optional (many space *> P.char '=' <* many space)
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 2: Option[ = ARG ]
    , Just <$> do
        P.char '[' <* many space
        -- XXX: Drop the spaces?
        P.optional (many space *> P.char '=' <* many space)
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 3: Option[ARG]
    , Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '[' <* many space
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

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

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

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

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 }) ->
  return $ 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.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, fromMaybe, isNothing)
import Data.String.Ext ((^=))
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)

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 = flip P.runParser (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
  | 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 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
              return $ 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
              return $ 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 (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'
              return $ (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'
              return $ (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
  P.skipSpaces
  xs <- L.many $ parsePositionedToken m
  P.eof <|> void do
    i <- getInput
    P.fail $ "Unexpected input: " ++ i
  return xs

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

parseToken :: Mode -> P.Parser String Token
parseToken m = P.choice (P.try <$> A.concat [
    [ P.char   '('   *> pure LParen
    , P.char   ')'   *> pure RParen
    ]
  , if isDescMode m then [ tag ] else []
  , [ reference
    , P.char   '['   *> pure LSquare
    , P.char   ']'   *> pure RSquare
    , P.char   '|'   *> pure VBar
    , P.char   ':'   *> pure Colon
    , P.char   ','   *> pure Comma
    , longOption
    , shortOption
    , AngleName <$> angleName
    , P.string "--"  *> pure DoubleDash
    , P.char   '-'   *> pure Dash
    , P.string "..." *> pure TripleDot
    , ShoutName <$> shoutName
    , Name      <$> name
    ]
  , if isDescMode m
        then [ Garbage <$> P.anyChar ]
        else []
  ])
  <* P.skipSpaces

 where

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

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

    where
      go = do
        many space
        x <- fromCharArray <<< fromList <$> do
          flip P.manyTill (P.lookAhead $ P.try end) do
            P.noneOf [']']
        end
        many space
        return x

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

  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)

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

  name :: P.Parser String String
  name = do
    n  <- alphaNum
    ns <- do
      A.many $ P.try $ do
        P.choice $ P.try <$> [
          identLetter
        , P.char '.' <* (P.notFollowedBy $ P.string "..")
        , P.oneOf [ '-', '_' ]
      ]
    return $ fromCharArray (n A.: ns)

  angleName :: P.Parser String String
  angleName = do
    P.char '<'
    n <- fromCharArray <$> do
      A.some $ P.choice [
        identLetter
      , P.try $ P.noneOf [ '>' ]
      ]
    P.char '>'
    return n

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

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

      -- Case 1: OPTION = ARG
      Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        return { name:     n
               , optional: false
               }

      -- Case 2: Option[ = ARG ]
    , Just <$> do
        P.char '[' <* many space
        -- XXX: Drop the spaces?
        P.optional (many space *> P.char '=' <* many space)
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 3: Option[ARG]
    , Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '[' <* many space
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 4: Option<ARG>
    , Just <$> do
        n <- angleName
        return { name:     n
               , optional: false
               }

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

    return $ 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 $ P.try <$> [

      -- Case 1: OPTION = ARG
      Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        return { name:     n
               , optional: false
               }

      -- Case 2: Option[ = ARG ]
    , Just <$> do
        P.char '[' <* many space
        -- XXX: Drop the spaces?
        P.optional (many space *> P.char '=' <* many space)
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 2: Option[ = ARG ]
    , Just <$> do
        P.char '[' <* many space
        -- XXX: Drop the spaces?
        P.optional (many space *> P.char '=' <* many space)
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 3: Option[ARG]
    , Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '[' <* many space
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

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

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

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

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


Fix resource output (#1342)

Fix resource output (#1342)

{-
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.Port
  ( Port(..)
  , Resource(..)
  , DataMap
  , Out
  , DownloadPort
  , MetricPort
  , ChartInstructionsPort
  , PivotTablePort
  , SetupLabeledFormInputPort
  , SetupTextLikeFormInputPort
  , tagPort
  , emptyOut
  , varMapOut
  , resourceOut
  , portOut
  , defaultResourceVar
  , filterResources
  , extractResource
  , extractFilePath
  , flattenResources
  , resourceToVarMapValue
  , _Initial
  , _Variables
  , _SlamDown
  , _DownloadOptions
  , _CardError
  , _Metric
  , _ChartInstructions
  , _PivotTable
  , _filePath
  , module SlamData.Workspace.Card.Port.VarMap
  ) where

import SlamData.Prelude

import Data.Argonaut (JCursor)
import Data.Lens (Prism', prism', Traversal', wander, Lens', lens, (^.), view)
import Data.List as List
import Data.Map as Map
import Data.Path.Pathy as Path
import Data.Set as Set
import Data.StrMap as SM

import ECharts.Monad (DSL)
import ECharts.Types.Phantom (OptionI)

import SlamData.Download.Model (DownloadOptions)
import SlamData.Workspace.Card.BuildChart.PivotTable.Model as PTM
import SlamData.Workspace.Card.BuildChart.Semantics as Sem
import SlamData.Workspace.Card.CardType.ChartType (ChartType)
import SlamData.Workspace.Card.CardType.FormInputType (FormInputType)
import SlamData.Workspace.Card.Port.VarMap (VarMap, URLVarMap, VarMapValue(..), renderVarMapValue, emptyVarMap, escapeIdentifier)
import Text.Markdown.SlamDown as SD
import Utils.Path as PU

data Resource
  = Path PU.FilePath
  | View PU.FilePath String DataMap

derive instance eqResource ∷ Eq Resource

type DataMap = SM.StrMap (Either Resource VarMapValue)

type Out = Port × DataMap

type DownloadPort =
  { resource ∷ PU.FilePath
  , compress ∷ Boolean
  , options ∷ DownloadOptions
  }

type MetricPort =
  { label ∷ Maybe String
  , value ∷ String
  }

type ChartInstructionsPort =
  { options ∷ DSL OptionI
  , chartType ∷ ChartType
  }

type PivotTablePort =
  { dimensions ∷ Array (String × JCursor)
  , columns ∷ Array (String × PTM.Column)
  , isSimpleQuery ∷ Boolean
  }

type SetupLabeledFormInputPort =
  { name ∷ String
  , valueLabelMap ∷ Map.Map Sem.Semantics (Maybe String)
  , cursor ∷ JCursor
  , selectedValues ∷ Set.Set Sem.Semantics
  , formInputType ∷ FormInputType
  }

type SetupTextLikeFormInputPort =
  { name ∷ String
  , cursor ∷ JCursor
  , formInputType ∷ FormInputType
  }

data Port
  = Initial
  | Variables
  | CardError String
  | ResourceKey String
  | SetupLabeledFormInput SetupLabeledFormInputPort
  | SetupTextLikeFormInput SetupTextLikeFormInputPort
  | SlamDown (SD.SlamDownP VarMapValue)
  | ChartInstructions ChartInstructionsPort
  | DownloadOptions DownloadPort
  | Metric MetricPort
  | PivotTable PivotTablePort

tagPort ∷ Port → String
tagPort  = case _ of
  Initial → "Initial"
  Variables → "Variables"
  CardError str → "CardError: " ⊕ show str
  ResourceKey str → "ResourceKey: " ⊕ show str
  SetupLabeledFormInput _ → "SetupLabeledFormInput"
  SetupTextLikeFormInput _ → "SetupTextLikeFormInput"
  SlamDown sd → "SlamDown: " ⊕ show sd
  ChartInstructions _ → "ChartInstructions"
  DownloadOptions _ → "DownloadOptions"
  Metric _ → "Metric"
  PivotTable _ → "PivotTable"

filterResources ∷ DataMap → SM.StrMap Resource
filterResources = SM.fold go SM.empty
  where
    go m key (Left res) = SM.insert key res m
    go m _ _ = m

extractResource ∷ DataMap → Maybe Resource
extractResource = map snd ∘ List.head ∘ SM.toList ∘ filterResources

extractFilePath ∷ DataMap → Maybe PU.FilePath
extractFilePath = map (view _filePath) ∘ extractResource

flattenResources ∷ DataMap → VarMap
flattenResources = map go
  where
    go (Left val) = resourceToVarMapValue val
    go (Right val) = val

resourceToVarMapValue ∷ Resource → VarMapValue
resourceToVarMapValue r = QueryExpr (escapeIdentifier (Path.printPath (r ^. _filePath)))

defaultResourceVar ∷ String
defaultResourceVar = "results"

emptyOut ∷ Out
emptyOut = Initial × SM.empty

varMapOut ∷ DataMap → Out
varMapOut v = Variables × v

resourceOut ∷ Resource → Out
resourceOut r = ResourceKey defaultResourceVar × SM.singleton defaultResourceVar (Left r)

portOut ∷ Port → Out
portOut p = p × SM.empty

_Initial ∷ Prism' Port Unit
_Initial = prism' (const Initial) case _ of
  Initial → Just unit
  _ → Nothing

_Variables ∷ Prism' Port Unit
_Variables = prism' (const Variables) case _ of
  Variables → Just unit
  _ → Nothing

_SlamDown ∷ Traversal' Port (SD.SlamDownP VarMapValue)
_SlamDown = wander \f s → case s of
  SlamDown sd → SlamDown <$> f sd
  _ → pure s

_CardError ∷ Prism' Port String
_CardError = prism' CardError \p → case p of
  CardError x → Just x
  _ → Nothing

_DownloadOptions ∷ Prism' Port DownloadPort
_DownloadOptions = prism' DownloadOptions \p → case p of
  DownloadOptions p' → Just p'
  _ → Nothing

_ChartInstructions ∷ Traversal' Port (DSL OptionI)
_ChartInstructions = wander \f s → case s of
  ChartInstructions o → ChartInstructions ∘ o{options = _} <$> f o.options
  _ → pure s

_Metric ∷ Prism' Port MetricPort
_Metric = prism' Metric case _ of
  Metric u → Just u
  _ → Nothing

_PivotTable ∷ Prism' Port PivotTablePort
_PivotTable = prism' PivotTable case _ of
  PivotTable u → Just u
  _ → Nothing

_filePath ∷ Lens' Resource PU.FilePath
_filePath = lens get set
  where
    get (Path fp) = fp
    get (View fp _ _) = fp

    set (Path _) fp = Path fp
    set (View _ a b) fp = View fp a b

{-
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.Port
  ( Port(..)
  , Resource(..)
  , DataMap
  , Out
  , DownloadPort
  , MetricPort
  , ChartInstructionsPort
  , PivotTablePort
  , SetupLabeledFormInputPort
  , SetupTextLikeFormInputPort
  , tagPort
  , emptyOut
  , varMapOut
  , resourceOut
  , portOut
  , defaultResourceVar
  , filterResources
  , extractResource
  , extractFilePath
  , flattenResources
  , resourceToVarMapValue
  , _Initial
  , _Variables
  , _SlamDown
  , _DownloadOptions
  , _CardError
  , _Metric
  , _ChartInstructions
  , _PivotTable
  , _filePath
  , module SlamData.Workspace.Card.Port.VarMap
  ) where

import SlamData.Prelude

import Data.Argonaut (JCursor)
import Data.Lens (Prism', prism', Traversal', wander, Lens', lens, (^.), view)
import Data.List as List
import Data.Map as Map
import Data.Path.Pathy as Path
import Data.Set as Set
import Data.StrMap as SM

import ECharts.Monad (DSL)
import ECharts.Types.Phantom (OptionI)

import SlamData.Download.Model (DownloadOptions)
import SlamData.Workspace.Card.BuildChart.PivotTable.Model as PTM
import SlamData.Workspace.Card.BuildChart.Semantics as Sem
import SlamData.Workspace.Card.CardType.ChartType (ChartType)
import SlamData.Workspace.Card.CardType.FormInputType (FormInputType)
import SlamData.Workspace.Card.Port.VarMap (VarMap, URLVarMap, VarMapValue(..), renderVarMapValue, emptyVarMap, escapeIdentifier)
import Text.Markdown.SlamDown as SD
import Utils.Path as PU

data Resource
  = Path PU.FilePath
  | View PU.FilePath String DataMap

derive instance eqResource ∷ Eq Resource

type DataMap = SM.StrMap (Either Resource VarMapValue)

type Out = Port × DataMap

type DownloadPort =
  { resource ∷ PU.FilePath
  , compress ∷ Boolean
  , options ∷ DownloadOptions
  }

type MetricPort =
  { label ∷ Maybe String
  , value ∷ String
  }

type ChartInstructionsPort =
  { options ∷ DSL OptionI
  , chartType ∷ ChartType
  }

type PivotTablePort =
  { dimensions ∷ Array (String × JCursor)
  , columns ∷ Array (String × PTM.Column)
  , isSimpleQuery ∷ Boolean
  }

type SetupLabeledFormInputPort =
  { name ∷ String
  , valueLabelMap ∷ Map.Map Sem.Semantics (Maybe String)
  , cursor ∷ JCursor
  , selectedValues ∷ Set.Set Sem.Semantics
  , formInputType ∷ FormInputType
  }

type SetupTextLikeFormInputPort =
  { name ∷ String
  , cursor ∷ JCursor
  , formInputType ∷ FormInputType
  }

data Port
  = Initial
  | Variables
  | CardError String
  | ResourceKey String
  | SetupLabeledFormInput SetupLabeledFormInputPort
  | SetupTextLikeFormInput SetupTextLikeFormInputPort
  | SlamDown (SD.SlamDownP VarMapValue)
  | ChartInstructions ChartInstructionsPort
  | DownloadOptions DownloadPort
  | Metric MetricPort
  | PivotTable PivotTablePort

tagPort ∷ Port → String
tagPort  = case _ of
  Initial → "Initial"
  Variables → "Variables"
  CardError str → "CardError: " ⊕ show str
  ResourceKey str → "ResourceKey: " ⊕ show str
  SetupLabeledFormInput _ → "SetupLabeledFormInput"
  SetupTextLikeFormInput _ → "SetupTextLikeFormInput"
  SlamDown sd → "SlamDown: " ⊕ show sd
  ChartInstructions _ → "ChartInstructions"
  DownloadOptions _ → "DownloadOptions"
  Metric _ → "Metric"
  PivotTable _ → "PivotTable"

filterResources ∷ DataMap → SM.StrMap Resource
filterResources = SM.fold go SM.empty
  where
    go m key (Left res) = SM.insert key res m
    go m _ _ = m

extractResource ∷ DataMap → Maybe Resource
extractResource = map snd ∘ List.head ∘ SM.toList ∘ filterResources

extractFilePath ∷ DataMap → Maybe PU.FilePath
extractFilePath = map (view _filePath) ∘ extractResource

flattenResources ∷ DataMap → VarMap
flattenResources = map go
  where
    go (Left val) = resourceToVarMapValue val
    go (Right val) = val

resourceToVarMapValue ∷ Resource → VarMapValue
resourceToVarMapValue r = QueryExpr (escapeIdentifier (Path.printPath (r ^. _filePath)))

defaultResourceVar ∷ String
defaultResourceVar = "results"

emptyOut ∷ Out
emptyOut = Initial × SM.empty

varMapOut ∷ DataMap → Out
varMapOut v = Variables × v

resourceOut ∷ Resource → Out
resourceOut r = ResourceKey defaultResourceVar × SM.singleton "out" (Left r)

portOut ∷ Port → Out
portOut p = p × SM.empty

_Initial ∷ Prism' Port Unit
_Initial = prism' (const Initial) case _ of
  Initial → Just unit
  _ → Nothing

_Variables ∷ Prism' Port Unit
_Variables = prism' (const Variables) case _ of
  Variables → Just unit
  _ → Nothing

_SlamDown ∷ Traversal' Port (SD.SlamDownP VarMapValue)
_SlamDown = wander \f s → case s of
  SlamDown sd → SlamDown <$> f sd
  _ → pure s

_CardError ∷ Prism' Port String
_CardError = prism' CardError \p → case p of
  CardError x → Just x
  _ → Nothing

_DownloadOptions ∷ Prism' Port DownloadPort
_DownloadOptions = prism' DownloadOptions \p → case p of
  DownloadOptions p' → Just p'
  _ → Nothing

_ChartInstructions ∷ Traversal' Port (DSL OptionI)
_ChartInstructions = wander \f s → case s of
  ChartInstructions o → ChartInstructions ∘ o{options = _} <$> f o.options
  _ → pure s

_Metric ∷ Prism' Port MetricPort
_Metric = prism' Metric case _ of
  Metric u → Just u
  _ → Nothing

_PivotTable ∷ Prism' Port PivotTablePort
_PivotTable = prism' PivotTable case _ of
  PivotTable u → Just u
  _ → Nothing

_filePath ∷ Lens' Resource PU.FilePath
_filePath = lens get set
  where
    get (Path fp) = fp
    get (View fp _ _) = fp

    set (Path _) fp = Path fp
    set (View _ a b) fp = View fp a b


Restrict `ShoutName` in terms of `P.notFollowedBy`

module Docopt.Parser.Lexer where

import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import Control.Monad.State (State(), evalState, get)
import Control.Monad.Trans
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Token as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import qualified Data.List as L
import qualified Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray, fromChar)
import Data.List (List(..), (:), fromList, many)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Docopt.Parser.Base
import Docopt.Parser.State
import Data.Tuple

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | LAngle
  | RAngle
  | Dash
  | VBar
  | Colon
  | Equal
  | TripleDot
  | LOpt String
  | SOpt Char (List Char) String
  | ShoutName String
  | AngleName String
  | Name      String
  | Garbage   Char

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 Equal         = show '='
prettyPrintToken TripleDot     = show "..."
prettyPrintToken (Garbage   c) = "Garbage "   ++ show c
prettyPrintToken (Name      n) = "Name "      ++ show n
prettyPrintToken (ShoutName n) = "ShoutName " ++ show n
prettyPrintToken (AngleName n) = "AngleName " ++ show n
prettyPrintToken (LOpt n)      = show $ "--" ++ n
prettyPrintToken (SOpt n s a)  =
  show $ "-"
    ++ (fromChar n)
    ++ (fromCharArray $ fromList s)
    ++ a

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 LAngle        LAngle           = true
  eq RAngle        RAngle           = true
  eq VBar          VBar             = true
  eq Colon         Colon            = true
  eq Dash          Dash             = true
  eq Equal         Equal            = true
  eq TripleDot     TripleDot        = true
  eq (AngleName n) (AngleName n')   = n == n'
  eq (ShoutName n) (ShoutName n')   = n == n'
  eq (Garbage c)   (Garbage c')     = c == c'
  eq (Name n)      (Name n')        = n == n'
  eq (LOpt n)      (LOpt n')        = (n == n')
  eq (SOpt n ns a) (SOpt n' ns' a') = (n == n') && (ns' == ns') && (a == a')
  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 $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '|'   *> pure VBar
  , P.try $ P.char   ':'   *> pure Colon
  , P.try $ parseLongOption
  , P.try $ parseShortOption
  , P.try $ AngleName <$> parseAngleName
  , P.try $ P.char   '<'   *> pure LAngle
  , P.try $ P.char   '>'   *> pure RAngle
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.char   '='   *> pure Equal
  , P.try $ P.string "..." *> pure TripleDot
  , P.try $ ShoutName <$> parseShoutName
  , P.try $ Name      <$> parseName
  , P.try $ Garbage   <$> P.anyChar
  ] <* P.skipSpaces

 where

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

  parseAngleName :: P.Parser String String
  parseAngleName =
    P.char '<' *> parseName <* P.char '>'

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

  parseShortOption :: P.Parser String Token
  parseShortOption =
    P.char '-' *> do
      SOpt
        <$> lowerAlphaNum
        <*> (many lowerAlphaNum)
        <*> (fromCharArray <$> (A.many upperAlphaNum))

  parseLongOption :: P.Parser String Token
  parseLongOption =
    P.string "--" *> do
      LOpt <$> parseName

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

vbar :: TokenParser Unit
vbar = match VBar

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

equal :: TokenParser Unit
equal = match Equal

lopt :: TokenParser String
lopt = token go P.<?> "long-option"
  where
    go (LOpt n) = Just n
    go _        = Nothing

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

name :: TokenParser String
name = token go P.<?> "name"
  where
    go (Name 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
  (ParserState { indentation: 0 })
  <<< P.runParserT
  (P.PState { input: s, position: P.initialPos })

module Docopt.Parser.Lexer where

import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import Control.Monad.State (State(), evalState, get)
import Control.Monad.Trans
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Token as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import qualified Data.List as L
import qualified Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray, fromChar)
import Data.List (List(..), (:), fromList, many)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Docopt.Parser.Base
import Docopt.Parser.State
import Data.Tuple

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | LAngle
  | RAngle
  | Dash
  | VBar
  | Colon
  | Equal
  | TripleDot
  | LOpt String
  | SOpt Char (List Char) String
  | ShoutName String
  | AngleName String
  | Name      String
  | Garbage   Char

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 Equal         = show '='
prettyPrintToken TripleDot     = show "..."
prettyPrintToken (Garbage   c) = "Garbage "   ++ show c
prettyPrintToken (Name      n) = "Name "      ++ show n
prettyPrintToken (ShoutName n) = "ShoutName " ++ show n
prettyPrintToken (AngleName n) = "AngleName " ++ show n
prettyPrintToken (LOpt n)      = show $ "--" ++ n
prettyPrintToken (SOpt n s a)  =
  show $ "-"
    ++ (fromChar n)
    ++ (fromCharArray $ fromList s)
    ++ a

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 LAngle        LAngle           = true
  eq RAngle        RAngle           = true
  eq VBar          VBar             = true
  eq Colon         Colon            = true
  eq Dash          Dash             = true
  eq Equal         Equal            = true
  eq TripleDot     TripleDot        = true
  eq (AngleName n) (AngleName n')   = n == n'
  eq (ShoutName n) (ShoutName n')   = n == n'
  eq (Garbage c)   (Garbage c')     = c == c'
  eq (Name n)      (Name n')        = n == n'
  eq (LOpt n)      (LOpt n')        = (n == n')
  eq (SOpt n ns a) (SOpt n' ns' a') = (n == n') && (ns' == ns') && (a == a')
  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 $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '|'   *> pure VBar
  , P.try $ P.char   ':'   *> pure Colon
  , P.try $ parseLongOption
  , P.try $ parseShortOption
  , P.try $ AngleName <$> parseAngleName
  , P.try $ P.char   '<'   *> pure LAngle
  , P.try $ P.char   '>'   *> pure RAngle
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.char   '='   *> pure Equal
  , P.try $ P.string "..." *> pure TripleDot
  , P.try $ ShoutName <$> parseShoutName
  , P.try $ Name      <$> parseName
  , P.try $ Garbage   <$> P.anyChar
  ] <* P.skipSpaces

 where

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

  parseAngleName :: P.Parser String String
  parseAngleName =
    P.char '<' *> parseName <* P.char '>'

  parseShoutName :: P.Parser String String
  parseShoutName = fromCharArray <$> do
    A.cons
      <$> upperAlpha
      <*> (A.many $ do
        c <- regex "[A-Z_-]"
        P.lookAhead (void space <|> P.eof)
        return c)

  parseShortOption :: P.Parser String Token
  parseShortOption =
    P.char '-' *> do
      SOpt
        <$> lowerAlphaNum
        <*> (many lowerAlphaNum)
        <*> (fromCharArray <$> (A.many upperAlphaNum))

  parseLongOption :: P.Parser String Token
  parseLongOption =
    P.string "--" *> do
      LOpt <$> parseName

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

vbar :: TokenParser Unit
vbar = match VBar

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

equal :: TokenParser Unit
equal = match Equal

lopt :: TokenParser String
lopt = token go P.<?> "long-option"
  where
    go (LOpt n) = Just n
    go _        = Nothing

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

name :: TokenParser String
name = token go P.<?> "name"
  where
    go (Name 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
  (ParserState { indentation: 0 })
  <<< P.runParserT
  (P.PState { input: s, position: P.initialPos })


Fix window.location.pathname parsing function

module Pux.Routing.Bob where

import Prelude
import Pux.Router as Pux.Router
import Routing.Bob as Routing.Bob
import Control.Monad.Aff (liftEff')
import Control.Monad.Eff (Eff)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Location (pathname)
import DOM.HTML.Window (location)
import Data.Generic (class Generic)
import Data.Maybe (Maybe(Nothing, Just))
import Data.String (dropWhile)
import Pux (onlyEffects, noEffects, Update)
import Pux.Html (Html, a)
import Pux.Html.Attributes (href)
import Pux.Html.Elements (Attribute)
import Pux.Html.Events (onClick)
import Pux.Router (navigateTo)
import Routing.Bob (fromUrl, Router)
import Signal (Signal, (~>))

type Path = String

data RoutingError r
  = NotFound Path

instance functorRoutingError :: Functor RoutingError where
  map f (NotFound p) = NotFound p

-- | Base routing action type:
-- | - `RouteRequest r` - should be used to request url change
-- |    and should be passed to library `update` function.
-- | - `UrlChange s` is raised when browser location changes
-- |    should be passed to library `update` function too.
-- | - `Routed r` - is an response type which indicates route
-- |    change and should be handled in your application `update`
-- | - `RoutingError ...` - is error response action which
-- |    should be handled in your `update` too.
data RoutingAction routesType
  -- | handled by library `update` function
  = RouteRequest routesType
  | UrlChanged Path
  -- | handled by your `update` function
  | Routed routesType
  | RoutingError (RoutingError routesType)

instance functorRoutingActionWrapper :: Functor RoutingAction where
  map f (RouteRequest r) = RouteRequest (f r)
  map f (Routed r) = Routed (f r)
  map f (RoutingError e) = RoutingError (map f e)
  map _ (UrlChanged p) = (UrlChanged p)

toAbsoluteUrl :: forall route. Router route -> route -> String
toAbsoluteUrl = (("/" <> _) <$> _) <$> Routing.Bob.toUrl

fromAbsoluteUrl :: forall route. Router route -> String -> Maybe route
fromAbsoluteUrl r =  fromUrl r <<< dropWhile (_ == '/')

update :: forall eff route state. (Generic route) =>
          Router route ->
          Update state (RoutingAction route) (dom :: DOM | eff)
update router (RouteRequest r) state =
  let url = toAbsoluteUrl router r
  in onlyEffects state [ liftEff' (push url) >>= (const $ pure (Routed r)) ]
update router (UrlChanged p) state =
  onlyEffects
    state
    [ case fromAbsoluteUrl router p of
        Just r -> pure <<< Routed $ r
        Nothing -> pure <<< RoutingError <<< NotFound $ p
    ]
update router _ state = noEffects state

sampleUrl :: forall route eff. Eff (dom :: DOM | eff) (Signal (RoutingAction route))
sampleUrl = Pux.Router.sampleUrl >>= (pure <<< (_ ~> UrlChanged))

sampleUrl' :: forall action route eff.
             (RoutingAction route -> action) ->
             Eff (dom :: DOM | eff) (Signal action)
sampleUrl' fromRoutingAction = do
  s <- sampleUrl
  pure (s ~> fromRoutingAction)

link :: forall action route. (Generic route) =>
        Router route ->
        (RoutingAction route -> action) ->
        route ->
        Array (Attribute action) ->
        Array (Html action) ->
        Html action
link router fromRoutingAction route attrs children =
  let url = toAbsoluteUrl router route
      attrs' = [ href url
               , onClick (const (fromRoutingAction <<< RouteRequest $ route))
               ] <> attrs
  in a attrs' children

-- | Tries to parse current `window.location` value and if it is correct
-- | just returns parsed route value. In other case pushes `defaultRoute`
-- | onto history stack.
-- | Returns route which has been initialized.
setInitialRoute :: forall eff route. Router route -> route -> Eff (dom :: DOM | eff) route
setInitialRoute router defaultRoute = do
  maybeCurrRoute <- parseWindowLocation router
  case maybeCurrRoute of
    Just cr -> pure cr
    Nothing ->
      do
        pushRoute router defaultRoute
        pure defaultRoute

-- | push* and navigateTo* functions should be used only when initializing
-- | application. In other situations you should request url change through
-- | `RequestRoute r` action.

-- | Pushes history state (changes location) without signaling this event.
foreign import push :: forall eff. String -> Eff (dom :: DOM | eff) Unit

-- | Pushes route (changes location) without signaling this event.
pushRoute :: forall eff route.
              Router route ->
              route ->
              Eff (dom :: DOM | eff) Unit
pushRoute router route = push (toAbsoluteUrl router route)

-- | Pushes history state (changes location) signaling this event.
navigateToRoute :: forall eff route.
                    Router route ->
                    route ->
                    Eff (dom :: DOM | eff) Unit
navigateToRoute router route = navigateTo (toAbsoluteUrl router route)

-- | Tries to parse current window.location.pathname.
parseWindowLocation :: forall eff route.
                        Router route ->
                        Eff (dom :: DOM | eff) (Maybe route)
parseWindowLocation router =
  window >>= location >>= pathname >>= (pure <<< fromAbsoluteUrl router)

module Pux.Routing.Bob where

import Prelude
import Pux.Router as Pux.Router
import Routing.Bob as Routing.Bob
import Control.Monad.Aff (liftEff')
import Control.Monad.Eff (Eff)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Location (pathname)
import DOM.HTML.Window (location)
import Data.Generic (class Generic)
import Data.Maybe (Maybe(Nothing, Just))
import Data.String (dropWhile)
import Pux (onlyEffects, noEffects, Update)
import Pux.Html (Html, a)
import Pux.Html.Attributes (href)
import Pux.Html.Elements (Attribute)
import Pux.Html.Events (onClick)
import Pux.Router (navigateTo)
import Routing.Bob (Router, fromUrl)
import Signal (Signal, (~>))

type Path = String

data RoutingError r
  = NotFound Path

instance functorRoutingError :: Functor RoutingError where
  map f (NotFound p) = NotFound p

-- | Base routing action type:
-- | - `RouteRequest r` - should be used to request url change
-- |    and should be passed to library `update` function.
-- | - `UrlChange s` is raised when browser location changes
-- |    should be passed to library `update` function too.
-- | - `Routed r` - is an response type which indicates route
-- |    change and should be handled in your application `update`
-- | - `RoutingError ...` - is error response action which
-- |    should be handled in your `update` too.
data RoutingAction routesType
  -- | handled by library `update` function
  = RouteRequest routesType
  | UrlChanged Path
  -- | handled by your `update` function
  | Routed routesType
  | RoutingError (RoutingError routesType)

instance functorRoutingActionWrapper :: Functor RoutingAction where
  map f (RouteRequest r) = RouteRequest (f r)
  map f (Routed r) = Routed (f r)
  map f (RoutingError e) = RoutingError (map f e)
  map _ (UrlChanged p) = (UrlChanged p)

toAbsoluteUrl :: forall route. Router route -> route -> String
toAbsoluteUrl = (("/" <> _) <$> _) <$> Routing.Bob.toUrl

update :: forall eff route state. (Generic route) =>
          Router route ->
          Update state (RoutingAction route) (dom :: DOM | eff)
update router (RouteRequest r) state =
  let url = toAbsoluteUrl router r
  in onlyEffects state [ liftEff' (push url) >>= (const $ pure (Routed r)) ]
update router (UrlChanged p) state =
  onlyEffects
    state
    [ case fromUrl router (dropWhile (_ == '/') p) of
        Just r -> pure <<< Routed $ r
        Nothing -> pure <<< RoutingError <<< NotFound $ p
    ]
update router _ state = noEffects state

sampleUrl :: forall route eff. Eff (dom :: DOM | eff) (Signal (RoutingAction route))
sampleUrl = Pux.Router.sampleUrl >>= (pure <<< (_ ~> UrlChanged))

sampleUrl' :: forall action route eff.
             (RoutingAction route -> action) ->
             Eff (dom :: DOM | eff) (Signal action)
sampleUrl' fromRoutingAction = do
  s <- sampleUrl
  pure (s ~> fromRoutingAction)

link :: forall action route. (Generic route) =>
        Router route ->
        (RoutingAction route -> action) ->
        route ->
        Array (Attribute action) ->
        Array (Html action) ->
        Html action
link router fromRoutingAction route attrs children =
  let url = toAbsoluteUrl router route
      attrs' = [ href url
               , onClick (const (fromRoutingAction <<< RouteRequest $ route))
               ] <> attrs
  in a attrs' children

-- | Tries to parse current `window.location` value and if it is correct
-- | just return parsed route value. In other case setup url with default route.
-- | Returns value which is finally used.
setInitialRoute :: forall eff route. Router route -> route -> Eff (dom :: DOM | eff) route
setInitialRoute router defaultRoute = do
  maybeCurrRoute <- parseWindowLocation router
  case maybeCurrRoute of
    Just cr -> pure cr
    Nothing ->
      do
        pushRoute router defaultRoute
        pure defaultRoute

-- | push* and navigateTo* functions should be used only when initializing
-- | application. In other situations you should request url change through
-- | `RequestRoute r` action.

-- | Pushes history state (changes location) without signaling this event.
foreign import push :: forall eff. String -> Eff (dom :: DOM | eff) Unit

-- | Pushes route (changes location) without signaling this event.
pushRoute :: forall eff route.
              Router route ->
              route ->
              Eff (dom :: DOM | eff) Unit
pushRoute router route = push (toAbsoluteUrl router route)

-- | Pushes history state (changes location) signaling this event.
navigateToRoute :: forall eff route.
                    Router route ->
                    route ->
                    Eff (dom :: DOM | eff) Unit
navigateToRoute router route = navigateTo (toAbsoluteUrl router route)

-- | Tries to parse current window.location.pathname.
parseWindowLocation :: forall eff route.
                        Router route ->
                        Eff (dom :: DOM | eff) (Maybe route)
parseWindowLocation router =
  window >>= location >>= pathname >>= (pure <<< fromUrl router)


fixes #408

fixes #408

module Controller.Notebook.Cell.Viz where

import Prelude
import Api.Query (count, all, sample)
import Control.Apply ((*>))
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.MonadPlus (guard)
import Control.Plus (empty)
import Data.Argonaut.Core (JArray())
import Data.Array (range, zipWith, concat, replicate, length, filter, (!!), null)
import Data.Foldable (fold, foldl)
import Data.Function (on)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..), fromMaybe, maybe, isJust)
import Data.Maybe.Unsafe (fromJust)
import Data.Time (Milliseconds(..))
import Data.Tuple (Tuple(..), fst, snd)

import Halogen.HTML.Events.Monad (andThen)
import Input.Notebook (Input(..))
import Model.Notebook (State(), _notebook)
import Model.Notebook.Cell (Cell(), _content, _Visualize, _cellId, CellId(), _runState, _input, _hasRun, newVisualizeContent, RunState(..))
import Model.Notebook.Cell.Viz
import Model.Notebook.Domain hiding (_path, _name)
import Model.Notebook.Port (_PortResource)
import Model.Resource -- (Resource())
import Optic.Core
import Optic.Fold ((^?))
import Optic.Extended (TraversalP())
import Data.Argonaut.JCursor (JCursor())
import Data.Map (Map(), keys, toList, lookup, values)
import Data.Selection
import qualified Model.Notebook.ECharts as Me
import Global (readInt, isNaN)
import qualified Data.Set as S
import Utils (s2i, s2n)
import Controller.Notebook.Common (update, I())
import Controller.Notebook.Cell.Viz.Pie (mkPie)
import Controller.Notebook.Cell.Viz.Line (mkLine)
import Controller.Notebook.Cell.Viz.Bar (mkBar)
import qualified Model.Notebook.ECharts as Me
import ECharts.Options
import Utils (s2i)
import qualified Data.List as L

selectAgg :: forall e. Cell -> LensP VizRec Aggregation -> Aggregation -> I e
selectAgg cell _agg agg =
  (update cell upd) <>
  (updateOpts (upd cell))
  where upd = _content.._Visualize.._agg .~ agg

setChartHeight :: forall e. Cell -> String -> I e
setChartHeight cell height =
  case s2i' height of
    Nothing -> empty
    Just h ->
      (update cell (_content.._Visualize.._chartHeight .~ toNumber h)) <>
      (pure $ ResizeECharts (show $ cell ^. _cellId))

s2i' :: String -> Maybe Int
s2i' s = if s == "" then pure 0 else s2i s

setChartWidth :: forall e. Cell -> String -> I e
setChartWidth cell width =
  case s2i' width of
    Nothing -> empty
    Just w ->
      (update cell (_content .. _Visualize .. _chartWidth .~ toNumber w)) <>
      (pure $ ResizeECharts (show $ cell ^. _cellId))

selectChartType :: forall e. Cell -> ChartType -> I e
selectChartType cell ct =
  (update cell (_content.._Visualize.._chartType .~ ct)) <>
  (updateOpts (cell # _content.._Visualize.._chartType .~ ct))

cleanChart :: forall e. Cell -> I e
cleanChart cell =
  pure $ SetEChartsOption (show $ cell ^._cellId) (Option optionDefault)

insertViz :: forall e. State -> Cell -> I e
insertViz state parent =
  case insertCell parent newVisualizeContent (state ^. _notebook) of
    Tuple note cell ->
      (pure $ WithState (_notebook .~ note))
      `andThen` \_ ->
      (updateInserted cell)
      `andThen` \_ ->
      (pure ForceSave)

runViz :: forall e. Cell -> I e
runViz cell =
  (updateInserted cell)
  `andThen` \_ ->
  (update cell (_runState .~ RunFinished (Milliseconds 0)))

updateViz :: forall e. Cell -> VizRec -> I e
updateViz cell r =
  (update cell (_content.._Visualize .~ configured)) <>
  (updateOpts (cell # _content.._Visualize .~ configured))
  where
  configured = configure r

updateInserted :: forall e. Cell -> I e
updateInserted cell =
  maybe errorInPort (updateData cell) $ cell ^? _input .. _PortResource
  where
  error :: String -> I e
  error msg = update cell (_content.._Visualize.._error .~ msg)

  errorInPort :: I e
  errorInPort = error "Incorrect input port"

updateData :: forall e. Cell -> Resource -> I e
updateData cell file = do
  jarr <- liftAff $ sample file 0 20
  if null jarr
    then errorEmptyInput
    else do
    let sample = Me.analyzeJArray jarr
    all <- Me.analyzeJArray <$> (liftAff $ all file)
    let vizRec = fromMaybe initialVizRec $ cell ^? _content .. _Visualize
        axes = keys all
    if L.null axes
      then updateOpts cell
      else
      let vRec = configure $ (vizRec # _all .~ all
                                     # _sample .~ sample
                             )
          vRec' = vRec # _error .~ if S.isEmpty (vRec ^. _availableChartTypes)
                                  then "There is no available chart type for this data"
                                  else ""
      in (update cell ((_content .. _Visualize .~ vRec')
                       .. (_hasRun .~ true))) <>
         (updateOpts (cell # _content .. _Visualize .~ vRec'))
  where
  errored :: String -> I e
  errored msg = update cell (_content.. _Visualize .. _error .~ msg)

  errorEmptyInput :: I e
  errorEmptyInput = errored "Empty input"

configure :: VizRec -> VizRec
configure r =
  let tpls = L.fromList $ toList (r ^._sample)
      cats = fst <$> (filter (snd >>> Me.isCatAxis) tpls)
      vals = fst <$> (filter (snd >>> Me.isValAxis) tpls)
      times = fst <$> (filter (snd >>> Me.isTimeAxis) tpls)

      pie = (r ^._pieConfiguration) #
            (_cats %~ autoSelect) ..
            (_firstMeasures %~ autoSelect) ..
            (_cats.._variants .~ cats) ..
            (_firstSeries.._variants .~ ((cats <-> p.cats) `onlyIfSelected` p.cats)) ..
            (_secondSeries.._variants .~ ((cats <-> p.cats <-> p.firstSeries) `onlyIfSelected` p.firstSeries)) ..
            (_firstMeasures.._variants .~ (depends p.cats vals))

      bar = (r ^._barConfiguration) #
            (_cats %~ autoSelect) ..
            (_firstMeasures %~ autoSelect) ..
            (_cats.._variants .~ cats) ..
            (_firstSeries.._variants .~ ((cats <-> b.cats) `onlyIfSelected` b.cats)) ..
            (_secondSeries.._variants .~ ((cats <-> b.cats <-> b.firstSeries) `onlyIfSelected` b.firstSeries)) ..
            (_firstMeasures.._variants .~ (depends b.cats vals))

      line = (r ^._lineConfiguration) #
             (_dims %~ autoSelect) ..
             (_firstMeasures %~ autoSelect) ..
             (_dims.._variants .~ (times <> cats)) ..
             (_firstSeries.._variants .~ ((cats <-> l.dims) `onlyIfSelected` l.dims)) ..
             (_secondSeries.._variants .~ ((cats <-> l.dims <-> l.firstSeries) `onlyIfSelected` l.firstSeries)) ..
             (_firstMeasures.._variants .~ (depends l.dims vals)) ..
             (_secondMeasures.._variants .~ ((depends l.dims $(vals <-> l.firstMeasures)) `onlyIfSelected` l.firstMeasures))

      available = if null vals
                  then L.Nil
                  else if not $ null cats
                       then L.toList [Pie, Bar, Line]
                       else if null times
                            then L.Nil
                            else L.singleton Line
      error = if L.null available then "No available chart types, please, rerun cell" else ""

  in r # _pieConfiguration .~ pie
       # _barConfiguration .~ bar
       # _lineConfiguration .~ line
       # _availableChartTypes .~ S.fromList available
  where
    p = r ^._pieConfiguration
    b = r ^._barConfiguration
    l = r ^._lineConfiguration

    onlyIfSelected :: forall a. Array a -> Selection a -> Array a
    onlyIfSelected lst sel = maybe [] (const lst) (sel ^._selection)

updateOpts :: forall e. Cell -> I e
updateOpts cell =
  -- options event with true in updateOptio in echarts
  -- don't update properly :(
  (setOutput cell) `andThen` \_ ->
  (maybe empty go (cell ^? _content.._Visualize))
  where
  go r = do
    let opts = case r ^._chartType of
          Pie -> mkPie r (r ^. _pieConfiguration)
          Line -> mkLine r (r ^. _lineConfiguration)
          Bar -> mkBar r (r ^. _barConfiguration)
    if L.null $ keys (r ^._all)
      then empty :: I e
      else
      (update cell (_content.._Visualize.._output .~ opts)) `andThen` \_ ->
      (setOutput (cell # _content.._Visualize.._output .~ opts))

setOutput :: forall e. Cell -> I e
setOutput cell =
  (cleanChart cell) `andThen` \_ ->
  (maybe empty go (cell ^? _content.._Visualize.._output))
  where
  go opts =
    pure $ SetEChartsOption (show $ cell ^._cellId) opts

module Controller.Notebook.Cell.Viz where

import Prelude
import Api.Query (count, all, sample)
import Control.Apply ((*>))
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.MonadPlus (guard)
import Control.Plus (empty)
import Data.Argonaut.Core (JArray())
import Data.Array (range, zipWith, concat, replicate, length, filter, (!!), null)
import Data.Foldable (fold, foldl)
import Data.Function (on)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..), fromMaybe, maybe, isJust)
import Data.Maybe.Unsafe (fromJust)
import Data.Time (Milliseconds(..))
import Data.Tuple (Tuple(..), fst, snd)

import Halogen.HTML.Events.Monad (andThen)
import Input.Notebook (Input(..))
import Model.Notebook (State(), _notebook)
import Model.Notebook.Cell (Cell(), _content, _Visualize, _cellId, CellId(), _runState, _input, _hasRun, newVisualizeContent, RunState(..))
import Model.Notebook.Cell.Viz
import Model.Notebook.Domain
import Model.Notebook.Port (_PortResource)
import Model.Resource (Resource())
import Optic.Core
import Optic.Fold ((^?))
import Optic.Extended (TraversalP())
import Data.Argonaut.JCursor (JCursor())
import Data.Map (Map(), keys, toList, lookup, values)
import Data.Selection
import qualified Model.Notebook.ECharts as Me
import Global (readInt, isNaN)
import qualified Data.Set as S
import Utils (s2i, s2n)
import Controller.Notebook.Common (update, I())
import Controller.Notebook.Cell.Viz.Pie (mkPie)
import Controller.Notebook.Cell.Viz.Line (mkLine)
import Controller.Notebook.Cell.Viz.Bar (mkBar)
import qualified Model.Notebook.ECharts as Me
import ECharts.Options
import Utils (s2i)
import qualified Data.List as L

selectAgg :: forall e. Cell -> LensP VizRec Aggregation -> Aggregation -> I e
selectAgg cell _agg agg =
  (update cell upd) <>
  (updateOpts (upd cell))
  where upd = _content.._Visualize.._agg .~ agg

setChartHeight :: forall e. Cell -> String -> I e
setChartHeight cell height =
  case s2i' height of
    Nothing -> empty
    Just h ->
      (update cell (_content.._Visualize.._chartHeight .~ toNumber h)) <>
      (pure $ ResizeECharts (show $ cell ^. _cellId))

s2i' :: String -> Maybe Int
s2i' s = if s == "" then pure 0 else s2i s

setChartWidth :: forall e. Cell -> String -> I e
setChartWidth cell width =
  case s2i' width of
    Nothing -> empty
    Just w ->
      (update cell (_content .. _Visualize .. _chartWidth .~ toNumber w)) <>
      (pure $ ResizeECharts (show $ cell ^. _cellId))

selectChartType :: forall e. Cell -> ChartType -> I e
selectChartType cell ct =
  (update cell (_content.._Visualize.._chartType .~ ct)) <>
  (updateOpts (cell # _content.._Visualize.._chartType .~ ct))

cleanChart :: forall e. Cell -> I e
cleanChart cell =
  pure $ SetEChartsOption (show $ cell ^._cellId) (Option optionDefault)

insertViz :: forall e. State -> Cell -> I e
insertViz state parent =
  case insertCell parent newVisualizeContent (state ^. _notebook) of
    Tuple note cell ->
      (pure $ WithState (_notebook .~ note))
      `andThen` \_ ->
      (updateInserted cell)
      `andThen` \_ ->
      (pure ForceSave)

runViz :: forall e. Cell -> I e
runViz cell =
  (updateInserted cell)
  `andThen` \_ ->
  (update cell (_runState .~ RunFinished (Milliseconds 0)))

updateViz :: forall e. Cell -> VizRec -> I e
updateViz cell r =
  (update cell (_content.._Visualize .~ configured)) <>
  (updateOpts (cell # _content.._Visualize .~ configured))
  where
  configured = configure r

updateInserted :: forall e. Cell -> I e
updateInserted cell =
  maybe errorInPort (updateData cell) $ cell ^? _input .. _PortResource
  where
  error :: String -> I e
  error msg = update cell (_content.._Visualize.._error .~ msg)

  errorInPort :: I e
  errorInPort = error "Incorrect input port"

updateData :: forall e. Cell -> Resource -> I e
updateData cell file = do
  numItems <- liftAff $ count file
  if numItems < 1
    then errorEmptyInput
    else do
    sample <- Me.analyzeJArray <$>
              (liftAff $ sample file 0 20)

    all <- Me.analyzeJArray <$> (liftAff $ all file)

    let vizRec = fromMaybe initialVizRec $ cell ^? _content.._Visualize
        axes = keys all
    if L.null axes
      then updateOpts cell
      else
      let vRec = configure $ (vizRec # _all .~ all
                                     # _sample .~ sample
                             )
          vRec' = vRec # _error .~ if S.isEmpty (vRec ^._availableChartTypes)
                                   then "There is no availbale chart type for this data"
                                   else ""

      in (update cell ((_content .. _Visualize .~ vRec')
                    .. (_hasRun .~ true))) <>
         (updateOpts (cell # _content.._Visualize .~ vRec'))

  where
  errored :: String -> I e
  errored msg = update cell (_content.._Visualize.._error .~ msg)

  errorEmptyInput :: I e
  errorEmptyInput = errored "Empty input"

configure :: VizRec -> VizRec
configure r =
  let tpls = L.fromList $ toList (r ^._sample)
      cats = fst <$> (filter (snd >>> Me.isCatAxis) tpls)
      vals = fst <$> (filter (snd >>> Me.isValAxis) tpls)
      times = fst <$> (filter (snd >>> Me.isTimeAxis) tpls)

      pie = (r ^._pieConfiguration) #
            (_cats %~ autoSelect) ..
            (_firstMeasures %~ autoSelect) ..
            (_cats.._variants .~ cats) ..
            (_firstSeries.._variants .~ ((cats <-> p.cats) `onlyIfSelected` p.cats)) ..
            (_secondSeries.._variants .~ ((cats <-> p.cats <-> p.firstSeries) `onlyIfSelected` p.firstSeries)) ..
            (_firstMeasures.._variants .~ (depends p.cats vals))

      bar = (r ^._barConfiguration) #
            (_cats %~ autoSelect) ..
            (_firstMeasures %~ autoSelect) ..
            (_cats.._variants .~ cats) ..
            (_firstSeries.._variants .~ ((cats <-> b.cats) `onlyIfSelected` b.cats)) ..
            (_secondSeries.._variants .~ ((cats <-> b.cats <-> b.firstSeries) `onlyIfSelected` b.firstSeries)) ..
            (_firstMeasures.._variants .~ (depends b.cats vals))

      line = (r ^._lineConfiguration) #
             (_dims %~ autoSelect) ..
             (_firstMeasures %~ autoSelect) ..
             (_dims.._variants .~ (times <> cats)) ..
             (_firstSeries.._variants .~ ((cats <-> l.dims) `onlyIfSelected` l.dims)) ..
             (_secondSeries.._variants .~ ((cats <-> l.dims <-> l.firstSeries) `onlyIfSelected` l.firstSeries)) ..
             (_firstMeasures.._variants .~ (depends l.dims vals)) ..
             (_secondMeasures.._variants .~ ((depends l.dims $(vals <-> l.firstMeasures)) `onlyIfSelected` l.firstMeasures))

      available = if null vals
                  then L.Nil
                  else if not $ null cats
                       then L.toList [Pie, Bar, Line]
                       else if null times
                            then L.Nil
                            else L.singleton Line
      error = if L.null available then "No available chart types, please, rerun cell" else ""

  in r # _pieConfiguration .~ pie
       # _barConfiguration .~ bar
       # _lineConfiguration .~ line
       # _availableChartTypes .~ S.fromList available
  where
    p = r ^._pieConfiguration
    b = r ^._barConfiguration
    l = r ^._lineConfiguration

    onlyIfSelected :: forall a. Array a -> Selection a -> Array a
    onlyIfSelected lst sel = maybe [] (const lst) (sel ^._selection)

updateOpts :: forall e. Cell -> I e
updateOpts cell =
  -- options event with true in updateOptio in echarts
  -- don't update properly :(
  (setOutput cell) `andThen` \_ ->
  (maybe empty go (cell ^? _content.._Visualize))
  where
  go r = do
    let opts = case r ^._chartType of
          Pie -> mkPie r (r ^. _pieConfiguration)
          Line -> mkLine r (r ^. _lineConfiguration)
          Bar -> mkBar r (r ^. _barConfiguration)
    if L.null $ keys (r ^._all)
      then empty :: I e
      else
      (update cell (_content.._Visualize.._output .~ opts)) `andThen` \_ ->
      (setOutput (cell # _content.._Visualize.._output .~ opts))

setOutput :: forall e. Cell -> I e
setOutput cell =
  (cleanChart cell) `andThen` \_ ->
  (maybe empty go (cell ^? _content.._Visualize.._output))
  where
  go opts =
    pure $ SetEChartsOption (show $ cell ^._cellId) opts


Fix shadowed name warning

Fix shadowed name warning

-- | This module defines a type class for reading foreign values.

module Data.Foreign.Class
  ( class IsForeign
  , read
  , readJSON
  , readWith
  , readProp
  , class AsForeign
  , write
  , writeProp, (.=)
  , readEitherR
  , readEitherL
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Except (Except, mapExcept)

import Data.Array (range, zipWith, length)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foreign (F, Foreign, MultipleErrors, ForeignError(..), Prop(..), toForeign, parseJSON, readArray, readInt, readNumber, readBoolean, readChar, readString)
import Data.Foreign.Index (class Index, errorAt, (!))
import Data.Foreign.Null (Null(..), readNull, writeNull)
import Data.Foreign.NullOrUndefined (NullOrUndefined(..), readNullOrUndefined)
import Data.Foreign.Undefined (Undefined(..), readUndefined, writeUndefined)
import Data.Maybe (maybe)
import Data.Traversable (sequence)

-- | A type class instance for this class can be written for a type if it
-- | is possible to attempt to _safely_ coerce a `Foreign` value to that
-- | type.
-- |
-- | Instances are provided for standard data structures, and the `F` monad
-- | can be used to construct instances for new data structures.
class IsForeign a where
  read :: Foreign -> F a

instance foreignIsForeign :: IsForeign Foreign where
  read = pure

instance stringIsForeign :: IsForeign String where
  read = readString

instance charIsForeign :: IsForeign Char where
  read = readChar

instance booleanIsForeign :: IsForeign Boolean where
  read = readBoolean

instance numberIsForeign :: IsForeign Number where
  read = readNumber

instance intIsForeign :: IsForeign Int where
  read = readInt

instance arrayIsForeign :: IsForeign a => IsForeign (Array a) where
  read = readArray >=> readElements
    where
    readElements :: Array Foreign -> F (Array a)
    readElements arr = sequence (zipWith readElement (range zero (length arr)) arr)

    readElement :: Int -> Foreign -> F a
    readElement i value = readWith (map (ErrorAtIndex i)) value

instance nullIsForeign :: IsForeign a => IsForeign (Null a) where
  read = readNull read

instance undefinedIsForeign :: IsForeign a => IsForeign (Undefined a) where
  read = readUndefined read

instance nullOrUndefinedIsForeign :: IsForeign a => IsForeign (NullOrUndefined a) where
  read = readNullOrUndefined read

-- | Attempt to read a data structure from a JSON string
readJSON :: forall a. IsForeign a => String -> F a
readJSON json = parseJSON json >>= read

-- | Attempt to read a foreign value, handling errors using the specified function
readWith :: forall a e. IsForeign a => (MultipleErrors -> e) -> Foreign -> Except e a
readWith f = mapExcept (lmap f) <<< read

-- | Attempt to read a property of a foreign value at the specified index
readProp :: forall a i. (IsForeign a, Index i) => i -> Foreign -> F a
readProp prop value = value ! prop >>= readWith (map (errorAt prop))

-- | A type class to convert to a `Foreign` value.
-- |
-- | Instances are provided for standard data structures.
class AsForeign a where
  write :: a -> Foreign

instance foreignAsForeign :: AsForeign Foreign where
  write = id

instance stringAsForeign :: AsForeign String where
  write = toForeign

instance charAsForeign :: AsForeign Char where
  write = toForeign

instance booleanAsForeign :: AsForeign Boolean where
  write = toForeign

instance numberAsForeign :: AsForeign Number where
  write = toForeign

instance intAsForeign :: AsForeign Int where
  write = toForeign

instance arrayAsForeign :: AsForeign a => AsForeign (Array a) where
  write = toForeign <<< map write

instance nullAsForeign :: AsForeign a => AsForeign (Null a) where
  write (Null a) = maybe writeNull write a

instance undefinedAsForeign :: AsForeign a => AsForeign (Undefined a) where
  write (Undefined a) = maybe writeUndefined write a

instance nullOrUndefinedAsForeign :: AsForeign a => AsForeign (NullOrUndefined a) where
  write (NullOrUndefined a) = write (Null a)

infixl 8 writeProp as .=

writeProp :: forall a. AsForeign a => String -> a -> Prop
writeProp k v = Prop { key: k, value: write v }

-- | Attempt to read a value that can be either one thing or another. This
-- | implementation is right biased.
readEitherR :: forall l r. (IsForeign l, IsForeign r) => Foreign -> F (Either l r)
readEitherR value = Right <$> read value <|> Left <$> read value

-- | Attempt to read a value that can be either one thing or another. This
-- | implementation is left biased.
readEitherL :: forall l r. (IsForeign l, IsForeign r) => Foreign -> F (Either l r)
readEitherL value = Left <$> read value <|> Right <$> read value

-- | This module defines a type class for reading foreign values.

module Data.Foreign.Class
  ( class IsForeign
  , read
  , readJSON
  , readWith
  , readProp
  , class AsForeign
  , write
  , writeProp, (.=)
  , readEitherR
  , readEitherL
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Except (Except, mapExcept)

import Data.Array (range, zipWith, length)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foreign (F, Foreign, MultipleErrors, ForeignError(..), Prop(..), toForeign, parseJSON, readArray, readInt, readNumber, readBoolean, readChar, readString)
import Data.Foreign.Index (class Index, errorAt, (!))
import Data.Foreign.Null (Null(..), readNull, writeNull)
import Data.Foreign.NullOrUndefined (NullOrUndefined(..), readNullOrUndefined)
import Data.Foreign.Undefined (Undefined(..), readUndefined, writeUndefined)
import Data.Maybe (maybe)
import Data.Traversable (sequence)

-- | A type class instance for this class can be written for a type if it
-- | is possible to attempt to _safely_ coerce a `Foreign` value to that
-- | type.
-- |
-- | Instances are provided for standard data structures, and the `F` monad
-- | can be used to construct instances for new data structures.
class IsForeign a where
  read :: Foreign -> F a

instance foreignIsForeign :: IsForeign Foreign where
  read = pure

instance stringIsForeign :: IsForeign String where
  read = readString

instance charIsForeign :: IsForeign Char where
  read = readChar

instance booleanIsForeign :: IsForeign Boolean where
  read = readBoolean

instance numberIsForeign :: IsForeign Number where
  read = readNumber

instance intIsForeign :: IsForeign Int where
  read = readInt

instance arrayIsForeign :: IsForeign a => IsForeign (Array a) where
  read value = readArray value >>= readElements
    where
    readElements :: Array Foreign -> F (Array a)
    readElements arr = sequence (zipWith readElement (range zero (length arr)) arr)

    readElement :: Int -> Foreign -> F a
    readElement i value = readWith (map (ErrorAtIndex i)) value

instance nullIsForeign :: IsForeign a => IsForeign (Null a) where
  read = readNull read

instance undefinedIsForeign :: IsForeign a => IsForeign (Undefined a) where
  read = readUndefined read

instance nullOrUndefinedIsForeign :: IsForeign a => IsForeign (NullOrUndefined a) where
  read = readNullOrUndefined read

-- | Attempt to read a data structure from a JSON string
readJSON :: forall a. IsForeign a => String -> F a
readJSON json = parseJSON json >>= read

-- | Attempt to read a foreign value, handling errors using the specified function
readWith :: forall a e. IsForeign a => (MultipleErrors -> e) -> Foreign -> Except e a
readWith f = mapExcept (lmap f) <<< read

-- | Attempt to read a property of a foreign value at the specified index
readProp :: forall a i. (IsForeign a, Index i) => i -> Foreign -> F a
readProp prop value = value ! prop >>= readWith (map (errorAt prop))

-- | A type class to convert to a `Foreign` value.
-- |
-- | Instances are provided for standard data structures.
class AsForeign a where
  write :: a -> Foreign

instance foreignAsForeign :: AsForeign Foreign where
  write = id

instance stringAsForeign :: AsForeign String where
  write = toForeign

instance charAsForeign :: AsForeign Char where
  write = toForeign

instance booleanAsForeign :: AsForeign Boolean where
  write = toForeign

instance numberAsForeign :: AsForeign Number where
  write = toForeign

instance intAsForeign :: AsForeign Int where
  write = toForeign

instance arrayAsForeign :: AsForeign a => AsForeign (Array a) where
  write = toForeign <<< map write

instance nullAsForeign :: AsForeign a => AsForeign (Null a) where
  write (Null a) = maybe writeNull write a

instance undefinedAsForeign :: AsForeign a => AsForeign (Undefined a) where
  write (Undefined a) = maybe writeUndefined write a

instance nullOrUndefinedAsForeign :: AsForeign a => AsForeign (NullOrUndefined a) where
  write (NullOrUndefined a) = write (Null a)

infixl 8 writeProp as .=

writeProp :: forall a. AsForeign a => String -> a -> Prop
writeProp k v = Prop { key: k, value: write v }

-- | Attempt to read a value that can be either one thing or another. This
-- | implementation is right biased.
readEitherR :: forall l r. (IsForeign l, IsForeign r) => Foreign -> F (Either l r)
readEitherR value = Right <$> read value <|> Left <$> read value

-- | Attempt to read a value that can be either one thing or another. This
-- | implementation is left biased.
readEitherL :: forall l r. (IsForeign l, IsForeign r) => Foreign -> F (Either l r)
readEitherL value = Left <$> read value <|> Right <$> read value