Remove excess type definition

Remove excess type definition

-- | Input Parser Generator for Docopt
-- |
-- | > Given a un-ambigious specification as input, generate a parser that can
-- | > be applied to user input.
-- |
-- | ===

module Language.Docopt.ParserGen.Parser (
    genUsageParser
  , Parser()
  ) where

import Prelude
import Control.Plus (class Plus, empty)
import Debug.Trace
import Data.Identity (Identity(), runIdentity)
import Control.Monad.State (State(), evalState)
import Control.Apply ((*>), (<*))
import Data.Function (on)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, maybe, maybe')
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList, filter, reverse, concat, catMaybes)
import Control.Alt ((<|>))
import Data.Traversable (class Traversable, traverse, for)
import Control.Lazy (defer)
import Data.Foldable (class Foldable, maximum, maximumBy, foldl, intercalate, for_, all)
import Data.String (fromCharArray, stripPrefix)
import Data.Bifunctor (class Bifunctor, rmap)
import Data.List as L
import Data.List.Unsafe as LU
import Data.Array as A
import Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Monoid (Monoid)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Monoid (mempty)
import Data.Map (Map())
import Control.Monad.Reader (Reader(), ask, runReader)
import Data.Map as Map
import Data.StrMap (StrMap())
import Control.Monad.Trans (lift)
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Control.Bind ((=<<))

import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt.Env      as Env
import Language.Docopt.Errors   as D
import Language.Docopt.Value    as D
import Language.Docopt.Argument as D
import Language.Docopt.Usage    as D
import Language.Docopt.Env      as D
import Language.Docopt.Option   as O

import Language.Docopt.ParserGen.Token
import Language.Docopt.ParserGen.ValueMapping
import Language.Docopt.Parser.Base (alphaNum, space, getInput, debug)

type Parser a = P.ParserT (List Token) (Reader D.Env) a

newtype ScoredResult a = ScoredResult { score :: Int, result :: a }

unScoredResult :: forall a. ScoredResult a -> { score :: Int, result :: a }
unScoredResult (ScoredResult r) = r

instance semigroupScoredResult :: (Semigroup a) => Semigroup (ScoredResult a)
  where append (ScoredResult s) (ScoredResult s')
          = ScoredResult { score:  s.score  + s'.score
                         , result: s.result ++ s'.result }

instance monoidScoredResult :: (Monoid a) => Monoid (ScoredResult a)
  where mempty = ScoredResult { score: 0, result: mempty }

instance showScoredResult :: (Show a) => Show (ScoredResult a)
  where show (ScoredResult { score, result })
          = "ScoredResult " ++ show score ++ ": " ++ show result

instance ordScoredResult :: Ord (ScoredResult a)
  where compare = compare `on` (_.score <<< unScoredResult)

instance eqScoredResult :: Eq (ScoredResult a)
  where eq = eq `on` (_.score <<< unScoredResult)

scoreFromList :: forall a. List a -> ScoredResult (List a)
scoreFromList xs = ScoredResult { score: length xs, result: xs }

rmapScoreResult :: forall a b. (a -> b) -> ScoredResult a -> ScoredResult b
rmapScoreResult f (ScoredResult (x@{ result })) = ScoredResult $ x { result = f result }

--------------------------------------------------------------------------------
-- Input Token Parser ----------------------------------------------------------
--------------------------------------------------------------------------------

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> Parser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case test tok of
        Just a ->
          let nextpos = pos -- neglect pos (for now)
          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"

data Acc a
  = Free (Parser a)
  | Pending (Parser a) (List D.Argument)

eoa :: Parser D.Value
eoa = token go P.<?> "--"
  where
    go (EOA xs) = Just (D.ArrayValue (fromList xs))
    go _        = Nothing

command :: String -> Parser D.Value
command n = token go P.<?> "command " ++ show n
  where
    go (Lit s) | s == n = Just (D.BoolValue true)
    go _                = Nothing

positional :: String -> Parser D.Value
positional n = token go P.<?> "positional argument " ++ show n
  where
    go (Lit v) = Just (D.StringValue v)
    go _       = Nothing

type HasConsumedArg = Boolean
data OptParse = OptParse D.Value (Maybe Token) HasConsumedArg

longOption :: O.Name -> (Maybe O.Argument) -> Parser D.Value
longOption n a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos (for now)
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    takesArg = isJust a

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | takesArg && (n' == n)
      = case v of
          Just s ->
            return $ OptParse (D.StringValue s) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s)  Nothing true
            _            -> OptParse (D.BoolValue true) Nothing false

    -- case 2:
    -- The name is an exact match and takes no argument
    go (LOpt n' _) _ | (not takesArg) && (n' == n)
      = return $ OptParse (D.BoolValue true) Nothing false

    -- case 3:
    -- The name is a substring of the input and no explicit argument has been
    -- provdided.
    go (LOpt n' Nothing) atok | takesArg
      = case stripPrefix n n' of
          Just s -> return $ OptParse (D.StringValue s) Nothing false
          _      -> Left "Invalid substring"

    go _ _ = Left "Invalid token"

shortOption :: Char -> (Maybe O.Argument) -> Parser D.Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    takesArg = isJust a

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && takesArg && (A.length xs == 0)
      = case v of
          Just val -> return $ OptParse (D.StringValue val) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s) Nothing true
            _ -> OptParse (D.BoolValue true)
                          Nothing
                          false

    -- case 2:
    -- The leading flag matches, there are stacked options, no explicit
    -- argument has been passed and the option takes an argument.
    go (SOpt f' xs v) _ | (f' == f) && takesArg && (A.length xs > 0)
      = do
        let a = fromCharArray xs ++ maybe "" id v
        return $ OptParse (D.StringValue a)
                          Nothing
                          false

    -- case 3:
    -- The leading flag matches, there are stacked options, the option takes
    -- no argument and an explicit argument has not been provided.
    go (SOpt f' xs v) _ | (f' == f) && (not takesArg) && (A.length xs > 0)
      = return $ OptParse (D.BoolValue true)
                          (Just $ SOpt (AU.head xs) (AU.tail xs) v)
                          false

    -- case 4:
    -- The leading flag matches, there are no stacked options and the option
    -- takes no argument - total consumption!
    go (SOpt f' xs _) _ | (f' == f) && (not takesArg) && (A.length xs == 0)
      = return $ OptParse (D.BoolValue true)
                          Nothing
                          false

    go a b = Left $ "Invalid token " ++ show a ++ " (input: " ++ show b ++ ")"

eof :: Parser Unit
eof = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return $ case s of
    Nil -> { consumed: false, input: s, result: Right unit, position: pos }
    _   -> P.parseFailed s pos $
              "Trailing input: "
            ++ (intercalate ", " $ prettyPrintToken <$> s)

-- | Generate a parser for a single program usage.
genUsageParser :: D.Usage -> Parser (Tuple D.Branch (List ValueMapping))
genUsageParser (D.Usage xs) = genBranchesParser xs <* eof

-- | Fold over a list of parsers, applying each in turn onto the result of the
-- | previous, keeping both errors and results. Each application of a branches
-- | parser must set out from the same parser state.

-- | Generate a parser that selects the best branch it parses and
-- | fails if no branch was parsed.

genBranchesParser :: List D.Branch
                  -> Parser (Tuple D.Branch (List ValueMapping))
genBranchesParser xs = P.ParserT \(s@(P.PState { input: i, position: pos })) -> do
  env :: D.Env <- ask
  let ps = xs <#> \x -> rmapScoreResult (Tuple x) <$> genBranchParser x
      rs = runReader (collect s ps) env

  -- Weed out successful parses that have a zero-scores, from successful
  -- parses that have a non-zero score. Zero-scores are treated as errors
  -- due to ambiguity if no none-zero score was attained. Should there be
  -- only a single zero-score, however, it can walk away the victor.
  -- XXX: Should the ambiguity rules be extended for any score? I.e. if
  --      there's a total tie across all scores.
  (Tuple zs as) <- return $
    mpartition ((== 0) <<< _.score <<< unScoredResult <<< _.result)
             $ mrights rs

  return $ maybe'
    (\_ ->
      maybe'
        (\_ ->
          -- XXX: The following needs review. Is this safe? correct?
          let h = LU.head zs
            in h { result = Right <<< _.result <<< unScoredResult $ h.result }
        )
        (\e -> e { result = Left e.result })
        (head $ mlefts rs)
    )
    (\r -> r { result = Right <<< _.result <<< unScoredResult $ r.result })
    (maximumBy (compare `on` _.result) as)
  where
    collect s ps = ps `flip traverse` \p -> P.unParserT p s >>= \o ->
                    return $ either
                      (\e -> Left  { input:    o.input
                                   , consumed: o.consumed
                                   , position: o.position
                                   , result:   e
                                   })
                      (\r -> Right { input:    o.input
                                   , consumed: o.consumed
                                   , position: o.position
                                   , result:   r
                                   })
                      o.result

-- | Generate a parser for a single usage branch
genBranchParser :: D.Branch -> Parser (ScoredResult (List ValueMapping))
genBranchParser (D.Branch xs) = do
  either
    (\_   -> P.fail "Failed to generate parser")
    (\acc -> case acc of
              Free p       -> p
              Pending p xs -> do
                r  <- p
                rs <- genExhaustiveParser xs
                return $ r ++ rs
    )
    (foldM step (Free $ pure mempty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    genExhaustiveParser :: List D.Argument
                        -> Parser (ScoredResult (List ValueMapping))
    genExhaustiveParser Nil = return mempty
    genExhaustiveParser ps  = do
      draw ps (length ps)
      where
        -- iterate over `ps` until a match `x` is found, then, recursively
        -- apply `draw` until the parser fails, with a modified `ps`.
        draw :: List D.Argument -- ^ the arguments to parse
             -> Int             -- ^ the number of options left to parse
             -> Parser (ScoredResult (List ValueMapping))

        draw pss@(Cons p ps') n | n >= 0 = (do
          r <- unScoredResult <$> genParser p

          -- verify the arguments for parsed set of options
          -- when an option takes anything but a bool value, i.e. it is not
          -- a flag, an explicit argument *must* be provided.
          let ys = fst <$> flip filter r.result
                    (\(Tuple a v) -> (D.takesArgument a)
                                  && (not $ D.isFlag a)
                                  && (D.isBoolValue v))

          if (length ys == 0)
            then return unit
            else P.fail $ "Missing required arguments for "
                        ++ intercalate ", " (D.prettyPrintArg <$> ys)

          r' <- unScoredResult <$> do
                  if D.isRepeatable p
                        then draw pss (length pss)
                        else draw ps' (length ps')

          return $ ScoredResult r ++ ScoredResult r'
        ) <|> (defer \_ -> draw (ps' ++ singleton p) (n - 1))

        draw ps' n | (length ps' > 0) && (n < 0) = do
          env <- lift ask
          let missing = filter (\o -> not $ D.isRepeatable  o
                                         || D.hasDefault    o
                                         || D.isFlag        o
                                         || D.hasEnvBacking o env
                               )
                               $ reverse ps'
          if (length missing > 0)
            then P.fail $
              "Missing required options: "
                ++ intercalate ", " (D.prettyPrintArg <$> missing)
            else return mempty

        draw _ _ = return mempty

    step :: Acc (ScoredResult (List ValueMapping))
         -> D.Argument
         -> Either P.ParseError (Acc (ScoredResult (List ValueMapping)))

    -- Options always transition to the `Pending state`
    step (Free p) x@(D.Option _)
      = return $ Pending p (singleton x)

    step (Free p) x@(D.Group _ bs _) | isFree x
      = return $ Pending p (singleton x)

    -- Any other argument causes immediate evaluation
    step (Free p) x = Right $ Free do
      r  <- p
      rs <- genParser x
      return $ r ++ rs

    -- Options always keep accumulating
    step (Pending p xs) x@(D.Option _) = Right $ Pending p (x:xs)

    -- Any non-options always leaves the pending state
    step (Pending p xs) y = Right $
      Free do
        r   <- p
        rs  <- genExhaustiveParser xs
        rss <- genParser y
        return $ r ++ rs ++ rss

    -- Parser generator for a single `Argument`
    genParser :: D.Argument
              -> Parser (ScoredResult (List ValueMapping))

    -- Generate a parser for a `Command` argument
    genParser x@(D.Command n) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        command n
      ) P.<?> "command: " ++ (show $ D.prettyPrintArg x)

    -- Generate a parser for a `EOA` argument
    genParser x@(D.EOA) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        eoa <|> (return $ D.ArrayValue []) -- XXX: Fix type
      ) P.<?> "end of arguments: \"--\""

    -- Generate a parser for a `Stdin` argument
    genParser x@(D.Stdin) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        -- stdin always succeeds, as it is not actually an argument on argv.
        -- XXX: Should docopt check `process.stdin.isTTY` at this stage, or
        --      even at all?
        return (D.BoolValue true)
      ) P.<?> "stdin: \"-\""

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) = (do
      scoreFromList <$> do
        if r then (some go) else (singleton <$> go)
        ) P.<?> "positional argument: " ++ (show $ D.prettyPrintArg x)
        where go = Tuple x <$> (positional n)

    -- Generate a parser for a `Option` argument
    genParser x@(D.Option (O.Option o)) = (do
      scoreFromList <$> do
        if o.repeatable then (some go) else (singleton <$> go)
        ) P.<?> "option: " ++ (show $ D.prettyPrintArg x)
        where
          go = do
            P.choice $ P.try <$> [
              Tuple x <$> (mkLoptParser o.name o.arg)
            , Tuple x <$> (mkSoptParser o.flag o.arg)
            ]

          mkLoptParser (Just n) a = longOption n a
          mkLoptParser Nothing _  = P.fail "no long name"

          mkSoptParser (Just f) a = shortOption f a
          mkSoptParser Nothing _  = P.fail "no flag"

    -- Generate a parser for an argument `Group`
    -- The total score a group is the sum of all scores inside of it.
    genParser x@(D.Group optional bs repeated) = do
      vs <- concat <$>
          let mod    = if optional then P.try >>> P.option mempty else \p -> p
              parser = if repeated then many go else singleton <$> go
          in mod parser
      return $ scoreFromList vs
      where go = if length bs > 0
                    then snd <$> genBranchesParser bs
                    else return mempty

    isFree :: D.Argument -> Boolean
    isFree (D.Option _)     = true
    isFree (D.Group _ bs _) = all (\(D.Branch b) -> all isFree b) bs
    isFree _                = false

