Re-order lexing priorities

Re-order lexing priorities

module Docopt.Parser.Lexer where

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

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

prettyPrintToken :: Token -> String
prettyPrintToken LParen            = show '('
prettyPrintToken RParen            = show ')'
prettyPrintToken LSquare           = show '['
prettyPrintToken RSquare           = show ']'
prettyPrintToken LAngle            = show '<'
prettyPrintToken RAngle            = show '>'
prettyPrintToken Dash              = show '-'
prettyPrintToken VBar              = show '|'
prettyPrintToken Colon             = show ':'
prettyPrintToken Comma             = show ','
prettyPrintToken Equal             = show '='
prettyPrintToken TripleDot         = show "..."
prettyPrintToken (Garbage   c)     = "Garbage "   ++ show c
prettyPrintToken (Name      n)     = "Name "      ++ show n
prettyPrintToken (ShoutName n)     = "ShoutName " ++ show n
prettyPrintToken (AngleName n)     = "AngleName " ++ show n
prettyPrintToken (StringLiteral s) = "StrLit " ++ show s
prettyPrintToken (Word w)          = "Word " ++ show w
prettyPrintToken (LOpt n)          = "LOpt --" ++ n
prettyPrintToken (SOpt n s a)      =
  "SOpt -"
    ++ (fromChar n)
    ++ (fromCharArray $ fromList s)
    ++ a

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

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