-- | Input Parser Generator for Docopt
-- |
-- | > Given a un-ambigious specification as input, generate a parser that can
-- | > be applied to user input.
-- |
-- | ===

module Language.Docopt.ParserGen.Parser (
    genUsageParser
  , Parser()
  ) where

import Prelude
import Control.Plus (class Plus, empty)
import Debug.Trace
import Data.Identity (Identity(), runIdentity)
import Control.Monad.State (State(), evalState)
import Control.Apply ((*>), (<*))
import Data.Function (on)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, maybe, maybe')
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList, filter, reverse, concat, catMaybes)
import Control.Alt ((<|>))
import Data.Traversable (class Traversable, traverse, for)
import Control.Lazy (defer)
import Data.Foldable (class Foldable, maximum, maximumBy, foldl, intercalate, for_, all)
import Data.String (fromCharArray, stripPrefix)
import Data.Bifunctor (class Bifunctor, rmap)
import Data.List as L
import Data.List.Unsafe as LU
import Data.Array as A
import Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Monoid (Monoid)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Monoid (mempty)
import Data.Map (Map())
import Control.Monad.Reader (Reader(), ask, runReader)
import Data.Map as Map
import Data.StrMap (StrMap())
import Control.Monad.Trans (lift)
import Control.MonadPlus.Partial (mrights, mlefts, mpartition)
import Control.Bind ((=<<))

import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt.Env      as Env
import Language.Docopt.Errors   as D
import Language.Docopt.Value    as D
import Language.Docopt.Argument as D
import Language.Docopt.Usage    as D
import Language.Docopt.Env      as D
import Language.Docopt.Option   as O

import Language.Docopt.ParserGen.Token
import Language.Docopt.ParserGen.ValueMapping
import Language.Docopt.Parser.Base (alphaNum, space, getInput, debug)

type ValueMapping = Tuple D.Argument D.Value
type Parser a = P.ParserT (List Token) (Reader D.Env) a

newtype ScoredResult a = ScoredResult { score :: Int, result :: a }

unScoredResult :: forall a. ScoredResult a -> { score :: Int, result :: a }
unScoredResult (ScoredResult r) = r

instance semigroupScoredResult :: (Semigroup a) => Semigroup (ScoredResult a)
  where append (ScoredResult s) (ScoredResult s')
          = ScoredResult { score:  s.score  + s'.score
                         , result: s.result ++ s'.result }

instance monoidScoredResult :: (Monoid a) => Monoid (ScoredResult a)
  where mempty = ScoredResult { score: 0, result: mempty }

instance showScoredResult :: (Show a) => Show (ScoredResult a)
  where show (ScoredResult { score, result })
          = "ScoredResult " ++ show score ++ ": " ++ show result

instance ordScoredResult :: Ord (ScoredResult a)
  where compare = compare `on` (_.score <<< unScoredResult)

instance eqScoredResult :: Eq (ScoredResult a)
  where eq = eq `on` (_.score <<< unScoredResult)

scoreFromList :: forall a. List a -> ScoredResult (List a)
scoreFromList xs = ScoredResult { score: length xs, result: xs }

rmapScoreResult :: forall a b. (a -> b) -> ScoredResult a -> ScoredResult b
rmapScoreResult f (ScoredResult (x@{ result })) = ScoredResult $ x { result = f result }

--------------------------------------------------------------------------------
-- Input Token Parser ----------------------------------------------------------
--------------------------------------------------------------------------------

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> Parser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case test tok of
        Just a ->
          let nextpos = pos -- neglect pos (for now)
          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"

data Acc a
  = Free (Parser a)
  | Pending (Parser a) (List D.Argument)

eoa :: Parser D.Value
eoa = token go P.<?> "--"
  where
    go (EOA xs) = Just (D.ArrayValue (fromList xs))
    go _        = Nothing

command :: String -> Parser D.Value
command n = token go P.<?> "command " ++ show n
  where
    go (Lit s) | s == n = Just (D.BoolValue true)
    go _                = Nothing

positional :: String -> Parser D.Value
positional n = token go P.<?> "positional argument " ++ show n
  where
    go (Lit v) = Just (D.StringValue v)
    go _       = Nothing

type HasConsumedArg = Boolean
data OptParse = OptParse D.Value (Maybe Token) HasConsumedArg

longOption :: O.Name -> (Maybe O.Argument) -> Parser D.Value
longOption n a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos (for now)
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    takesArg = isJust a

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | takesArg && (n' == n)
      = case v of
          Just s ->
            return $ OptParse (D.StringValue s) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s)  Nothing true
            _            -> OptParse (D.BoolValue true) Nothing false

    -- case 2:
    -- The name is an exact match and takes no argument
    go (LOpt n' _) _ | (not takesArg) && (n' == n)
      = return $ OptParse (D.BoolValue true) Nothing false

    -- case 3:
    -- The name is a substring of the input and no explicit argument has been
    -- provdided.
    go (LOpt n' Nothing) atok | takesArg
      = case stripPrefix n n' of
          Just s -> return $ OptParse (D.StringValue s) Nothing false
          _      -> Left "Invalid substring"

    go _ _ = Left "Invalid token"

shortOption :: Char -> (Maybe O.Argument) -> Parser D.Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    takesArg = isJust a

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && takesArg && (A.length xs == 0)
      = case v of
          Just val -> return $ OptParse (D.StringValue val) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s) Nothing true
            _ -> OptParse (D.BoolValue true)
                          Nothing
                          false

    -- case 2:
    -- The leading flag matches, there are stacked options, no explicit
    -- argument has been passed and the option takes an argument.
    go (SOpt f' xs v) _ | (f' == f) && takesArg && (A.length xs > 0)
      = do
        let a = fromCharArray xs ++ maybe "" id v
        return $ OptParse (D.StringValue a)
                          Nothing
                          false

    -- case 3:
    -- The leading flag matches, there are stacked options, the option takes
    -- no argument and an explicit argument has not been provided.
    go (SOpt f' xs v) _ | (f' == f) && (not takesArg) && (A.length xs > 0)
      = return $ OptParse (D.BoolValue true)
                          (Just $ SOpt (AU.head xs) (AU.tail xs) v)
                          false

    -- case 4:
    -- The leading flag matches, there are no stacked options and the option
    -- takes no argument - total consumption!
    go (SOpt f' xs _) _ | (f' == f) && (not takesArg) && (A.length xs == 0)
      = return $ OptParse (D.BoolValue true)
                          Nothing
                          false

    go a b = Left $ "Invalid token " ++ show a ++ " (input: " ++ show b ++ ")"

eof :: Parser Unit
eof = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return $ case s of
    Nil -> { consumed: false, input: s, result: Right unit, position: pos }
    _   -> P.parseFailed s pos $
              "Trailing input: "
            ++ (intercalate ", " $ prettyPrintToken <$> s)

-- | Generate a parser for a single program usage.
genUsageParser :: D.Usage -> Parser (Tuple D.Branch (List ValueMapping))
genUsageParser (D.Usage xs) = genBranchesParser xs <* eof

-- | Fold over a list of parsers, applying each in turn onto the result of the
-- | previous, keeping both errors and results. Each application of a branches
-- | parser must set out from the same parser state.

-- | Generate a parser that selects the best branch it parses and
-- | fails if no branch was parsed.

genBranchesParser :: List D.Branch
                  -> Parser (Tuple D.Branch (List ValueMapping))
genBranchesParser xs = P.ParserT \(s@(P.PState { input: i, position: pos })) -> do
  env :: D.Env <- ask
  let ps = xs <#> \x -> rmapScoreResult (Tuple x) <$> genBranchParser x
      rs = runReader (collect s ps) env

  -- Weed out successful parses that have a zero-scores, from successful
  -- parses that have a non-zero score. Zero-scores are treated as errors
  -- due to ambiguity if no none-zero score was attained. Should there be
  -- only a single zero-score, however, it can walk away the victor.
  -- XXX: Should the ambiguity rules be extended for any score? I.e. if
  --      there's a total tie across all scores.
  (Tuple zs as) <- return $
    mpartition ((== 0) <<< _.score <<< unScoredResult <<< _.result)
             $ mrights rs

  return $ maybe'
    (\_ ->
      maybe'
        (\_ ->
          -- XXX: The following needs review. Is this safe? correct?
          let h = LU.head zs
            in h { result = Right <<< _.result <<< unScoredResult $ h.result }
        )
        (\e -> e { result = Left e.result })
        (head $ mlefts rs)
    )
    (\r -> r { result = Right <<< _.result <<< unScoredResult $ r.result })
    (maximumBy (compare `on` _.result) as)
  where
    collect s ps = ps `flip traverse` \p -> P.unParserT p s >>= \o ->
                    return $ either
                      (\e -> Left  { input:    o.input
                                   , consumed: o.consumed
                                   , position: o.position
                                   , result:   e
                                   })
                      (\r -> Right { input:    o.input
                                   , consumed: o.consumed
                                   , position: o.position
                                   , result:   r
                                   })
                      o.result

-- | Generate a parser for a single usage branch
genBranchParser :: D.Branch -> Parser (ScoredResult (List ValueMapping))
genBranchParser (D.Branch xs) = do
  either
    (\_   -> P.fail "Failed to generate parser")
    (\acc -> case acc of
              Free p       -> p
              Pending p xs -> do
                r  <- p
                rs <- genExhaustiveParser xs
                return $ r ++ rs
    )
    (foldM step (Free $ pure mempty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    genExhaustiveParser :: List D.Argument
                        -> Parser (ScoredResult (List ValueMapping))
    genExhaustiveParser Nil = return mempty
    genExhaustiveParser ps  = do
      draw ps (length ps)
      where
        -- iterate over `ps` until a match `x` is found, then, recursively
        -- apply `draw` until the parser fails, with a modified `ps`.
        draw :: List D.Argument -- ^ the arguments to parse
             -> Int             -- ^ the number of options left to parse
             -> Parser (ScoredResult (List ValueMapping))

        draw pss@(Cons p ps') n | n >= 0 = (do
          r <- unScoredResult <$> genParser p

          -- verify the arguments for parsed set of options
          -- when an option takes anything but a bool value, i.e. it is not
          -- a flag, an explicit argument *must* be provided.
          let ys = fst <$> flip filter r.result
                    (\(Tuple a v) -> (D.takesArgument a)
                                  && (not $ D.isFlag a)
                                  && (D.isBoolValue v))

          if (length ys == 0)
            then return unit
            else P.fail $ "Missing required arguments for "
                        ++ intercalate ", " (D.prettyPrintArg <$> ys)

          r' <- unScoredResult <$> do
                  if D.isRepeatable p
                        then draw pss (length pss)
                        else draw ps' (length ps')

          return $ ScoredResult r ++ ScoredResult r'
        ) <|> (defer \_ -> draw (ps' ++ singleton p) (n - 1))

        draw ps' n | (length ps' > 0) && (n < 0) = do
          env <- lift ask
          let missing = filter (\o -> not $ D.isRepeatable  o
                                         || D.hasDefault    o
                                         || D.isFlag        o
                                         || D.hasEnvBacking o env
                               )
                               $ reverse ps'
          if (length missing > 0)
            then P.fail $
              "Missing required options: "
                ++ intercalate ", " (D.prettyPrintArg <$> missing)
            else return mempty

        draw _ _ = return mempty

    step :: Acc (ScoredResult (List ValueMapping))
         -> D.Argument
         -> Either P.ParseError (Acc (ScoredResult (List ValueMapping)))

    -- Options always transition to the `Pending state`
    step (Free p) x@(D.Option _)
      = return $ Pending p (singleton x)

    step (Free p) x@(D.Group _ bs _) | isFree x
      = return $ Pending p (singleton x)

    -- Any other argument causes immediate evaluation
    step (Free p) x = Right $ Free do
      r  <- p
      rs <- genParser x
      return $ r ++ rs

    -- Options always keep accumulating
    step (Pending p xs) x@(D.Option _) = Right $ Pending p (x:xs)

    -- Any non-options always leaves the pending state
    step (Pending p xs) y = Right $
      Free do
        r   <- p
        rs  <- genExhaustiveParser xs
        rss <- genParser y
        return $ r ++ rs ++ rss

    -- Parser generator for a single `Argument`
    genParser :: D.Argument
              -> Parser (ScoredResult (List ValueMapping))

    -- Generate a parser for a `Command` argument
    genParser x@(D.Command n) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        command n
      ) P.<?> "command: " ++ (show $ D.prettyPrintArg x)

    -- Generate a parser for a `EOA` argument
    genParser x@(D.EOA) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        eoa <|> (return $ D.ArrayValue []) -- XXX: Fix type
      ) P.<?> "end of arguments: \"--\""

    -- Generate a parser for a `Stdin` argument
    genParser x@(D.Stdin) = (do
      scoreFromList <<< singleton <<< Tuple x <$> do
        -- stdin always succeeds, as it is not actually an argument on argv.
        -- XXX: Should docopt check `process.stdin.isTTY` at this stage, or
        --      even at all?
        return (D.BoolValue true)
      ) P.<?> "stdin: \"-\""

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) = (do
      scoreFromList <$> do
        if r then (some go) else (singleton <$> go)
        ) P.<?> "positional argument: " ++ (show $ D.prettyPrintArg x)
        where go = Tuple x <$> (positional n)

    -- Generate a parser for a `Option` argument
    genParser x@(D.Option (O.Option o)) = (do
      scoreFromList <$> do
        if o.repeatable then (some go) else (singleton <$> go)
        ) P.<?> "option: " ++ (show $ D.prettyPrintArg x)
        where
          go = do
            P.choice $ P.try <$> [
              Tuple x <$> (mkLoptParser o.name o.arg)
            , Tuple x <$> (mkSoptParser o.flag o.arg)
            ]

          mkLoptParser (Just n) a = longOption n a
          mkLoptParser Nothing _  = P.fail "no long name"

          mkSoptParser (Just f) a = shortOption f a
          mkSoptParser Nothing _  = P.fail "no flag"

    -- Generate a parser for an argument `Group`
    -- The total score a group is the sum of all scores inside of it.
    genParser x@(D.Group optional bs repeated) = do
      vs <- concat <$>
          let mod    = if optional then P.try >>> P.option mempty else \p -> p
              parser = if repeated then many go else singleton <$> go
          in mod parser
      return $ scoreFromList vs
      where go = if length bs > 0
                    then snd <$> genBranchesParser bs
                    else return mempty

    isFree :: D.Argument -> Boolean
    isFree (D.Option _)     = true
    isFree (D.Group _ bs _) = all (\(D.Branch b) -> all isFree b) bs
    isFree _                = false


[CSE-102] Slow down requests

[CSE-102] Slow down requests

module Main where

import Prelude (($), (<$>), (<<<), bind, pure, const, (*))
import Control.Bind ((=<<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Now (NOW, nowDateTime)
import Control.SocketIO.Client (SocketIO, connect, on)
import Control.Comonad (extract)
import DOM (DOM)
import Data.Lens (set)
import Data.Maybe (Maybe(..))
import Explorer.Api.Socket (toEvent)
import Explorer.Api.Socket (blocksUpdatedEventHandler, callYouEventHandler, callYouStringEventHandler, callYouCTxIdEventHandler, mkSocketHost, connectEvent, closeEvent, connectHandler, closeHandler, txsUpdatedHandler) as Ex
import Explorer.Lenses.State (connection, socket)
import Explorer.Routes (match)
import Explorer.Types.Actions (Action(..)) as Ex
import Explorer.Types.State (State) as Ex
import Explorer.Update (update) as Ex
import Explorer.Util.Config (hostname, secureProtocol)
import Explorer.View.Layout (view)
import Network.HTTP.Affjax (AJAX)
import Pos.Explorer.Socket.Methods (ServerEvent(..))
import Pux (App, Config, CoreEffects, Update, renderToDOM, start)
import Pux.Devtool (Action, start) as Pux.Devtool
import Pux.Router (sampleUrl)
import Signal (Signal, (~>))
import Signal.Time (every, second)
import Signal.Channel (channel, subscribe)

type AppEffects = (dom :: DOM, ajax :: AJAX, socket :: SocketIO, now :: NOW)

config :: Ex.State -> Eff (CoreEffects AppEffects) (Config Ex.State Ex.Action AppEffects)
config state = do
  -- routing
  urlSignal <- sampleUrl
  let routeSignal = urlSignal ~> Ex.UpdateView <<< match
  let clockSignal = every second ~> const Ex.UpdateClock
  let reloadSignal = every (60.0 * second) ~> const Ex.Reload
  -- socket
--  actionChannel <- channel $ Ex.SocketConnected false
--  let socketSignal = subscribe actionChannel :: Signal Ex.Action
--  socketHost <- Ex.mkSocketHost (secureProtocol false) <$> hostname
--  socket' <- connect socketHost
--  on socket' Ex.connectEvent $ Ex.connectHandler actionChannel
--  on socket' Ex.closeEvent $ Ex.closeHandler actionChannel
--  on socket' (toEvent TxsUpdated) $ Ex.txsUpdatedHandler actionChannel
--  on socket' (toEvent BlocksUpdated) $ Ex.blocksUpdatedEventHandler actionChannel
--  on socket' (toEvent CallYou) $ Ex.callYouEventHandler actionChannel
--  on socket' (toEvent CallYouString) $ Ex.callYouStringEventHandler actionChannel
--  on socket' (toEvent CallYouTxId) $ Ex.callYouCTxIdEventHandler actionChannel
  dt <- extract <$> nowDateTime

  pure
    { initialState: set (socket <<< connection) Nothing state
    , update: Ex.update :: Update Ex.State Ex.Action AppEffects
    , view: view
    , inputs: [clockSignal, reloadSignal, routeSignal]
    }

appSelector :: String
appSelector = "#explorer"

main :: Ex.State -> Eff (CoreEffects AppEffects) (App Ex.State Ex.Action)
main state = do
  app <- start =<< config state
  renderToDOM appSelector app.html
  pure app

debug :: Ex.State -> Eff (CoreEffects AppEffects) (App Ex.State (Pux.Devtool.Action Ex.Action))
debug state = do
  appConfig <- config state
  app <- Pux.Devtool.start appConfig {opened: false}
  renderToDOM appSelector app.html
  pure app

module Main where

import Prelude (($), (<$>), (<<<), bind, pure, const, (*))
import Control.Bind ((=<<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Now (NOW, nowDateTime)
import Control.SocketIO.Client (SocketIO, connect, on)
import Control.Comonad (extract)
import DOM (DOM)
import Data.Lens (set)
import Data.Maybe (Maybe(..))
import Explorer.Api.Socket (toEvent)
import Explorer.Api.Socket (blocksUpdatedEventHandler, callYouEventHandler, callYouStringEventHandler, callYouCTxIdEventHandler, mkSocketHost, connectEvent, closeEvent, connectHandler, closeHandler, txsUpdatedHandler) as Ex
import Explorer.Lenses.State (connection, socket)
import Explorer.Routes (match)
import Explorer.Types.Actions (Action(..)) as Ex
import Explorer.Types.State (State) as Ex
import Explorer.Update (update) as Ex
import Explorer.Util.Config (hostname, secureProtocol)
import Explorer.View.Layout (view)
import Network.HTTP.Affjax (AJAX)
import Pos.Explorer.Socket.Methods (ServerEvent(..))
import Pux (App, Config, CoreEffects, Update, renderToDOM, start)
import Pux.Devtool (Action, start) as Pux.Devtool
import Pux.Router (sampleUrl)
import Signal (Signal, (~>))
import Signal.Time (every, second)
import Signal.Channel (channel, subscribe)

type AppEffects = (dom :: DOM, ajax :: AJAX, socket :: SocketIO, now :: NOW)

config :: Ex.State -> Eff (CoreEffects AppEffects) (Config Ex.State Ex.Action AppEffects)
config state = do
  -- routing
  urlSignal <- sampleUrl
  let routeSignal = urlSignal ~> Ex.UpdateView <<< match
  let clockSignal = every second ~> const Ex.UpdateClock
  let reloadSignal = every (10.0 * second) ~> const Ex.Reload
  -- socket
--  actionChannel <- channel $ Ex.SocketConnected false
--  let socketSignal = subscribe actionChannel :: Signal Ex.Action
--  socketHost <- Ex.mkSocketHost (secureProtocol false) <$> hostname
--  socket' <- connect socketHost
--  on socket' Ex.connectEvent $ Ex.connectHandler actionChannel
--  on socket' Ex.closeEvent $ Ex.closeHandler actionChannel
--  on socket' (toEvent TxsUpdated) $ Ex.txsUpdatedHandler actionChannel
--  on socket' (toEvent BlocksUpdated) $ Ex.blocksUpdatedEventHandler actionChannel
--  on socket' (toEvent CallYou) $ Ex.callYouEventHandler actionChannel
--  on socket' (toEvent CallYouString) $ Ex.callYouStringEventHandler actionChannel
--  on socket' (toEvent CallYouTxId) $ Ex.callYouCTxIdEventHandler actionChannel
  dt <- extract <$> nowDateTime

  pure
    { initialState: set (socket <<< connection) Nothing state
    , update: Ex.update :: Update Ex.State Ex.Action AppEffects
    , view: view
    , inputs: [clockSignal, reloadSignal, routeSignal]
    }

appSelector :: String
appSelector = "#explorer"

main :: Ex.State -> Eff (CoreEffects AppEffects) (App Ex.State Ex.Action)
main state = do
  app <- start =<< config state
  renderToDOM appSelector app.html
  pure app

debug :: Ex.State -> Eff (CoreEffects AppEffects) (App Ex.State (Pux.Devtool.Action Ex.Action))
debug state = do
  appConfig <- config state
  app <- Pux.Devtool.start appConfig {opened: false}
  renderToDOM appSelector app.html
  pure app


Add basic/placeholder config type for Cy.js graphs

module Genetics.Browser.Config.Track
       ( BDTrackConfig
       , makeBDTrack
       , validateBDConfig
       , CyGraphConfig
       , makeCyTrack
       , validateCyConfig
       , TrackType
       )
       where

import Prelude
import Data.Argonaut (Json, _Object, _String)
import Data.Either (Either(..))
import Data.Foreign (Foreign, toForeign)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..))

newtype TrackType = TrackType String

-- derive instance newtypeTrackType :: Newtype TrackType _
derive instance eqTrackType :: Eq TrackType
derive instance ordTrackType :: Ord TrackType

bdTrack = TrackType "BDTrack"
cyGraph = TrackType "CyGraph"

getTrackType :: Json -> Maybe TrackType
getTrackType json = case json ^? _Object <<< ix "trackType" <<< _String of
  -- must be better ways of encoding this. this is ripe for programmer error
  Just "BDTrack" -> Just bdTrack
  Just "CyGraph" -> Just cyGraph
  _ -> Nothing

newtype BDTrackConfig = BDTrackConfig Foreign

makeBDTrack :: ∀ r. { trackType :: TrackType, name :: String | r } -> BDTrackConfig
makeBDTrack = BDTrackConfig <<< toForeign

validateBDConfig :: Json -> Either String BDTrackConfig
validateBDConfig json =
  case getTrackType json of
    Nothing -> Left $ "Track has no type"
    Just cyGraph -> Left $ ""
    Just bdTrack -> case json ^? _Object <<< ix "name" of
      Nothing -> Left $ "BD track config does not have a name"
      Just c  -> Right $ BDTrackConfig $ toForeign json

-- Maybe this should be in another file (one not called 'Track')
newtype CyGraphConfig = CyGraphConfig Foreign

makeCyTrack :: ∀ r. { trackType :: TrackType, elementsUri :: String } -> CyGraphConfig
makeCyTrack = CyGraphConfig <<< toForeign

-- this and validateBDConfig must be able to be simplified;
-- there are two levels of validation, first checking it's a track at all,
-- then validating the specific track type
validateCyConfig :: Json -> Either String CyGraphConfig
validateCyConfig json = do
  case getTrackType json of
    Nothing -> Left $ "Track has no type"
    Just bdTrack -> Left $ ""
    Just cyGraph -> case json ^? _Object <<< ix "elementsUri" of
      Nothing -> Left $ "cy graph config does not have an elementsUri"
      Just c  -> Right $ CyGraphConfig $ toForeign json

-- TODO: combine validateBDConfig and validateCyConfig
-- validateTrackConfig :: Json -> Either String (Either BDTrackConfig CyGraphConfig)
-- validateTrackConfig :: Json -> Either String (Either3 BDTrackConfig PSTrackConfig CyGraphConfig)

module Genetics.Browser.Config.Track
       where

import Prelude
import Data.Argonaut (Json, _Object)
import Data.Either (Either(..))
import Data.Foreign (Foreign, toForeign)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..))

-- TODO add some BD validation
newtype BDTrackConfig = BDTrackConfig Foreign

makeBDTrack :: ∀ r. { name :: String | r } -> BDTrackConfig
makeBDTrack = (BDTrackConfig <<< toForeign)

validateBDConfig :: Json -> Either String BDTrackConfig
validateBDConfig json = case json ^? _Object <<< ix "name" of
  Nothing -> Left $ "BD track config does not have a name"
  Just c  -> Right $ BDTrackConfig $ toForeign json


Fix doc-comments: Eff -> Effect (#27)

Fix doc-comments: Eff -> Effect (#27)

-- | This module provides a way of dealing with the JS idiom of options
-- | objects in PureScript, by giving you the tools to provide a reasonably
-- | comfortable typed layer on top of JavaScript APIs which make use of this
-- | idiom.
-- |
-- | Many JavaScript APIs include functions which take an object argument,
-- | where the object's properties come from a fixed set of optional
-- | configuration values. For example, the `createWriteStream` function from
-- | the Node.js `fs` module may contain properties such as:
-- |
-- | - `flags`, which should be a `String`, such as `"w"`, `"rw"`, or `"r+"`,
-- | - `defaultEncoding`, which should be a `String` representing an
-- |   encoding, such as `"utf8"`,
-- |
-- | and so on.
-- |
-- | PureScript's record types can be a little awkward for this, since it is
-- | usually the case that any subset of these properties can be specified;
-- | however, a value of  type `{ flags :: String, defaultEncoding :: String, [...] }`
-- | must include every property listed, even if you only want to specify
-- | one or two properties.
-- |
-- | Using this module, you could wrap `fs.createWriteStream` as follows:
-- |
-- | First, create a phantom type used for the options object:
-- |
-- | ```purescript
-- | data CreateWriteStreamOptions
-- | ```
-- |
-- | Then, create `Option` values for each of the options:
-- |
-- | ```purescript
-- | flags :: Option CreateWriteStreamOptions String
-- | flags = opt "flags"
-- |
-- | defaultEncoding :: Option CreateWriteStreamOptions String
-- | defaultEncoding = opt "defaultEncoding"
-- |
-- | -- and so on
-- | ```
-- |
-- | Import the function you're wrapping using the FFI, using the `Foreign`
-- | type for the options object:
-- |
-- | ```purescript
-- | -- don't export this!
-- | foreign import createWriteStreamImpl :: forall eff. FilePath -> Foreign -> Effect Unit
-- | ```
-- |
-- | Finally, in the function you are going to export, take an `Options` value
-- | for the options argument, and use the `options` function provided by this
-- | library to convert it into a `Foreign` value, which will then have a
-- | suitable representation for passing to the JavaScript API.
-- |
-- | ```
-- | createWriteStream :: forall eff. FilePath -> Options CreateWriteStreamOptions -> Effect Unit
-- | createWriteStream path opts = createWriteStreamImpl path (options opts)
-- | ```
-- |
-- | Then, users of your API can create `Options` values using the `:=`
-- | operator to assign values for the options they want to configure, and the
-- | `Monoid Options` instance to combine them. For example, as a user of this
-- | API, you might write:
-- |
-- | ```purescript
-- | FS.createWriteStream "file.txt" $
-- |    defaultEncoding := "utf8" <>
-- |    flags := "rw"
-- | ```
-- |
-- | You can also use more specific types for more type safety. For example,
-- | it would be safer to use the existing `FileFlags` and `Encoding` types
-- | already provided by the `node-fs` library. However, we cannot use them
-- | directly because they will have the wrong runtime representation. This is
-- | where the `Contravariant` instance for `Option` comes in; it can be used
-- | to transform an option's value to give it a suitable runtime
-- | representation based on what the JS API is expecting. For example:
-- |
-- | ```purescript
-- | flags :: Option CreateWriteStreamOptions FileFlags
-- | flags = cmap fileFlagsToNode (opt "flags")
-- | ```
-- |
-- | Note that `fileFlagsToNode` takes a `FileFlags` and returns a `String`
-- | suitable for passing to a Node.js API.
module Data.Options
  ( Options(..)
  , options
  , Option
  , assoc, (:=)
  , optional
  , opt
  , tag
  , defaultToOptions
  ) where

import Prelude

import Data.Maybe (Maybe, maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Op (Op(..))
import Data.Tuple (Tuple(..))
import Foreign (Foreign, unsafeToForeign)
import Foreign.Object as Object

-- | The `Options` type represents a set of options. The type argument is a
-- | phantom type, which is useful for ensuring that options for one particular
-- | API are not accidentally passed to some other API.
newtype Options opt = Options (Array (Tuple String Foreign))

derive instance newtypeOptions :: Newtype (Options opt) _
derive newtype instance semigroupOptions ∷ Semigroup (Options opt)
derive newtype instance monoidOptions ∷ Monoid (Options opt)

-- | Convert an `Options` value into a JavaScript object, suitable for passing
-- | to JavaScript APIs.
options :: forall opt. Options opt -> Foreign
options (Options os) = unsafeToForeign (Object.fromFoldable os)

-- | An `Option` represents an opportunity to configure a specific attribute
-- | of a call to some API. This normally corresponds to one specific property
-- | of an "options" object in JavaScript APIs, but can in general correspond
-- | to zero or more actual properties.
type Option opt = Op (Options opt)

-- | Associates a value with a specific option.
assoc :: forall opt value. Option opt value -> value -> Options opt
assoc = unwrap

-- | An infix version of `assoc`.
infixr 6 assoc as :=

-- | A version of `assoc` which takes possibly absent values. `Nothing` values
-- | are ignored; passing `Nothing` for the second argument will result in an
-- | empty `Options`.
optional :: forall opt value. Option opt value -> Option opt (Maybe value)
optional option = Op $ maybe mempty (option := _)

-- | The default way of creating `Option` values. Constructs an `Option` with
-- | the given key, which passes the given value through unchanged.
opt :: forall opt value. String -> Option opt value
opt = Op <<< defaultToOptions

-- | Create a `tag`, by fixing an `Option` to a single value.
tag :: forall opt value. Option opt value -> value -> Option opt Unit
tag o value = Op \_ -> o := value

-- | The default method for turning a string property key into an
-- | `Option`. This function simply calls `unsafeToForeign` on the value. If
-- | you need some other behaviour, you can write your own function to replace
-- | this one, and construct an `Option` yourself.
defaultToOptions :: forall opt value. String -> value -> Options opt
defaultToOptions k v = Options [Tuple k (unsafeToForeign v)]

-- | This module provides a way of dealing with the JS idiom of options
-- | objects in PureScript, by giving you the tools to provide a reasonably
-- | comfortable typed layer on top of JavaScript APIs which make use of this
-- | idiom.
-- |
-- | Many JavaScript APIs include functions which take an object argument,
-- | where the object's properties come from a fixed set of optional
-- | configuration values. For example, the `createWriteStream` function from
-- | the Node.js `fs` module may contain properties such as:
-- |
-- | - `flags`, which should be a `String`, such as `"w"`, `"rw"`, or `"r+"`,
-- | - `defaultEncoding`, which should be a `String` representing an
-- |   encoding, such as `"utf8"`,
-- |
-- | and so on.
-- |
-- | PureScript's record types can be a little awkward for this, since it is
-- | usually the case that any subset of these properties can be specified;
-- | however, a value of  type `{ flags :: String, defaultEncoding :: String, [...] }`
-- | must include every property listed, even if you only want to specify
-- | one or two properties.
-- |
-- | Using this module, you could wrap `fs.createWriteStream` as follows:
-- |
-- | First, create a phantom type used for the options object:
-- |
-- | ```purescript
-- | data CreateWriteStreamOptions
-- | ```
-- |
-- | Then, create `Option` values for each of the options:
-- |
-- | ```purescript
-- | flags :: Option CreateWriteStreamOptions String
-- | flags = opt "flags"
-- |
-- | defaultEncoding :: Option CreateWriteStreamOptions String
-- | defaultEncoding = opt "defaultEncoding"
-- |
-- | -- and so on
-- | ```
-- |
-- | Import the function you're wrapping using the FFI, using the `Foreign`
-- | type for the options object:
-- |
-- | ```purescript
-- | -- don't export this!
-- | foreign import createWriteStreamImpl :: forall eff. FilePath -> Foreign -> Eff (fs :: FS | eff) Unit
-- | ```
-- |
-- | Finally, in the function you are going to export, take an `Options` value
-- | for the options argument, and use the `options` function provided by this
-- | library to convert it into a `Foreign` value, which will then have a
-- | suitable representation for passing to the JavaScript API.
-- |
-- | ```
-- | createWriteStream :: forall eff. FilePath -> Options CreateWriteStreamOptions -> Eff (fs :: FS | eff) Unit
-- | createWriteStream path opts = createWriteStreamImpl path (options opts)
-- | ```
-- |
-- | Then, users of your API can create `Options` values using the `:=`
-- | operator to assign values for the options they want to configure, and the
-- | `Monoid Options` instance to combine them. For example, as a user of this
-- | API, you might write:
-- |
-- | ```purescript
-- | FS.createWriteStream "file.txt" $
-- |    defaultEncoding := "utf8" <>
-- |    flags := "rw"
-- | ```
-- |
-- | You can also use more specific types for more type safety. For example,
-- | it would be safer to use the existing `FileFlags` and `Encoding` types
-- | already provided by the `node-fs` library. However, we cannot use them
-- | directly because they will have the wrong runtime representation. This is
-- | where the `Contravariant` instance for `Option` comes in; it can be used
-- | to transform an option's value to give it a suitable runtime
-- | representation based on what the JS API is expecting. For example:
-- |
-- | ```purescript
-- | flags :: Option CreateWriteStreamOptions FileFlags
-- | flags = cmap fileFlagsToNode (opt "flags")
-- | ```
-- |
-- | Note that `fileFlagsToNode` takes a `FileFlags` and returns a `String`
-- | suitable for passing to a Node.js API.
module Data.Options
  ( Options(..)
  , options
  , Option
  , assoc, (:=)
  , optional
  , opt
  , tag
  , defaultToOptions
  ) where

import Prelude

import Data.Maybe (Maybe, maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Op (Op(..))
import Data.Tuple (Tuple(..))
import Foreign (Foreign, unsafeToForeign)
import Foreign.Object as Object

-- | The `Options` type represents a set of options. The type argument is a
-- | phantom type, which is useful for ensuring that options for one particular
-- | API are not accidentally passed to some other API.
newtype Options opt = Options (Array (Tuple String Foreign))

derive instance newtypeOptions :: Newtype (Options opt) _
derive newtype instance semigroupOptions ∷ Semigroup (Options opt)
derive newtype instance monoidOptions ∷ Monoid (Options opt)

-- | Convert an `Options` value into a JavaScript object, suitable for passing
-- | to JavaScript APIs.
options :: forall opt. Options opt -> Foreign
options (Options os) = unsafeToForeign (Object.fromFoldable os)

-- | An `Option` represents an opportunity to configure a specific attribute
-- | of a call to some API. This normally corresponds to one specific property
-- | of an "options" object in JavaScript APIs, but can in general correspond
-- | to zero or more actual properties.
type Option opt = Op (Options opt)

-- | Associates a value with a specific option.
assoc :: forall opt value. Option opt value -> value -> Options opt
assoc = unwrap

-- | An infix version of `assoc`.
infixr 6 assoc as :=

-- | A version of `assoc` which takes possibly absent values. `Nothing` values
-- | are ignored; passing `Nothing` for the second argument will result in an
-- | empty `Options`.
optional :: forall opt value. Option opt value -> Option opt (Maybe value)
optional option = Op $ maybe mempty (option := _)

-- | The default way of creating `Option` values. Constructs an `Option` with
-- | the given key, which passes the given value through unchanged.
opt :: forall opt value. String -> Option opt value
opt = Op <<< defaultToOptions

-- | Create a `tag`, by fixing an `Option` to a single value.
tag :: forall opt value. Option opt value -> value -> Option opt Unit
tag o value = Op \_ -> o := value

-- | The default method for turning a string property key into an
-- | `Option`. This function simply calls `unsafeToForeign` on the value. If
-- | you need some other behaviour, you can write your own function to replace
-- | this one, and construct an `Option` yourself.
defaultToOptions :: forall opt value. String -> value -> Options opt
defaultToOptions k v = Options [Tuple k (unsafeToForeign v)]


Renamed function to make it more clear

Renamed function to make it more clear

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events
import Data.DOM.Simple.Window
import Data.Int
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  { player: player,
    color:  if player == playerOne then colorPlayerOne else colorPlayerTwo,
    king:   false }

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:                  createGrid offset width height layers,
    currentPlayer:         playerOne,
    selectedCoordinate:    Nothing,
    highlightedCoordinate: Nothing }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

hasPlayer :: Player -> Piece -> Boolean
hasPlayer player piece = piece.player == player

hasCoordinate :: Coordinate -> Square -> Boolean
hasCoordinate coordinate square = coordinate == square.coordinate

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  fromMaybe Nothing $ (squares !!) <$> (findIndex (hasCoordinate coordinate) squares)

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> fromMaybe false $ (hasPlayer player) <$> square.piece

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares coordinate playerOne ||
  hasPlayerPiece squares coordinate playerTwo

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -2 : (-1 : (1 : (singleton 2)))
  j <- -2 : (-1 : (1 : (singleton 2)))
  return (Tuple (x + i) (y + j))

isOnSquare :: Pixel -> Square -> Boolean
isOnSquare (Tuple x y) square =
  let px = square.render + square.offset
      px' = px + (Tuple renderSize renderSize)
  in fst px < x && x < fst px' && snd px < y && y < snd px'

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare pixel square && not (null moves)

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel =
  case findIndex (isOnActiveSquare grid player pixel) grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

findCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
findCoordinate grid player pixel =
  case findIndex (isOnSquare pixel) grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

getHighlightCoordinate :: State -> Pixel -> Maybe Coordinate
getHighlightCoordinate state pixel =
  case findCoordinate state.grid state.currentPlayer pixel of
    Nothing -> Nothing
    Just to -> do
      case state.selectedCoordinate of
        Nothing -> getActiveCoordinate state.grid state.currentPlayer pixel
        Just from ->
          if isValidMove state.grid state.currentPlayer from to
          then Just to
          else getActiveCoordinate state.grid state.currentPlayer pixel

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
      d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
      d5 = from + Tuple   2    2
      d6 = from + Tuple (-2)   2
      d7 = from + Tuple   2  (-2)
      d8 = from + Tuple (-2) (-2)
      p1 = player == playerOne && ((d1 == to) || (d2 == to) ||
                                   (d5 == to && hasPlayerPiece grid.squares d1 playerTwo) ||
                                   (d6 == to && hasPlayerPiece grid.squares d2 playerTwo))
      p2 = player == playerTwo && ((d3 == to) || (d4 == to) ||
                                   (d7 == to && hasPlayerPiece grid.squares d3 playerOne) ||
                                   (d8 == to && hasPlayerPiece grid.squares d4 playerOne))
  in isValid grid to && not hasPiece grid.squares to && (p1 || p2)

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  guard $ hasPlayerPiece grid.squares coordinate player
  potential <- getDiagonalSquares coordinate
  guard $ isValidMove grid player coordinate potential
  return potential

alterPiece :: Maybe Piece -> Coordinate -> Grid -> Grid
alterPiece piece coordinate grid = grid { squares = newSquares }
  where
    index = fromJust (findIndex (hasCoordinate coordinate) grid.squares)
    newSquares = fromJust (modifyAt index (setPiece piece) grid.squares)

removePiece :: Coordinate -> Grid -> Grid
removePiece = alterPiece Nothing

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = removePiece from (alterPiece originalSquare.piece to grid)
    where
      fromIndex = fromJust (findIndex (hasCoordinate from) grid.squares)
      originalSquare = fromJust (grid.squares !! fromIndex)

otherPlayer :: Player -> Player
otherPlayer (Player 1) = Player 2
otherPlayer (Player 2) = Player 1
otherPlayer _          = Player 1

renderSquare :: forall e.
                  Context2D ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx _ square = do
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle colorBorder ctx
  strokeRect ctx border
  return unit

renderHighlight :: forall e.
                     Context2D ->
                     Array Square ->
                     Maybe Coordinate ->
                     Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderHighlight ctx squares selection = do
  case selection of
    Nothing -> return unit
    Just coordinate -> do
      let square = fromJust (getSquare squares coordinate)
          arcPiece = { x:     fst square.render + 0.5 * renderSize,
                       y:     snd square.render + 0.5 * renderSize,
                       r:     (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end:   2.0 * pi }
      setLineWidth highlightWidth ctx
      strokePath ctx $ arc ctx arcPiece
      return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.selectedCoordinate
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.highlightedCoordinate
  return unit

renderPage :: forall s e.
                STRef s State ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st
      return unit
    _ -> return unit
  return unit

moveListener :: forall s e.
                  STRef s State ->
                  DOMEvent ->
                  Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
moveListener st e = do
  ux <- unsafeEventNumberProp "clientX" e
  uy <- unsafeEventNumberProp "clientY" e
  state <- readSTRef st
  let pixel = (Tuple (toNumber ux) (toNumber uy))
      highlightedCoordinate = getHighlightCoordinate state pixel
  writeSTRef st $ state { highlightedCoordinate = highlightedCoordinate }
  renderPage st
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          toCoordinate = getHighlightCoordinate state pixel
      case toCoordinate of
        Nothing -> return unit
        Just to -> do
          case state.selectedCoordinate of
            Nothing -> do
              writeSTRef st $ state { selectedCoordinate = Just to }
              renderPage st
              return unit
            Just from -> do
              case isValidMove state.grid state.currentPlayer from to of
                false -> do
                  writeSTRef st $ state { selectedCoordinate = if to == from
                                                               then Nothing
                                                               else Just to }
                  renderPage st
                  return unit
                true -> do
                  writeSTRef st $ state { selectedCoordinate = Nothing,
                                          grid = movePiece from to state.grid,
                                          currentPlayer = otherPlayer state.currentPlayer }
                  renderPage st
                  return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (moveListener st) canvas
      addMouseEventListener MouseClickEvent (clickListener st) canvas
      renderPage st
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events
import Data.DOM.Simple.Window
import Data.Int
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  { player: player,
    color:  if player == playerOne then colorPlayerOne else colorPlayerTwo,
    king:   false }

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:                  createGrid offset width height layers,
    currentPlayer:         playerOne,
    selectedCoordinate:    Nothing,
    highlightedCoordinate: Nothing }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

hasPlayer :: Player -> Piece -> Boolean
hasPlayer player piece = piece.player == player

hasCoordinate :: Coordinate -> Square -> Boolean
hasCoordinate coordinate square = coordinate == square.coordinate

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  fromMaybe Nothing $ (squares !!) <$> (findIndex (hasCoordinate coordinate) squares)

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> fromMaybe false $ (hasPlayer player) <$> square.piece

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares coordinate playerOne ||
  hasPlayerPiece squares coordinate playerTwo

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -2 : (-1 : (1 : (singleton 2)))
  j <- -2 : (-1 : (1 : (singleton 2)))
  return (Tuple (x + i) (y + j))

isOnSquare :: Pixel -> Square -> Boolean
isOnSquare (Tuple x y) square =
  let px = square.render + square.offset
      px' = px + (Tuple renderSize renderSize)
  in fst px < x && x < fst px' && snd px < y && y < snd px'

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare pixel square && not (null moves)

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel =
  case findIndex (isOnActiveSquare grid player pixel) grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

find :: Grid -> Player -> Pixel -> Maybe Coordinate
find grid player pixel =
  case findIndex (isOnSquare pixel) grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

getHighlightCoordinate :: State -> Pixel -> Maybe Coordinate
getHighlightCoordinate state pixel =
  case find state.grid state.currentPlayer pixel of
    Nothing -> Nothing
    Just to -> do
      case state.selectedCoordinate of
        Nothing -> getActiveCoordinate state.grid state.currentPlayer pixel
        Just from ->
          if isValidMove state.grid state.currentPlayer from to
          then Just to
          else getActiveCoordinate state.grid state.currentPlayer pixel

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
      d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
      d5 = from + Tuple   2    2
      d6 = from + Tuple (-2)   2
      d7 = from + Tuple   2  (-2)
      d8 = from + Tuple (-2) (-2)
      p1 = player == playerOne && ((d1 == to) || (d2 == to) ||
                                   (d5 == to && hasPlayerPiece grid.squares d1 playerTwo) ||
                                   (d6 == to && hasPlayerPiece grid.squares d2 playerTwo))
      p2 = player == playerTwo && ((d3 == to) || (d4 == to) ||
                                   (d7 == to && hasPlayerPiece grid.squares d3 playerOne) ||
                                   (d8 == to && hasPlayerPiece grid.squares d4 playerOne))
  in isValid grid to && not hasPiece grid.squares to && (p1 || p2)

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  guard $ hasPlayerPiece grid.squares coordinate player
  potential <- getDiagonalSquares coordinate
  guard $ isValidMove grid player coordinate potential
  return potential

alterPiece :: Maybe Piece -> Coordinate -> Grid -> Grid
alterPiece piece coordinate grid = grid { squares = newSquares }
  where
    index = fromJust (findIndex (hasCoordinate coordinate) grid.squares)
    newSquares = fromJust (modifyAt index (setPiece piece) grid.squares)

removePiece :: Coordinate -> Grid -> Grid
removePiece = alterPiece Nothing

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = removePiece from (alterPiece originalSquare.piece to grid)
    where
      fromIndex = fromJust (findIndex (hasCoordinate from) grid.squares)
      originalSquare = fromJust (grid.squares !! fromIndex)

otherPlayer :: Player -> Player
otherPlayer (Player 1) = Player 2
otherPlayer (Player 2) = Player 1
otherPlayer _          = Player 1

renderSquare :: forall e.
                  Context2D ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx _ square = do
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle colorBorder ctx
  strokeRect ctx border
  return unit

renderHighlight :: forall e.
                     Context2D ->
                     Array Square ->
                     Maybe Coordinate ->
                     Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderHighlight ctx squares selection = do
  case selection of
    Nothing -> return unit
    Just coordinate -> do
      let square = fromJust (getSquare squares coordinate)
          arcPiece = { x:     fst square.render + 0.5 * renderSize,
                       y:     snd square.render + 0.5 * renderSize,
                       r:     (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end:   2.0 * pi }
      setLineWidth highlightWidth ctx
      strokePath ctx $ arc ctx arcPiece
      return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.selectedCoordinate
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.highlightedCoordinate
  return unit

renderPage :: forall s e.
                STRef s State ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st
      return unit
    _ -> return unit
  return unit

moveListener :: forall s e.
                  STRef s State ->
                  DOMEvent ->
                  Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
moveListener st e = do
  ux <- unsafeEventNumberProp "clientX" e
  uy <- unsafeEventNumberProp "clientY" e
  state <- readSTRef st
  let pixel = (Tuple (toNumber ux) (toNumber uy))
      highlightedCoordinate = getHighlightCoordinate state pixel
  writeSTRef st $ state { highlightedCoordinate = highlightedCoordinate }
  renderPage st
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          toCoordinate = getHighlightCoordinate state pixel
      case toCoordinate of
        Nothing -> return unit
        Just to -> do
          case state.selectedCoordinate of
            Nothing -> do
              writeSTRef st $ state { selectedCoordinate = Just to }
              renderPage st
              return unit
            Just from -> do
              case isValidMove state.grid state.currentPlayer from to of
                false -> do
                  writeSTRef st $ state { selectedCoordinate = if to == from
                                                               then Nothing
                                                               else Just to }
                  renderPage st
                  return unit
                true -> do
                  writeSTRef st $ state { selectedCoordinate = Nothing,
                                          grid = movePiece from to state.grid,
                                          currentPlayer = otherPlayer state.currentPlayer }
                  renderPage st
                  return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (moveListener st) canvas
      addMouseEventListener MouseClickEvent (clickListener st) canvas
      renderPage st
      return unit
    _ -> return unit


fixes travis build

fixes travis build

{-
Copyright 2015 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 Test.Selenium.Notebook.Viz (test) where

import Prelude

import Control.Monad.Eff.Random (randomInt)
import Control.Monad.Eff.Class (liftEff)
import Data.List (length)

import Selenium.Types
import Selenium.Monad
import Selenium.ActionSequence hiding (sequence)

import Test.Config
import Test.Platform
import Test.Selenium.Monad
import Test.Selenium.Log
import Test.Selenium.Common
import Test.Selenium.Notebook.Getters
import Test.Selenium.Notebook.Contexts
import qualified Test.Selenium.Notebook.Common as C

import Utils (s2i)

checkNextVizCell :: Check Unit
checkNextVizCell = do
  waitNextVizCell >>= sequence <<< leftClick
  await "Viz cell has not been created" do
    ((eq 2) <<< length) <$> getCells
  successMsg "Ok, next cell viz works"

checkSetHeightWidth :: Check Unit
checkSetHeightWidth = withSmallZipsAllChart do
  widthInput <- waitVizWidthInput
  heightInput <- waitVizHeightInput

  w <- liftEff $ randomInt 100 400
  h <- liftEff $ randomInt 100 400

  sequence do
    leftClick widthInput
    sendSelectAll platform
    sendDelete
    sendKeys $ show w

    leftClick heightInput
    sendSelectAll platform
    sendDelete
    sendKeys $ show h

  await "Dimensions has not been setted" do
    dims <- getDims
    pure
       $ dims.w == pure w
      && dims.h == pure h
  successMsg "Ok, dimensions setted"

  where
  getDims = do
    canvas <- waitCanvas
    { w: _, h: _ }
      <$> (s2i <$> getCssValue canvas "width")
      <*> (s2i <$> getCssValue canvas "height")

test :: Check Unit
test = do
  config <- getConfig
  sectionMsg "check next viz cell (search)"
  withSmallZipsSearchedAll $ checkNextVizCell

  sectionMsg "check next viz cell (explore)"
  withSmallZipsOpened $ checkNextVizCell

  sectionMsg "check next viz cell (query)"
  withSmallZipsQueriedAll $ checkNextVizCell

  sectionMsg "check next viz cell (query)"
  withSmallZipsQueriedAll $ checkNextVizCell

  sectionMsg "check set height/width"
  checkSetHeightWidth

  sectionMsg "check hide/show"
  withSmallZipsAllChart do
    config <- getConfig
    cell <- getCell 1
    C.checkHideShowCell cell config.cell.vizEditor

{-
Copyright 2015 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 Test.Selenium.Notebook.Viz (test) where

import Prelude

import Control.Monad.Eff.Random (randomInt)
import Control.Monad.Eff.Class (liftEff)
import Data.List (length)

import Selenium.Types
import Selenium.Monad
import Selenium.ActionSequence hiding (sequence)

import Test.Config
import Test.Platform
import Test.Selenium.Monad
import Test.Selenium.Log
import Test.Selenium.Common
import Test.Selenium.Notebook.Getters
import Test.Selenium.Notebook.Contexts
import qualified Test.Selenium.Notebook.Common as C

import Utils (s2i)
import Utils.Log

checkNextVizCell :: Check Unit
checkNextVizCell = do
  waitNextVizCell >>= sequence <<< leftClick
  await "Viz cell has not been created" do
    ((eq 2) <<< length) <$> getCells
  successMsg "Ok, next cell viz works"

checkSetHeightWidth :: Check Unit
checkSetHeightWidth = withSmallZipsAllChart do
  initialDims <- getDims
  assertBoolean
    "Incorrect initial width, please check echarts version"
    (initialDims.aw == initialDims.cw * pure 2)
  assertBoolean
    "Incorrect initial height, please check echarts version"
    (initialDims.ah == initialDims.ch * pure 2)

  widthInput <- waitVizWidthInput
  heightInput <- waitVizHeightInput

  w <- liftEff $ randomInt 100 400
  h <- liftEff $ randomInt 100 400

  sequence do
    leftClick widthInput
    sendSelectAll platform
    sendDelete
    sendKeys $ show w

    leftClick heightInput
    sendSelectAll platform
    sendDelete
    sendKeys $ show h

  await "Dimensions has not been setted" do
    dims <- getDims
    pure
      $  dims.aw == dims.cw * pure 2
      && dims.cw == pure w
      && dims.ah == dims.ch * pure 2
      && dims.ch == pure h
  successMsg "Ok, dimensions setted"

  where
  getDims = do
    canvas <- waitCanvas
    {aw: _, ah: _, cw: _, ch: _}
      <$> (s2i <$> getAttribute canvas "width")
      <*> (s2i <$> getAttribute canvas "height")
      <*> (s2i <$> getCssValue canvas "width")
      <*> (s2i <$> getCssValue canvas "height")

test :: Check Unit
test = do
  config <- getConfig
  sectionMsg "check next viz cell (search)"
  withSmallZipsSearchedAll $ checkNextVizCell

  sectionMsg "check next viz cell (explore)"
  withSmallZipsOpened $ checkNextVizCell

  sectionMsg "check next viz cell (query)"
  withSmallZipsQueriedAll $ checkNextVizCell

  sectionMsg "check next viz cell (query)"
  withSmallZipsQueriedAll $ checkNextVizCell

  sectionMsg "check set height/width"
  checkSetHeightWidth

  sectionMsg "check hide/show"
  withSmallZipsAllChart do
    config <- getConfig
    cell <- getCell 1
    C.checkHideShowCell cell config.cell.vizEditor


Avoid `A.some` and `A.many` where possible

-- | ARGV lexer
-- |
-- | > Given an argv array, i.e. `process.argv`, derive a stream of tokens
-- | > suitable for parsing against a docopt specification.
-- |
-- | ===

module Language.Docopt.ArgParser.Lexer (
    lex
  , Options()
  ) where

import Prelude
import Debug.Trace
import Data.Either (Either())
import Data.Maybe (Maybe(..))
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import Data.String (fromCharArray)
import Data.List (List(..), singleton, many, fromFoldable, some, toUnfoldable)
import Data.String (singleton) as String
import Data.Traversable (foldMap)
import Data.Foldable (elem)
import Text.Parsing.Parser (ParseError, Parser, runParser) as P
import Text.Parsing.Parser.Combinators (try, choice, optional, optionMaybe) as P
import Text.Parsing.Parser.Pos (Position(Position)) as P
import Text.Parsing.Parser.String (eof, anyChar, char, oneOf, noneOf, string) as P
import Data.Array as A
import Control.Plus (empty)
import Language.Docopt.ArgParser.Token (PositionedToken(..), Token(..))
import Language.Docopt.SpecParser.Base (space, alphaNum)
import Language.Docopt.Value (Value(..)) as D

type Options r = {
  stopAt :: Array String
  | r
}

-- | Parse a single token from the ARGV stream.
-- | Because each item on the ARGV stream is a a string itself, apply a parser
-- | to each item and derive a token.
parseToken :: P.Parser String Token
parseToken = do
  P.choice $ P.try <$> [
    lopt  <* P.eof
  , sopt  <* P.eof
  , eoa   <* P.eof
  , stdin <* P.eof
  , lit   <* P.eof
  ]

  where
    stdin :: P.Parser String Token
    stdin = do
      P.char '-'
      pure Stdin

    eoa :: P.Parser String Token
    eoa = do
      P.string "--"
      pure $ EOA empty

    -- | Parse a short option
    sopt :: P.Parser String Token
    sopt = do
      P.char '-'
      x   <- alphaNum
      xs  <- A.many $ P.noneOf [ '=' ]
      arg <- P.optionMaybe arg
      pure $ SOpt x xs arg

    -- | Parse a long option
    lopt :: P.Parser String Token
    lopt = do
      P.string "--"
      xs <- foldMap String.singleton <$> do
        some $ P.noneOf [ '=', ' ' ]
      arg <- P.optionMaybe arg
      pure $ LOpt xs arg

    -- | Parse a literal
    lit :: P.Parser String Token
    lit = Lit <<< foldMap String.singleton <$> do
      many P.anyChar

    arg = do
      P.char '='
      fromCharArray <$> A.many P.anyChar

-- | Reduce the array of arguments (argv) to a list of tokens, by parsing each
-- | item individually.
lex
  :: forall r
   . List String
  -> Options r
  -> Either P.ParseError (List PositionedToken)
lex xs options = go xs 1
  where
    go Nil _ = pure Nil
    go (Cons x xs) n = do
      let toEOA l = pure $ singleton $ PositionedToken {
            token:     EOA (D.StringValue <$> xs)
          , sourcePos: P.Position { line: 1, column: n }
          , source:    x
          }

      tok <- P.runParser x parseToken
      case tok of
        (EOA  _) -> toEOA "--"
        otherwise -> do
          toks <- go xs (n + 1)
          pure
            $ singleton (PositionedToken {
                          token:     tok
                        , sourcePos: P.Position { line: 1, column: n }
                        , source:    x
                        }) <> toks

-- | ARGV lexer
-- |
-- | > Given an argv array, i.e. `process.argv`, derive a stream of tokens
-- | > suitable for parsing against a docopt specification.
-- |
-- | ===

module Language.Docopt.ArgParser.Lexer (
    lex
  , Options()
  ) where

import Prelude
import Debug.Trace
import Data.Either (Either())
import Data.Maybe (Maybe(..))
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import Data.String (fromCharArray)
import Data.List (List(..), singleton, many)
import Data.Foldable (elem)
import Text.Parsing.Parser (ParseError, Parser, runParser) as P
import Text.Parsing.Parser.Combinators (try, choice, optional, optionMaybe) as P
import Text.Parsing.Parser.Pos (Position(Position)) as P
import Text.Parsing.Parser.String (eof, anyChar, char, oneOf, noneOf, string) as P
import Data.Array as A
import Control.Plus (empty)
import Language.Docopt.ArgParser.Token (PositionedToken(..), Token(..))
import Language.Docopt.SpecParser.Base (space, alphaNum)
import Language.Docopt.Value (Value(..)) as D

type Options r = {
  stopAt :: Array String
  | r
}

-- | Parse a single token from the ARGV stream.
-- | Because each item on the ARGV stream is a a string itself, apply a parser
-- | to each item and derive a token.
parseToken :: P.Parser String Token
parseToken = do
  P.choice $ P.try <$> [
    stdin <* P.eof
  , sopt  <* P.eof
  , lopt  <* P.eof
  , eoa   <* P.eof
  , lit   <* P.eof
  ]

  where
    stdin :: P.Parser String Token
    stdin = do
      P.char '-'
      P.eof
      pure $ Stdin

    eoa :: P.Parser String Token
    eoa = do
      P.string "--"
      P.eof
      pure $ EOA empty

    -- | Parse a short option
    sopt :: P.Parser String Token
    sopt = do
      P.char '-'
      x   <- alphaNum
      xs  <- A.many $ P.noneOf [ '=' ]
      arg <- P.optionMaybe arg
      P.eof
      pure $ SOpt x xs arg

    -- | Parse a long option
    lopt :: P.Parser String Token
    lopt = do
      P.string "--"
      xs <- fromCharArray <$> do
        A.some $ P.noneOf [ '=', ' ' ]
      arg <- P.optionMaybe arg
      P.eof
      pure $ LOpt xs arg

    -- | Parse a literal
    lit :: P.Parser String Token
    lit = Lit <<< fromCharArray <$> do
      A.many P.anyChar

    arg = do
      P.char '='
      fromCharArray <$> A.many P.anyChar

-- | Reduce the array of arguments (argv) to a list of tokens, by parsing each
-- | item individually.
lex
  :: forall r
   . List String
  -> Options r
  -> Either P.ParseError (List PositionedToken)
lex xs options = go xs 1
  where
    go Nil _ = pure Nil
    go (Cons x xs) n = do
      let toEOA l = pure $ singleton $ PositionedToken {
            token:     EOA (D.StringValue <$> xs)
          , sourcePos: P.Position { line: 1, column: n }
          , source:    x
          }

      tok <- P.runParser x parseToken
      case tok of
        (EOA  _) -> toEOA "--"
        otherwise -> do
          toks <- go xs (n + 1)
          pure
            $ singleton (PositionedToken {
                          token:     tok
                        , sourcePos: P.Position { line: 1, column: n }
                        , source:    x
                        }) <> toks