instance eqToken :: Eq Token where
  eq LParen            LParen             = true
  eq RParen            RParen             = true
  eq LSquare           LSquare            = true
  eq RSquare           RSquare            = true
  eq LAngle            LAngle             = true
  eq RAngle            RAngle             = true
  eq VBar              VBar               = true
  eq Colon             Colon              = true
  eq Comma             Comma              = true
  eq Dash              Dash               = true
  eq Equal             Equal              = true
  eq TripleDot         TripleDot          = true
  eq (LOpt n)          (LOpt n')          = (n == n')
  eq (SOpt n s a)      (SOpt n' s' a')    = (n == n') && (s' == s') && (a == a')
  eq (StringLiteral s) (StringLiteral s') = s == s'
  eq (AngleName n)     (AngleName n')     = n == n'
  eq (ShoutName n)     (ShoutName n')     = n == n'
  eq (Word w)          (Word w')          = w == w'
  eq (Name n)          (Name n')          = n == n'
  eq (Garbage c)       (Garbage c')       = c == c'
  eq _ _                                  = false

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

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

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

parseToken :: P.Parser String Token
parseToken = P.choice
  [ P.try $ P.char   '('   *> pure LParen
  , P.try $ P.char   ')'   *> pure RParen
  , P.try $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '|'   *> pure VBar
  , P.try $ P.char   ':'   *> pure Colon
  , P.try $ P.char   ','   *> pure Comma
  , P.try $ parseLongOption
  , P.try $ (parseShortOption <* spaceOrEOF)
  , P.try $ AngleName <$> parseAngleName
  , P.try $ P.char   '<'   *> pure LAngle
  , P.try $ P.char   '>'   *> pure RAngle
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.char   '='   *> pure Equal
  , P.try $ P.string "..." *> pure TripleDot
  , P.try $ parseStringLiteral
  , P.try $ ShoutName <$> (parseShoutName <* P.notFollowedBy foo)
  , P.try $ Name      <$> (parseName      <* P.notFollowedBy foo)
  , P.try $ Word      <$> (parseWord      <* P.notFollowedBy foo)
  , P.try $ Garbage   <$> P.anyChar
  ] <* P.skipSpaces

 where

  foo :: P.Parser String Unit
  foo = do
    regex "[a-zA-Z]"
    pure unit

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

  spaceOrEOF :: P.Parser String Unit
  spaceOrEOF = P.choice [ whitespace, P.eof ]

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

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

  parseWord :: P.Parser String String
  parseWord = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> (A.many $ P.choice [
        identLetter
      , P.oneOf [ '.', '-', '_' ]
      ])

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

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

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

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

  identStart :: P.Parser String Char
  identStart = alpha

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

  flag :: P.Parser String Char
  flag = lowerAlphaNum

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

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

-- | Match the token at the head of the stream
match :: forall a. Token -> TokenParser Unit
match tok = token (\tok' -> if (tok' == tok) then Just unit else Nothing)
            P.<?> prettyPrintToken tok

anyToken = token $ Just

eof = P.notFollowedBy anyToken

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

langle :: TokenParser Unit
langle = match LAngle

rangle :: TokenParser Unit
rangle = match RAngle

dash :: TokenParser Unit
dash = match Dash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

equal :: TokenParser Unit
equal = match Equal

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

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

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

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

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

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

module Docopt.Parser.Lexer where

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

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

prettyPrintToken :: Token -> String
prettyPrintToken LParen            = show '('
prettyPrintToken RParen            = show ')'
prettyPrintToken LSquare           = show '['
prettyPrintToken RSquare           = show ']'
prettyPrintToken LAngle            = show '<'
prettyPrintToken RAngle            = show '>'
prettyPrintToken Dash              = show '-'
prettyPrintToken VBar              = show '|'
prettyPrintToken Colon             = show ':'
prettyPrintToken Comma             = show ','
prettyPrintToken Equal             = show '='
prettyPrintToken TripleDot         = show "..."
prettyPrintToken (Garbage   c)     = "Garbage "   ++ show c
prettyPrintToken (Name      n)     = "Name "      ++ show n
prettyPrintToken (ShoutName n)     = "ShoutName " ++ show n
prettyPrintToken (AngleName n)     = "AngleName " ++ show n
prettyPrintToken (StringLiteral s) = "StrLit " ++ show s
prettyPrintToken (Word w)          = "Word " ++ show w
prettyPrintToken (LOpt n)          = "LOpt --" ++ n
prettyPrintToken (SOpt n s a)      =
  "SOpt -"
    ++ (fromChar n)
    ++ (fromCharArray $ fromList s)
    ++ a

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

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

instance eqToken :: Eq Token where
  eq LParen            LParen             = true
  eq RParen            RParen             = true
  eq LSquare           LSquare            = true
  eq RSquare           RSquare            = true
  eq LAngle            LAngle             = true
  eq RAngle            RAngle             = true
  eq VBar              VBar               = true
  eq Colon             Colon              = true
  eq Comma             Comma              = true
  eq Dash              Dash               = true
  eq Equal             Equal              = true
  eq TripleDot         TripleDot          = true
  eq (LOpt n)          (LOpt n')          = (n == n')
  eq (SOpt n s a)      (SOpt n' s' a')    = (n == n') && (s' == s') && (a == a')
  eq (StringLiteral s) (StringLiteral s') = s == s'
  eq (AngleName n)     (AngleName n')     = n == n'
  eq (ShoutName n)     (ShoutName n')     = n == n'
  eq (Word w)          (Word w')          = w == w'
  eq (Name n)          (Name n')          = n == n'
  eq (Garbage c)       (Garbage c')       = c == c'
  eq _ _                                  = false

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

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

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

parseToken :: P.Parser String Token
parseToken = P.choice
  [ P.try $ P.char   '('   *> pure LParen
  , P.try $ P.char   ')'   *> pure RParen
  , P.try $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '|'   *> pure VBar
  , P.try $ P.char   ':'   *> pure Colon
  , P.try $ P.char   ','   *> pure Comma
  , P.try $ parseLongOption
  , P.try $ (parseShortOption <* spaceOrEOF)
  , P.try $ AngleName <$> parseAngleName
  , P.try $ P.char   '<'   *> pure LAngle
  , P.try $ P.char   '>'   *> pure RAngle
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.char   '='   *> pure Equal
  , P.try $ P.string "..." *> pure TripleDot
  , P.try $ parseStringLiteral
  , P.try $ ShoutName <$> (parseShoutName <* P.notFollowedBy foo)
  , P.try $ Word      <$> (parseWord      <* P.notFollowedBy foo)
  , P.try $ Name      <$> (parseName      <* P.notFollowedBy foo)
  , P.try $ Garbage   <$> P.anyChar
  ] <* P.skipSpaces

 where

  foo :: P.Parser String Unit
  foo = do
    regex "[a-zA-Z]"
    pure unit

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

  spaceOrEOF :: P.Parser String Unit
  spaceOrEOF = P.choice [ whitespace, P.eof ]

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

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

  parseWord :: P.Parser String String
  parseWord = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> (A.many $ P.choice [
        identLetter
      , P.oneOf [ '.', '-', '_' ]
      ])

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

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

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

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

  identStart :: P.Parser String Char
  identStart = alpha

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

  flag :: P.Parser String Char
  flag = lowerAlphaNum

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

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

-- | Match the token at the head of the stream
match :: forall a. Token -> TokenParser Unit
match tok = token (\tok' -> if (tok' == tok) then Just unit else Nothing)
            P.<?> prettyPrintToken tok

anyToken = token $ Just

eof = P.notFollowedBy anyToken

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

langle :: TokenParser Unit
langle = match LAngle

rangle :: TokenParser Unit
rangle = match RAngle

dash :: TokenParser Unit
dash = match Dash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

equal :: TokenParser Unit
equal = match Equal

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

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

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

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

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

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


fix phantom type var in doc strings

fix phantom type var in doc strings

The code always refers to the ST phantom type as `h`. The docs refered
to it as `s`. This was confusing.

module Control.Monad.ST where

import Control.Monad.Eff (Eff, runPure)

-- | The `ST` effect represents _local mutation_, i.e. mutation which does not
-- | "escape" into the surrounding computation.
-- |
-- | An `ST` computation is parameterized by a phantom type which is used to
-- | restrict the set of reference cells it is allowed to access.
-- |
-- | The `runST` function can be used to handle the `ST` effect.
foreign import data ST :: * -> !

-- | The type `STRef h a` represents a mutable reference holding a value of
-- | type `a`, which can be used with the `ST h` effect.
foreign import data STRef :: * -> * -> *

-- | Create a new mutable reference.
foreign import newSTRef
  :: forall a h r
   . a
  -> Eff (st :: ST h | r) (STRef h a)

-- | Read the current value of a mutable reference.
foreign import readSTRef
  :: forall a h r
   . STRef h a
  -> Eff (st :: ST h | r) a

-- | Modify the value of a mutable reference by applying a function to the
-- | current value.
foreign import modifySTRef
  :: forall a h r
   . STRef h a -> (a -> a)
  -> Eff (st :: ST h | r) a

-- | Set the value of a mutable reference.
foreign import writeSTRef
  :: forall a h r
   . STRef h a
  -> a
  -> Eff (st :: ST h | r) a

-- | Run an `ST` computation.
-- |
-- | Note: the type of `runST` uses a rank-2 type to constrain the phantom
-- | type `h`, such that the computation must not leak any mutable references
-- | to the surrounding computation.
-- |
-- | It may cause problems to apply this function using the `$` operator. The
-- | recommended approach is to use parentheses instead.
foreign import runST
  :: forall a r
   . (forall h. Eff (st :: ST h | r) a)
  -> Eff r a

-- | A convenience function which combines `runST` with `runPure`, which can be
-- | used when the only required effect is `ST`.
-- |
-- | Note: since this function has a rank-2 type, it may cause problems to apply
-- | this function using the `$` operator. The recommended approach is to use
-- | parentheses instead.
pureST :: forall a. (forall h. Eff (st :: ST h) a) -> a
pureST st = runPure (runST st)

module Control.Monad.ST where

import Control.Monad.Eff (Eff, runPure)

-- | The `ST` effect represents _local mutation_, i.e. mutation which does not
-- | "escape" into the surrounding computation.
-- |
-- | An `ST` computation is parameterized by a phantom type which is used to
-- | restrict the set of reference cells it is allowed to access.
-- |
-- | The `runST` function can be used to handle the `ST` effect.
foreign import data ST :: * -> !

-- | The type `STRef s a` represents a mutable reference holding a value of
-- | type `a`, which can be used with the `ST s` effect.
foreign import data STRef :: * -> * -> *

-- | Create a new mutable reference.
foreign import newSTRef
  :: forall a h r
   . a
  -> Eff (st :: ST h | r) (STRef h a)

-- | Read the current value of a mutable reference.
foreign import readSTRef
  :: forall a h r
   . STRef h a
  -> Eff (st :: ST h | r) a

-- | Modify the value of a mutable reference by applying a function to the
-- | current value.
foreign import modifySTRef
  :: forall a h r
   . STRef h a -> (a -> a)
  -> Eff (st :: ST h | r) a

-- | Set the value of a mutable reference.
foreign import writeSTRef
  :: forall a h r
   . STRef h a
  -> a
  -> Eff (st :: ST h | r) a

-- | Run an `ST` computation.
-- |
-- | Note: the type of `runST` uses a rank-2 type to constrain the phantom
-- | type `s`, such that the computation must not leak any mutable references
-- | to the surrounding computation.
-- |
-- | It may cause problems to apply this function using the `$` operator. The
-- | recommended approach is to use parentheses instead.
foreign import runST
  :: forall a r
   . (forall h. Eff (st :: ST h | r) a)
  -> Eff r a

-- | A convenience function which combines `runST` with `runPure`, which can be
-- | used when the only required effect is `ST`.
-- |
-- | Note: since this function has a rank-2 type, it may cause problems to apply
-- | this function using the `$` operator. The recommended approach is to use
-- | parentheses instead.
pureST :: forall a. (forall h. Eff (st :: ST h) a) -> a
pureST st = runPure (runST st)


Add toRep (#238)

Add toRep (#238)

* Add toRep

* Update type variable names to match class names

* Rename toRep to repOf

module Data.Generic.Rep
  ( class Generic
  , to
  , from
  , repOf
  , NoConstructors
  , NoArguments(..)
  , Sum(..)
  , Product(..)
  , Constructor(..)
  , Argument(..)
  ) where

import Type.Proxy (Proxy(..))

-- | A representation for types with no constructors.
data NoConstructors

-- | A representation for constructors with no arguments.
data NoArguments = NoArguments

-- | A representation for types with multiple constructors.
data Sum a b = Inl a | Inr b

-- | A representation for constructors with multiple fields.
data Product a b = Product a b

-- | A representation for constructors which includes the data constructor name
-- | as a type-level string.
newtype Constructor (name :: Symbol) a = Constructor a

-- | A representation for an argument in a data constructor.
newtype Argument a = Argument a

-- | The `Generic` class asserts the existence of a type function from types
-- | to their representations using the type constructors defined in this module.
class Generic a rep | a -> rep where
  to :: rep -> a
  from :: a -> rep

repOf :: forall a rep. Generic a rep => Proxy a -> Proxy rep
repOf _ = Proxy

module Data.Generic.Rep
  ( class Generic
  , to
  , from
  , NoConstructors
  , NoArguments(..)
  , Sum(..)
  , Product(..)
  , Constructor(..)
  , Argument(..)
  ) where

-- | A representation for types with no constructors.
data NoConstructors

-- | A representation for constructors with no arguments.
data NoArguments = NoArguments

-- | A representation for types with multiple constructors.
data Sum a b = Inl a | Inr b

-- | A representation for constructors with multiple fields.
data Product a b = Product a b

-- | A representation for constructors which includes the data constructor name
-- | as a type-level string.
newtype Constructor (name :: Symbol) a = Constructor a

-- | A representation for an argument in a data constructor.
newtype Argument a = Argument a

-- | The `Generic` class asserts the existence of a type function from types
-- | to their representations using the type constructors defined in this module.
class Generic a rep | a -> rep where
  to :: rep -> a
  from :: a -> rep


Mark non-deterministic test / SD-1639 (#761)

See https://slamdata.atlassian.net/browse/SD-1639

{-
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.SlamData.Feature.Test.File where

import SlamData.Prelude

import Selenium.Monad (later)
import Test.Feature.Log (successMsg, warnMsg, errorMsg)
import Test.Feature.Scenario (scenario)
import Test.SlamData.Feature.Expectations as Expect
import Test.SlamData.Feature.Interactions as Interact
import Test.SlamData.Feature.Monad (SlamFeature)

fileScenario
  ∷ SlamFeature Unit
   → String
   → Array String
   → SlamFeature Unit
   → SlamFeature Unit
fileScenario = scenario "File" (Interact.browseRootFolder)

defaultAfterFile ∷ SlamFeature Unit
defaultAfterFile = Interact.browseRootFolder

afterRename ∷ SlamFeature Unit
afterRename = Interact.deleteFile "Ϡ⨁⟶≣ΜϞ"

afterMove ∷ SlamFeature Unit
afterMove = Interact.browseTestFolder *> Interact.deleteFile "Medical data"

afterUpload ∷ SlamFeature Unit
afterUpload = Interact.deleteFile "array-wrapped.json"

afterAccessSharingUrl ∷ SlamFeature Unit
afterAccessSharingUrl =
  Interact.launchSlamData
    *> Interact.browseTestFolder
    *> Interact.deleteFile "Untitled Workspace.slam"

test ∷ SlamFeature Unit
test = do
  fileScenario afterRename "Rename a folder" [] do
    Interact.browseTestFolder
    Interact.createFolder
    Interact.renameFile "Untitled Folder" "Patients"
    Expect.file "Patients"
    Interact.renameFile "Patients" "Пациенты# #"
    Expect.file "Пациенты# #"
    Interact.renameFile "Пациенты# #" "Ϡ⨁⟶≣ΜϞ"
    Expect.file "Ϡ⨁⟶≣ΜϞ"
    successMsg "Successfully renamed a folder"

  fileScenario afterMove "Move a folder" ["https://slamdata.atlassian.net/browse/SD-1639"] do
    Interact.browseTestFolder
    Interact.createFolder
    Interact.renameFile "Untitled Folder" "Medical data"
    Interact.createFolder
    Interact.moveFile
      "Untitled Folder"
      "/test-mount/testDb/"
      "/test-mount/testDb/Medical data/"
    Interact.accessFile "Medical data"
    Expect.file "Untitled Folder"
    successMsg "Successfully moved a folder"
    errorMsg "This scenario succeeded, but is known to fail non-deterministically"

  fileScenario defaultAfterFile "Delete a folder" [] do
    Interact.browseTestFolder
    Interact.createFolder
    Interact.deleteFile "Untitled Folder"
    Expect.noFile "Untitled Folder"
    Interact.showHiddenFiles
    Interact.accessFile ".trash"
    Expect.file "Untitled Folder"
    Interact.hideHiddenFiles
    Expect.noFile ".trash"
    successMsg "Successfully deleted a folder"

  fileScenario defaultAfterFile "Navigate back using breadcrumbs" [] do
    Interact.browseTestFolder
    Interact.accessBreadcrumb "test-mount"
    Interact.accessBreadcrumb "Home"
    Expect.file "test-mount"
    successMsg "Successfully navigated back using breadcrumbs"

  fileScenario afterUpload "Upload a file" [] do
    Interact.browseTestFolder
    Interact.uploadFile "test/array-wrapped.json"
    Expect.resourceOpenedInLastExploreCard "/test-mount/testDb/array-wrapped.json"
    Interact.browseRootFolder
    Interact.browseTestFolder
    Expect.file "array-wrapped.json"
    successMsg "Successfully uploaded file"

  fileScenario defaultAfterFile "Search for a file" [] do
    Interact.provideFileSearchString "smallZ"
    Expect.fileSearchString "+smallZ"
    Expect.file "/test-mount/testDb/smallZips"
    Expect.numberOfFiles 1
    successMsg "Succesfully searched for a file"

  fileScenario defaultAfterFile "Access sharing URL for a file" [] do
    Interact.browseTestFolder
    Interact.shareFile "smallZips"
    Interact.accessSharingUrl
    Expect.resourceOpenedInLastExploreCard "/test-mount/testDb/smallZips"
    successMsg "Successfully accessed sharing URL for a file"
    Interact.launchSlamData

  fileScenario afterAccessSharingUrl "Access sharing URL for a deck" [] do
    Interact.createWorkspaceInTestFolder "Quarterly report"
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard "Quarterly"
    Interact.accessNextCardInLastDeck
    Interact.insertFormCardInLastDeck
    Expect.textInFormCard "Quarterly"
    Expect.lastCardToBeFinished
    warnMsg "SD-1538, we don't know if workspace has been saved already"
    later 1000 $ pure unit
    Interact.browseRootFolder
    Interact.browseTestFolder
    Interact.shareFile "Untitled Workspace.slam"
    Interact.accessSharingUrl
    Expect.textInFormCard "Quarterly"
    successMsg "Successfully accessed sharing URL for a workspace"

  fileScenario defaultAfterFile "Download file as CSV" [] do
    Interact.browseTestFolder
    Interact.downloadFileAsCSV "smallZips"
    Expect.downloadedTextFileToMatchFile
      "tmp/test/downloads"
      "smallZips"
      "test/smallZips.csv"
    successMsg "Successfully downloaded file as CSV"

  fileScenario defaultAfterFile "Download file as JSON" [] do
    Interact.browseTestFolder
    Interact.downloadFileAsJSON "smallZips"
    Expect.downloadedTextFileToMatchFile
      "tmp/test/downloads"
      "smallZips"
      "test/smallZips.json"
    successMsg "Successfully downloaded file as JSON"

{-
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.SlamData.Feature.Test.File where

import SlamData.Prelude

import Selenium.Monad (later)
import Test.Feature.Log (successMsg, warnMsg)
import Test.Feature.Scenario (scenario)
import Test.SlamData.Feature.Expectations as Expect
import Test.SlamData.Feature.Interactions as Interact
import Test.SlamData.Feature.Monad (SlamFeature)

fileScenario
  ∷ SlamFeature Unit
   → String
   → Array String
   → SlamFeature Unit
   → SlamFeature Unit
fileScenario = scenario "File" (Interact.browseRootFolder)

defaultAfterFile ∷ SlamFeature Unit
defaultAfterFile = Interact.browseRootFolder

afterRename ∷ SlamFeature Unit
afterRename = Interact.deleteFile "Ϡ⨁⟶≣ΜϞ"

afterMove ∷ SlamFeature Unit
afterMove = Interact.browseTestFolder *> Interact.deleteFile "Medical data"

afterUpload ∷ SlamFeature Unit
afterUpload = Interact.deleteFile "array-wrapped.json"

afterAccessSharingUrl ∷ SlamFeature Unit
afterAccessSharingUrl =
  Interact.launchSlamData
    *> Interact.browseTestFolder
    *> Interact.deleteFile "Untitled Workspace.slam"

test ∷ SlamFeature Unit
test = do
  fileScenario afterRename "Rename a folder" [] do
    Interact.browseTestFolder
    Interact.createFolder
    Interact.renameFile "Untitled Folder" "Patients"
    Expect.file "Patients"
    Interact.renameFile "Patients" "Пациенты# #"
    Expect.file "Пациенты# #"
    Interact.renameFile "Пациенты# #" "Ϡ⨁⟶≣ΜϞ"
    Expect.file "Ϡ⨁⟶≣ΜϞ"
    successMsg "Successfully renamed a folder"

  fileScenario afterMove "Move a folder" [] do
    Interact.browseTestFolder
    Interact.createFolder
    Interact.renameFile "Untitled Folder" "Medical data"
    Interact.createFolder
    Interact.moveFile
      "Untitled Folder"
      "/test-mount/testDb/"
      "/test-mount/testDb/Medical data/"
    Interact.accessFile "Medical data"
    Expect.file "Untitled Folder"
    successMsg "Successfully moved a folder"

  fileScenario defaultAfterFile "Delete a folder" [] do
    Interact.browseTestFolder
    Interact.createFolder
    Interact.deleteFile "Untitled Folder"
    Expect.noFile "Untitled Folder"
    Interact.showHiddenFiles
    Interact.accessFile ".trash"
    Expect.file "Untitled Folder"
    Interact.hideHiddenFiles
    Expect.noFile ".trash"
    successMsg "Successfully deleted a folder"

  fileScenario defaultAfterFile "Navigate back using breadcrumbs" [] do
    Interact.browseTestFolder
    Interact.accessBreadcrumb "test-mount"
    Interact.accessBreadcrumb "Home"
    Expect.file "test-mount"
    successMsg "Successfully navigated back using breadcrumbs"

  fileScenario afterUpload "Upload a file" [] do
    Interact.browseTestFolder
    Interact.uploadFile "test/array-wrapped.json"
    Expect.resourceOpenedInLastExploreCard "/test-mount/testDb/array-wrapped.json"
    Interact.browseRootFolder
    Interact.browseTestFolder
    Expect.file "array-wrapped.json"
    successMsg "Successfully uploaded file"

  fileScenario defaultAfterFile "Search for a file" [] do
    Interact.provideFileSearchString "smallZ"
    Expect.fileSearchString "+smallZ"
    Expect.file "/test-mount/testDb/smallZips"
    Expect.numberOfFiles 1
    successMsg "Succesfully searched for a file"

  fileScenario defaultAfterFile "Access sharing URL for a file" [] do
    Interact.browseTestFolder
    Interact.shareFile "smallZips"
    Interact.accessSharingUrl
    Expect.resourceOpenedInLastExploreCard "/test-mount/testDb/smallZips"
    successMsg "Successfully accessed sharing URL for a file"
    Interact.launchSlamData

  fileScenario afterAccessSharingUrl "Access sharing URL for a deck" [] do
    Interact.createWorkspaceInTestFolder "Quarterly report"
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard "Quarterly"
    Interact.accessNextCardInLastDeck
    Interact.insertFormCardInLastDeck
    Expect.textInFormCard "Quarterly"
    Expect.lastCardToBeFinished
    warnMsg "SD-1538, we don't know if workspace has been saved already"
    later 1000 $ pure unit
    Interact.browseRootFolder
    Interact.browseTestFolder
    Interact.shareFile "Untitled Workspace.slam"
    Interact.accessSharingUrl
    Expect.textInFormCard "Quarterly"
    successMsg "Successfully accessed sharing URL for a workspace"

  fileScenario defaultAfterFile "Download file as CSV" [] do
    Interact.browseTestFolder
    Interact.downloadFileAsCSV "smallZips"
    Expect.downloadedTextFileToMatchFile
      "tmp/test/downloads"
      "smallZips"
      "test/smallZips.csv"
    successMsg "Successfully downloaded file as CSV"

  fileScenario defaultAfterFile "Download file as JSON" [] do
    Interact.browseTestFolder
    Interact.downloadFileAsJSON "smallZips"
    Expect.downloadedTextFileToMatchFile
      "tmp/test/downloads"
      "smallZips"
      "test/smallZips.json"
    successMsg "Successfully downloaded file as JSON"


set -> reset in chart component

set -> reset in chart component

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Chart.Component (chartComponent) where

import SlamData.Prelude

import Data.Argonaut (JArray)
import Data.Array as A
import Data.Foreign (Foreign, ForeignError(TypeMismatch), readInt, readString)
import Data.Foreign.Class (readProp)
import Data.Int (toNumber, floor)
import Data.Lens ((.~), (?~))
import Data.String as Str

import CSS.Geometry as CG
import CSS.Size (px)

import ECharts.Monad (buildObj)

import Global (readFloat, isNaN)

import Halogen as H
import Halogen.ECharts as HEC
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.CSS.Indexed as CSS
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Effects (Slam)
import SlamData.Quasar.Aff (Wiring)
import SlamData.Quasar.Error as QE
import SlamData.Quasar.Query as Quasar
import SlamData.Render.CSS as RC
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Chart.BuildOptions as BO
import SlamData.Workspace.Card.Chart.ChartType (ChartType(..))
import SlamData.Workspace.Card.Chart.Component.State (State, initialState, _levelOfDetails, _chartType)
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Port (Port(..))
import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))

type ChartHTML = H.ParentHTML HEC.EChartsState CC.CardEvalQuery HEC.EChartsQuery Slam Unit
type ChartDSL = H.ParentDSL State HEC.EChartsState CC.CardEvalQuery HEC.EChartsQuery Slam Unit

chartComponent ∷ ∀ r. Wiring r → H.Component CC.CardStateP CC.CardQueryP Slam
chartComponent wiring = CC.makeCardComponent
  { cardType: CT.Chart
  , component: H.parentComponent { render, eval: eval wiring, peek: Nothing }
  , initialState: H.parentState initialState
  , _State: CC._ChartState
  , _Query: CC.makeQueryPrism CC._ChartQuery
  }

render ∷ State → ChartHTML
render state =
  HH.div_
    [ renderHighLOD state
    , renderLowLOD state
    ]

renderHighLOD ∷ State → ChartHTML
renderHighLOD state =
  HH.div
    [ HP.classes
        $ [ RC.chartOutput, HH.className "card-input-maximum-lod" ]
        ⊕ (guard (state.levelOfDetails ≠ High) $> B.hidden)
    , CSS.style do
         CG.height $ px $ toNumber $ state.height - heightPadding
         CG.width $ px $ toNumber state.width
    ]
    [ HH.slot unit \_ →
       { component: HEC.echarts
       , initialState: HEC.initialEChartsState 600 400
       }
    ]
  where
  heightPadding ∷ Int
  heightPadding = 80

renderLowLOD ∷ State → ChartHTML
renderLowLOD state =
  HH.div
    [ HP.classes
        $ [ HH.className "card-input-minimum-lod" ]
        ⊕ (guard (state.levelOfDetails ≠ Low) $> B.hidden)
    ]
    [ HH.button
      [ ARIA.label "Zoom or resize"
      , HP.title "Zoom or resize"
      , HE.onClick (HE.input_ CC.ZoomIn)
      ]
      $ foldMap renderButton state.chartType
    ]

renderButton ∷ ChartType → Array ChartHTML
renderButton ct =
  [ HH.img [ HP.src $ src ct ]
  , HH.text "Zoom or resize"
  ]
  where
  src ∷ ChartType → String
  src Pie = "img/pie-black.svg"
  src Bar = "img/bar-black.svg"
  src Line = "img/line-black.svg"
  src Area = "img/area-black.svg"
  src Scatter = "img/scatter-black.svg"
  src Radar = "img/radar-black.svg"
  src Funnel = "img/funnel-black.svg"

eval ∷ ∀ r. Wiring r → CC.CardEvalQuery ~> ChartDSL
eval wiring = case _ of
  CC.EvalCard value output next → do
    case value.input of
      Just (Chart options@{ options: opts, chartConfig: Just config }) → do
        -- TODO: this could possibly be optimised by caching records in the state,
        -- but we'd need to know when the input dataset going into ChartOptions changes.
        -- Basically something equivalent to the old `needsToUpdate`. -gb
        records ←
          either (const []) id
            <$> H.fromAff (Quasar.all wiring options.resource ∷ Slam (Either QE.QError JArray))
        let optionDSL = BO.buildOptions opts config records
        -- This _must_ be `Reset`. `Set` is for updating existing opts, not setting new.
        H.query unit $ H.action $ HEC.Reset optionDSL
        H.query unit $ H.action HEC.Resize
        setLevelOfDetails $ buildObj optionDSL
        H.modify (_chartType ?~ opts.chartType)
      _ → do
        H.query unit $ H.action HEC.Clear
        pure unit
    pure next
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k →
    pure $ k Card.Chart
  CC.Load _ next →
    pure next
  CC.SetDimensions dims next → do
    state ← H.get
    let
      heightPadding = 60
      intWidth = floor dims.width
      intHeight = floor dims.height
    when (state.width ≠ intWidth) do
      H.query unit $ H.action $ HEC.SetWidth $ intWidth
      H.modify _{ width = intWidth }
    when (state.height ≠ intHeight) do
      H.query unit $ H.action $ HEC.SetHeight $ intHeight - heightPadding
      H.modify _{ height = intHeight }
    mbOpts ← H.query unit $ H.request HEC.GetOptions
    for_ (join mbOpts) \opts → do
      setLevelOfDetails opts
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

setLevelOfDetails ∷ Foreign → ChartDSL Unit
setLevelOfDetails fOption = do
  state ← H.get
  let
    eBottom = do
      grids ← readProp "grid" fOption
      grid ← maybe (Left $ TypeMismatch "Array of grids" "Empty array") Right $ A.head grids
      readProp "bottom" grid

    eBottomPx = either (const Nothing) Just $ readInt =<< eBottom

    eBottomPct = do
      pctStr ← either (const Nothing) Just $ readString =<< eBottom
      str ← Str.stripSuffix "%" pctStr
      let num = readFloat str
      guard (not $ isNaN num)
      pure $ floor $ num / 100.0 * toNumber state.height

  for_ (eBottomPx <|> eBottomPct <|> pure zero) \bottomPx →
    H.modify
    $ _levelOfDetails
    .~ if (state.height - bottomPx) < 200 ∨ state.width < 300
         then Low
         else High

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Chart.Component (chartComponent) where

import SlamData.Prelude

import Data.Argonaut (JArray)
import Data.Array as A
import Data.Foreign (Foreign, ForeignError(TypeMismatch), readInt, readString)
import Data.Foreign.Class (readProp)
import Data.Int (toNumber, floor)
import Data.Lens ((.~), (?~))
import Data.String as Str

import CSS.Geometry as CG
import CSS.Size (px)

import ECharts.Monad (buildObj)

import Global (readFloat, isNaN)

import Halogen as H
import Halogen.ECharts as HEC
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.CSS.Indexed as CSS
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Effects (Slam)
import SlamData.Quasar.Aff (Wiring)
import SlamData.Quasar.Error as QE
import SlamData.Quasar.Query as Quasar
import SlamData.Render.CSS as RC
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Chart.BuildOptions as BO
import SlamData.Workspace.Card.Chart.ChartType (ChartType(..))
import SlamData.Workspace.Card.Chart.Component.State (State, initialState, _levelOfDetails, _chartType)
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Port (Port(..))
import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))

type ChartHTML = H.ParentHTML HEC.EChartsState CC.CardEvalQuery HEC.EChartsQuery Slam Unit
type ChartDSL = H.ParentDSL State HEC.EChartsState CC.CardEvalQuery HEC.EChartsQuery Slam Unit

chartComponent ∷ ∀ r. Wiring r → H.Component CC.CardStateP CC.CardQueryP Slam
chartComponent wiring = CC.makeCardComponent
  { cardType: CT.Chart
  , component: H.parentComponent { render, eval: eval wiring, peek: Nothing }
  , initialState: H.parentState initialState
  , _State: CC._ChartState
  , _Query: CC.makeQueryPrism CC._ChartQuery
  }

render ∷ State → ChartHTML
render state =
  HH.div_
    [ renderHighLOD state
    , renderLowLOD state
    ]

renderHighLOD ∷ State → ChartHTML
renderHighLOD state =
  HH.div
    [ HP.classes
        $ [ RC.chartOutput, HH.className "card-input-maximum-lod" ]
        ⊕ (guard (state.levelOfDetails ≠ High) $> B.hidden)
    , CSS.style do
         CG.height $ px $ toNumber $ state.height - heightPadding
         CG.width $ px $ toNumber state.width
    ]
    [ HH.slot unit \_ →
       { component: HEC.echarts
       , initialState: HEC.initialEChartsState 600 400
       }
    ]
  where
  heightPadding ∷ Int
  heightPadding = 80

renderLowLOD ∷ State → ChartHTML
renderLowLOD state =
  HH.div
    [ HP.classes
        $ [ HH.className "card-input-minimum-lod" ]
        ⊕ (guard (state.levelOfDetails ≠ Low) $> B.hidden)
    ]
    [ HH.button
      [ ARIA.label "Zoom or resize"
      , HP.title "Zoom or resize"
      , HE.onClick (HE.input_ CC.ZoomIn)
      ]
      $ foldMap renderButton state.chartType
    ]

renderButton ∷ ChartType → Array ChartHTML
renderButton ct =
  [ HH.img [ HP.src $ src ct ]
  , HH.text "Zoom or resize"
  ]
  where
  src ∷ ChartType → String
  src Pie = "img/pie-black.svg"
  src Bar = "img/bar-black.svg"
  src Line = "img/line-black.svg"
  src Area = "img/area-black.svg"
  src Scatter = "img/scatter-black.svg"
  src Radar = "img/radar-black.svg"
  src Funnel = "img/funnel-black.svg"

eval ∷ ∀ r. Wiring r → CC.CardEvalQuery ~> ChartDSL
eval wiring = case _ of
  CC.EvalCard value output next → do
    case value.input of
      Just (Chart options@{ options: opts, chartConfig: Just config }) → do
        -- TODO: this could possibly be optimised by caching records in the state,
        -- but we'd need to know when the input dataset going into ChartOptions changes.
        -- Basically something equivalent to the old `needsToUpdate`. -gb
        records ←
          either (const []) id
            <$> H.fromAff (Quasar.all wiring options.resource ∷ Slam (Either QE.QError JArray))
        let optionDSL = BO.buildOptions opts config records
        H.query unit $ H.action $ HEC.Set optionDSL
        H.query unit $ H.action HEC.Resize
        setLevelOfDetails $ buildObj optionDSL
        H.modify (_chartType ?~ opts.chartType)
      _ → do
        H.query unit $ H.action HEC.Clear
        pure unit
    pure next
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k →
    pure $ k Card.Chart
  CC.Load _ next →
    pure next
  CC.SetDimensions dims next → do
    state ← H.get
    let
      heightPadding = 60
      intWidth = floor dims.width
      intHeight = floor dims.height
    when (state.width ≠ intWidth) do
      H.query unit $ H.action $ HEC.SetWidth $ intWidth
      H.modify _{ width = intWidth }
    when (state.height ≠ intHeight) do
      H.query unit $ H.action $ HEC.SetHeight $ intHeight - heightPadding
      H.modify _{ height = intHeight }
    mbOpts ← H.query unit $ H.request HEC.GetOptions
    for_ (join mbOpts) \opts → do
      setLevelOfDetails opts
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

setLevelOfDetails ∷ Foreign → ChartDSL Unit
setLevelOfDetails fOption = do
  state ← H.get
  let
    eBottom = do
      grids ← readProp "grid" fOption
      grid ← maybe (Left $ TypeMismatch "Array of grids" "Empty array") Right $ A.head grids
      readProp "bottom" grid

    eBottomPx = either (const Nothing) Just $ readInt =<< eBottom

    eBottomPct = do
      pctStr ← either (const Nothing) Just $ readString =<< eBottom
      str ← Str.stripSuffix "%" pctStr
      let num = readFloat str
      guard (not $ isNaN num)
      pure $ floor $ num / 100.0 * toNumber state.height

  for_ (eBottomPx <|> eBottomPct <|> pure zero) \bottomPx →
    H.modify
    $ _levelOfDetails
    .~ if (state.height - bottomPx) < 200 ∨ state.width < 300
         then Low
         else High


Fix FS child slots

Fix FS child slots

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.FileSystem.Component.ChildSlot where

import SlamData.Prelude

import Halogen.Component.ChildPath as CP

import SlamData.FileSystem.Dialog.Component as Dialog
import SlamData.FileSystem.Listing.Component as Listing
import SlamData.FileSystem.Search.Component as Search
import SlamData.Header.Component as Header
import SlamData.Notification.Component as Notify

type ChildQuery
  = Listing.Query
  ⨁ Search.Query
  ⨁ Dialog.Query
  ⨁ Header.Query
  ⨁ Notify.Query
  ⨁ Const Void

type ChildSlot
  = Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Void

cpListing
  ∷ CP.ChildPath
      Listing.Query ChildQuery
      Unit ChildSlot
cpListing = CP.cp1

cpSearch
  ∷ CP.ChildPath
      Search.Query ChildQuery
      Unit ChildSlot
cpSearch = CP.cp2

cpDialog
  ∷ CP.ChildPath
      Dialog.Query ChildQuery
      Unit ChildSlot
cpDialog = CP.cp3

cpHeader
  ∷ CP.ChildPath
      Header.Query ChildQuery
      Unit ChildSlot
cpHeader = CP.cp4

cpNotify
  ∷ CP.ChildPath
      Notify.Query ChildQuery
      Unit ChildSlot
cpNotify = CP.cp5

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.FileSystem.Component.ChildSlot where

import SlamData.Prelude

import Halogen.Component.ChildPath as CP

import SlamData.FileSystem.Breadcrumbs.Component as Breadcrumbs
import SlamData.FileSystem.Dialog.Component as Dialog
import SlamData.FileSystem.Listing.Component as Listing
import SlamData.FileSystem.Search.Component as Search
import SlamData.Header.Component as Header
import SlamData.Notification.Component as Notify

type ChildQuery
  = Listing.Query
  ⨁ Search.Query
  ⨁ Breadcrumbs.Query
  ⨁ Dialog.Query
  ⨁ Header.Query
  ⨁ Notify.Query
  ⨁ Const Void

type ChildSlot
  = Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Unit
  ⊹ Void

cpListing
  ∷ CP.ChildPath
      Listing.Query ChildQuery
      Unit ChildSlot
cpListing = CP.cp1

cpSearch
  ∷ CP.ChildPath
      Search.Query ChildQuery
      Unit ChildSlot
cpSearch = CP.cp2

cpBreadcrumbs
  ∷ CP.ChildPath
      Breadcrumbs.Query ChildQuery
      Unit ChildSlot
cpBreadcrumbs = CP.cp3

cpDialog
  ∷ CP.ChildPath
      Dialog.Query ChildQuery
      Unit ChildSlot
cpDialog = CP.cp4

cpHeader
  ∷ CP.ChildPath
      Header.Query ChildQuery
      Unit ChildSlot
cpHeader = CP.cp5

cpNotify
  ∷ CP.ChildPath
      Notify.Query ChildQuery
      Unit ChildSlot
cpNotify = CP.cp6


Moved function inline as it's not needed elsewhere

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 (abs, max, 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 -> Player -> Coordinate -> Boolean
hasPlayerPiece squares player coordinate =
  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 playerOne coordinate ||
  hasPlayerPiece squares playerTwo coordinate

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

isRegularMove :: Player -> Coordinate -> Coordinate -> Boolean
isRegularMove (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
  in d1 == to || d2 == to
isRegularMove _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
  in d3 == to || d4 == to

isJumpMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isJumpMove grid (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
      d5 = from + Tuple   2    2
      d6 = from + Tuple (-2)   2
      f = hasPlayerPiece grid.squares playerTwo
  in d5 == to && f d1 || d6 == to && f d2
isJumpMove grid _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
      d7 = from + Tuple   2  (-2)
      d8 = from + Tuple (-2) (-2)
      f = hasPlayerPiece grid.squares playerOne
  in d7 == to && f d3 || d8 == to && f d4

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to =
  isValid grid to && not hasPiece grid.squares to &&
  (isRegularMove player from to || isJumpMove grid player from to)

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  guard $ hasPlayerPiece grid.squares player coordinate
  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 =
  let fromIndex = fromJust (findIndex (hasCoordinate from) grid.squares)
      originalSquare = fromJust (grid.squares !! fromIndex)

      getMiddle :: Coordinate -> Coordinate -> Maybe Coordinate
      getMiddle (Tuple x1 y1) (Tuple x2 y2) =
        if abs (toNumber (y1 - y2)) == 2.0
        then
          let n1 = floor (max (toNumber x1) (toNumber x2) - 1.0)
              n2 = floor (max (toNumber y1) (toNumber y2) - 1.0)
          in Just (Tuple n1 n2)
        else Nothing
  in
    case getMiddle from to of
      Nothing -> removePiece from (alterPiece originalSquare.piece to grid)
      Just middle -> removePiece middle (removePiece from (alterPiece originalSquare.piece to grid))

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 { highlightedCoordinate = Nothing,
                                          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 (abs, max, 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 -> Player -> Coordinate -> Boolean
hasPlayerPiece squares player coordinate =
  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 playerOne coordinate ||
  hasPlayerPiece squares playerTwo coordinate

shouldJump :: Coordinate -> Coordinate -> Maybe Coordinate
shouldJump (Tuple x1 y1) (Tuple x2 y2) =
  if abs (toNumber (y1 - y2)) == 2.0
  then
    let n1 = floor (max (toNumber x1) (toNumber x2) - 1.0)
        n2 = floor (max (toNumber y1) (toNumber y2) - 1.0)
    in Just (Tuple n1 n2)
  else Nothing

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

isRegularMove :: Player -> Coordinate -> Coordinate -> Boolean
isRegularMove (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
  in d1 == to || d2 == to
isRegularMove _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
  in d3 == to || d4 == to

isJumpMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isJumpMove grid (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
      d5 = from + Tuple   2    2
      d6 = from + Tuple (-2)   2
      f = hasPlayerPiece grid.squares playerTwo
  in d5 == to && f d1 || d6 == to && f d2
isJumpMove grid _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
      d7 = from + Tuple   2  (-2)
      d8 = from + Tuple (-2) (-2)
      f = hasPlayerPiece grid.squares playerOne
  in d7 == to && f d3 || d8 == to && f d4

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to =
  isValid grid to && not hasPiece grid.squares to &&
  (isRegularMove player from to || isJumpMove grid player from to)

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  guard $ hasPlayerPiece grid.squares player coordinate
  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 =
  let fromIndex = fromJust (findIndex (hasCoordinate from) grid.squares)
      originalSquare = fromJust (grid.squares !! fromIndex)
  in
    case shouldJump from to of
      Nothing -> removePiece from (alterPiece originalSquare.piece to grid)
      Just middle -> removePiece middle (removePiece from (alterPiece originalSquare.piece to grid))

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 { highlightedCoordinate = Nothing,
                                          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


Added functions for deciding whether a coordinate in the grid has a piece or a player's piece

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
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 (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
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 =
  let color = if player == playerOne
              then colorPlayerOne
              else colorPlayerTwo
  in { player: player, color: color, king: false }

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) 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 { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid: (createGrid offset width height layers),
    currentPlayer: playerOne }

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

getCoordinateIndex :: Array Square -> Coordinate -> Maybe Int
getCoordinateIndex squares coordinate = findIndex (\e -> (Tuple e.x e.y) == coordinate) squares

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getCoordinateIndex squares coordinate of
    Nothing -> false
    Just index ->
      case (fromJust (squares !! index)).piece of
        Nothing -> false
        Just p -> p.player == player

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 <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (getCoordinateIndex grid.squares from)
      toIndex = fromJust (getCoordinateIndex grid.squares to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

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

renderPiece :: forall e.
                 Context2D ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece ctx event _ square =
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: square.rx + 0.5 * renderSize,
                       y: square.ry + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          case isOnSquare square (toNumber ux) (toNumber uy) of
            true -> do
              setLineWidth highlightWidth ctx
              strokePath ctx $ arc ctx arcPiece
              return unit
            false -> return unit
          return unit
      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 "black" ctx
  strokeRect ctx border
  return unit

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

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

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
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 (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
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 =
  let color = if player == playerOne
              then colorPlayerOne
              else colorPlayerTwo
  in { player: player, color: color, king: false }

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) 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 { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid: (createGrid offset width height layers),
    currentPlayer: playerOne }

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

getCoordinateIndex :: Array Square -> Coordinate -> Maybe Int
getCoordinateIndex squares coordinate = findIndex (\e -> (Tuple e.x e.y) == coordinate) squares

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

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (getCoordinateIndex grid.squares from)
      toIndex = fromJust (getCoordinateIndex grid.squares to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

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

renderPiece :: forall e.
                 Context2D ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece ctx event _ square =
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: square.rx + 0.5 * renderSize,
                       y: square.ry + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          case isOnSquare square (toNumber ux) (toNumber uy) of
            true -> do
              setLineWidth highlightWidth ctx
              strokePath ctx $ arc ctx arcPiece
              return unit
            false -> return unit
          return unit
      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 "black" ctx
  strokeRect ctx border
  return unit

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

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