Note down thoughts on exhaustive parser

Note down thoughts on exhaustive parser

module Docopt.Generate (
  mkBranchParser
, runCliParser
, lexArgv
, Token(..)
) where

import Prelude
import Control.Plus (empty)
import Debug.Trace
import Control.Monad.State (State(), evalState)
import Control.Apply ((*>), (<*))
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail)
import Data.Foldable (foldl)
import Data.String (fromCharArray, stripPrefix)
import qualified Data.List as L
import qualified Data.List.Unsafe as LU
import qualified Data.Array as A
import qualified Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Tuple (Tuple(..))
import Data.Monoid (mempty)

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

import Docopt
import Docopt.Parser.Base (alphaNum, space, getInput, debug)

--------------------------------------------------------------------------------
-- Input Lexer
--------------------------------------------------------------------------------

data Token
  = LOpt String (Maybe String)
  | SOpt Char (Array Char) (Maybe String)
  | Lit  String

prettyPrintToken :: Token -> String
prettyPrintToken (Lit s) = show s
prettyPrintToken (LOpt n a)
  = "--" ++ n ++ " " ++ (show a)
prettyPrintToken (SOpt n s a)
  = "-"  ++ (fromCharArray (A.cons n s)) ++ " " ++ (show a)

instance showToken :: Show Token where
  show (LOpt s a)    = "LOpt " ++ show s ++ " " ++ show a
  show (SOpt c cs a) = "SOpt " ++ show c ++ " " ++ show cs ++ " " ++ show a
  show (Lit  s)      = "Lit "  ++ show s

parseToken :: P.Parser String Token
parseToken = do
  P.choice $ P.try <$> [ sopt, lopt, lit ]
  <* P.eof
  where
    sopt :: P.Parser String Token
    sopt = do
      P.char '-'
      x  <- alphaNum
      xs <- A.many alphaNum
      arg <- P.choice $ P.try <$> [
        Just <$> do
          many space *> P.char '=' <* many space
          fromCharArray <$> do A.many P.anyChar
      , pure Nothing
      ]
      pure $ SOpt x xs arg
    lopt :: P.Parser String Token
    lopt = do
      P.string "--"
      xs <- fromCharArray <$> do
        A.many alphaNum
      arg <- P.choice $ P.try <$> [
        Just <$> do
          many space *> P.char '=' <* many space
          fromCharArray <$> do A.many P.anyChar
      , pure Nothing
      ]
      pure $ LOpt xs arg
    lit :: P.Parser String Token
    lit = Lit <<< fromCharArray <$> do
      A.many P.anyChar

lexArgv :: (List String) -> Either P.ParseError (List Token)
lexArgv = foldM step Nil
  where
    step :: List Token -> String -> Either P.ParseError (List Token)
    step a b = do
      x <- flip P.runParser parseToken b
      return (a ++ (Cons x Nil))

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

type CliParseState = { mapped :: List (Tuple Argument Value) }
type CliParser a = P.ParserT (List Token) (State CliParseState) a

runCliParser :: forall a.
                (List Token)
              -> CliParser a
              -> Either P.ParseError a
runCliParser input =
  flip evalState
  { mapped: Nil }
  <<< P.runParserT
  (P.PState { input: input, position: P.initialPos })

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

-- XXX: Should the `Pending` constructor store a list of `Parsers` instead?
data Acc a
  = Free (CliParser a)
  | Pending (CliParser a) (List Argument)

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

positional :: CliParser Value
positional = token go P.<?> "positional"
  where
    go (Lit _) = Just (BoolValue true)
    go _       = Nothing

-- | Parse the token at the head of the input stream and possibly replace
-- | it with another token. Consider, e.g. an option was parsed but has a
-- | valid remainder, that remainder should be offered to subsequent parsers.
token' :: forall a. (Token -> Tuple (Maybe Token) (Maybe a)) -> CliParser a
token' f = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case f tok of
        Tuple remainder (Just a) ->
          let nextpos = pos -- neglect pos
          in {
            consumed: maybe true (const false) remainder
          , input:    maybe xs (\r -> (r:xs)) remainder
          , result:   Right a
          , position: nextpos
          }
        _ -> P.parseFailed toks pos "bad token"
    _ -> P.parseFailed toks pos "expected token, met EOF"

(\\) :: forall a b. a -> b -> Tuple a b
(\\) = Tuple

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

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

  where

    takesArg = isJust a
    def      = maybe Nothing (\(OptionArgument _ v) -> v) a

    go :: Token
        -> (Maybe Token)
        -> Either String OptParse

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | takesArg  && (n' == n)
      = case v of
          -- XXX: The val needs to be parsed into a `Value`
          Just val -> return $ OptParse (StringValue val) Nothing false
          _  -> case atok of
            -- XXX: The lit needs to be parsed into a `Value`
            Just (Lit s) -> return $ OptParse (StringValue s) Nothing true
            _ -> case def of
              Just defval -> return $ OptParse defval Nothing false
              _ -> Left "Argument required"

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

    go _ _ = Left "Invalid token"

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

  where

    takesArg = isJust a
    def      = maybe Nothing (\(OptionArgument _ v) -> v) a

    go :: Token
        -> (Maybe Token)
        -> Either String OptParse

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && takesArg && (A.length xs == 0)
      = case v of
          -- XXX: The val needs to be parsed into a `Value`
          Just val -> return $ OptParse (StringValue val) Nothing false
          _  -> case atok of
            -- XXX: The lit needs to be parsed into a `Value`
            Just (Lit s) -> return $ OptParse (StringValue s) Nothing true
            _ -> case def of
              Just defval -> return $ OptParse defval Nothing false
              _ -> Left "Argument required"

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

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

    go a b = Left $ "Invalid token" ++ show a ++ " / " ++ show b

-- | Generate a parser for a single usage branch
mkBranchParser :: Branch -> CliParser (List (Tuple Argument Value))
mkBranchParser (Branch xs) = do
  either
    (\_ -> P.fail "Failed to generate parser")
    (\acc -> case acc of
      Free p       -> p
      Pending p xs -> do
        a  <- p
        as <- mkExaustiveParser xs
        return (a ++ as))
    (foldM step (Free $ pure empty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    --
    -- XXX: Replace this with a manual iteration - i.e. consume each
    --      argument. Only fail if an argument has not been consumed
    --      that was declared as *required*.
    --
    --      This will allow for repeating flags in any order, i.e.:
    --      "-vbvbvb" would be equivalent to "-vvvbbb" (currenlty possible)
    mkExaustiveParser :: List Argument
                      -> CliParser (List (Tuple Argument Value))
    mkExaustiveParser Nil = pure empty
    mkExaustiveParser ps  = do
      let ls = reduce <$> (permute ps)
      P.choice $ P.try <$> ls
      where
          reduce :: List Argument -> CliParser (List (Tuple Argument Value))
          reduce ls = foldl step (pure empty) ls
            where step acc p = do
                    as <- acc
                    a  <- mkParser p
                    return (as ++ a)

          permute :: forall a. (Eq a) => List a -> List (List a)
          permute Nil = Cons Nil Nil
          permute xs  = do
              x  <- xs
              ys <- permute $ delete x xs
              return (x:ys)

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

    -- Any other argument causes immediate evaluation
    step (Free p) x = Right $ Free do
      a  <- p
      as <- (mkParser x)
      return (a ++ as)

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

    -- Any non-options always leaves the pending state
    step (Pending p xs) y = Right $
      Free do
        a  <- p
        as <- mkExaustiveParser xs
        return (a ++ as)

    -- Parser generator for a single `Argument`
    mkParser :: Argument -> CliParser (List (Tuple Argument Value))

    -- Generate a parser for a `Command` argument
    mkParser x@(Command n) = do
      singleton <<< Tuple x <$> do
        command n

    -- Generate a parser for a `Positional` argument
    mkParser x@(Positional n r) = do
      if r then (some go) else (singleton <$> go)
      where go = Tuple x <$> positional

    -- Generate a parser for a `Option` argument
    mkParser x@(Option f n a r) = do
      if r then (some go) else (singleton <$> go)
      where
        go = do
          P.choice $ P.try <$> [
            Tuple x <$> (mkLoptParser n a)
          , Tuple x <$> (mkSoptParser f a)
          ]

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

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

    -- Generate a parser for a argument `Group`
    mkParser (Group o bs r) =
      -- XXX: Recursively generate a parser.
      --      NOTE: THIS COMPUTATION MAY FAIL:
      --            `mkParser` must be in the Either monad
      -- XXX: Consider `r` here - we must either return a list, always, or
      --      a data type that ensures that at least one value is present:
      --      `X Xs`, where both `X` and `Xs` are data constructors.
      pure empty

module Docopt.Generate (
  mkBranchParser
, runCliParser
, lexArgv
, Token(..)
) where

import Prelude
import Control.Plus (empty)
import Debug.Trace
import Control.Monad.State (State(), evalState)
import Control.Apply ((*>), (<*))
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail)
import Data.Foldable (foldl)
import Data.String (fromCharArray, stripPrefix)
import qualified Data.List as L
import qualified Data.List.Unsafe as LU
import qualified Data.Array as A
import qualified Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Tuple (Tuple(..))
import Data.Monoid (mempty)

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

import Docopt
import Docopt.Parser.Base (alphaNum, space, getInput, debug)

--------------------------------------------------------------------------------
-- Input Lexer
--------------------------------------------------------------------------------

data Token
  = LOpt String (Maybe String)
  | SOpt Char (Array Char) (Maybe String)
  | Lit  String

prettyPrintToken :: Token -> String
prettyPrintToken (Lit s) = show s
prettyPrintToken (LOpt n a)
  = "--" ++ n ++ " " ++ (show a)
prettyPrintToken (SOpt n s a)
  = "-"  ++ (fromCharArray (A.cons n s)) ++ " " ++ (show a)

instance showToken :: Show Token where
  show (LOpt s a)    = "LOpt " ++ show s ++ " " ++ show a
  show (SOpt c cs a) = "SOpt " ++ show c ++ " " ++ show cs ++ " " ++ show a
  show (Lit  s)      = "Lit "  ++ show s

parseToken :: P.Parser String Token
parseToken = do
  P.choice $ P.try <$> [ sopt, lopt, lit ]
  <* P.eof
  where
    sopt :: P.Parser String Token
    sopt = do
      P.char '-'
      x  <- alphaNum
      xs <- A.many alphaNum
      arg <- P.choice $ P.try <$> [
        Just <$> do
          many space *> P.char '=' <* many space
          fromCharArray <$> do A.many P.anyChar
      , pure Nothing
      ]
      pure $ SOpt x xs arg
    lopt :: P.Parser String Token
    lopt = do
      P.string "--"
      xs <- fromCharArray <$> do
        A.many alphaNum
      arg <- P.choice $ P.try <$> [
        Just <$> do
          many space *> P.char '=' <* many space
          fromCharArray <$> do A.many P.anyChar
      , pure Nothing
      ]
      pure $ LOpt xs arg
    lit :: P.Parser String Token
    lit = Lit <<< fromCharArray <$> do
      A.many P.anyChar

lexArgv :: (List String) -> Either P.ParseError (List Token)
lexArgv = foldM step Nil
  where
    step :: List Token -> String -> Either P.ParseError (List Token)
    step a b = do
      x <- flip P.runParser parseToken b
      return (a ++ (Cons x Nil))

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

type CliParseState = { mapped :: List (Tuple Argument Value) }
type CliParser a = P.ParserT (List Token) (State CliParseState) a

runCliParser :: forall a.
                (List Token)
              -> CliParser a
              -> Either P.ParseError a
runCliParser input =
  flip evalState
  { mapped: Nil }
  <<< P.runParserT
  (P.PState { input: input, position: P.initialPos })

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

-- XXX: Should the `Pending` constructor store a list of `Parsers` instead?
data Acc a
  = Free (CliParser a)
  | Pending (CliParser a) (List Argument)

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

positional :: CliParser Value
positional = token go P.<?> "positional"
  where
    go (Lit _) = Just (BoolValue true)
    go _       = Nothing

-- | Parse the token at the head of the input stream and possibly replace
-- | it with another token. Consider, e.g. an option was parsed but has a
-- | valid remainder, that remainder should be offered to subsequent parsers.
token' :: forall a. (Token -> Tuple (Maybe Token) (Maybe a)) -> CliParser a
token' f = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case f tok of
        Tuple remainder (Just a) ->
          let nextpos = pos -- neglect pos
          in {
            consumed: maybe true (const false) remainder
          , input:    maybe xs (\r -> (r:xs)) remainder
          , result:   Right a
          , position: nextpos
          }
        _ -> P.parseFailed toks pos "bad token"
    _ -> P.parseFailed toks pos "expected token, met EOF"

(\\) :: forall a b. a -> b -> Tuple a b
(\\) = Tuple

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

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

  where

    takesArg = isJust a
    def      = maybe Nothing (\(OptionArgument _ v) -> v) a

    go :: Token
        -> (Maybe Token)
        -> Either String OptParse

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | takesArg  && (n' == n)
      = case v of
          -- XXX: The val needs to be parsed into a `Value`
          Just val -> return $ OptParse (StringValue val) Nothing false
          _  -> case atok of
            -- XXX: The lit needs to be parsed into a `Value`
            Just (Lit s) -> return $ OptParse (StringValue s) Nothing true
            _ -> case def of
              Just defval -> return $ OptParse defval Nothing false
              _ -> Left "Argument required"

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

    go _ _ = Left "Invalid token"

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

  where

    takesArg = isJust a
    def      = maybe Nothing (\(OptionArgument _ v) -> v) a

    go :: Token
        -> (Maybe Token)
        -> Either String OptParse

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && takesArg && (A.length xs == 0)
      = case v of
          -- XXX: The val needs to be parsed into a `Value`
          Just val -> return $ OptParse (StringValue val) Nothing false
          _  -> case atok of
            -- XXX: The lit needs to be parsed into a `Value`
            Just (Lit s) -> return $ OptParse (StringValue s) Nothing true
            _ -> case def of
              Just defval -> return $ OptParse defval Nothing false
              _ -> Left "Argument required"

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

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

    go a b = Left $ "Invalid token" ++ show a ++ " / " ++ show b

-- | Generate a parser for a single usage branch
mkBranchParser :: Branch -> CliParser (List (Tuple Argument Value))
mkBranchParser (Branch xs) = do
  either
    (\_ -> P.fail "Failed to generate parser")
    (\acc -> case acc of
      Free p       -> p
      Pending p xs -> do
        a  <- p
        as <- mkExaustiveParser xs
        return (a ++ as))
    (foldM step (Free $ pure empty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    mkExaustiveParser :: List Argument
                      -> CliParser (List (Tuple Argument Value))
    mkExaustiveParser Nil = pure empty
    mkExaustiveParser ps  = do
      let ls = reduce <$> (permute ps)
      P.choice $ P.try <$> ls
      where
          reduce :: List Argument -> CliParser (List (Tuple Argument Value))
          reduce ls = foldl step (pure empty) ls
            where step acc p = do
                    as <- acc
                    a  <- mkParser p
                    return (as ++ a)

          permute :: forall a. (Eq a) => List a -> List (List a)
          permute Nil = Cons Nil Nil
          permute xs  = do
              x  <- xs
              ys <- permute $ delete x xs
              return (x:ys)

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

    -- Any other argument causes immediate evaluation
    step (Free p) x = Right $ Free do
      a  <- p
      as <- (mkParser x)
      return (a ++ as)

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

    -- Any non-options always leaves the pending state
    step (Pending p xs) y = Right $
      Free do
        a  <- p
        as <- mkExaustiveParser xs
        return (a ++ as)

    -- Parser generator for a single `Argument`
    mkParser :: Argument -> CliParser (List (Tuple Argument Value))

    -- Generate a parser for a `Command` argument
    mkParser x@(Command n) = do
      singleton <<< Tuple x <$> do
        command n

    -- Generate a parser for a `Positional` argument
    mkParser x@(Positional n r) = do
      if r then (some go) else (singleton <$> go)
      where go = Tuple x <$> positional

    -- Generate a parser for a `Option` argument
    mkParser x@(Option f n a r) = do
      if r then (some go) else (singleton <$> go)
      where
        go = do
          P.choice $ P.try <$> [
            Tuple x <$> (mkLoptParser n a)
          , Tuple x <$> (mkSoptParser f a)
          ]

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

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

    -- Generate a parser for a argument `Group`
    mkParser (Group o bs r) =
      -- XXX: Recursively generate a parser.
      --      NOTE: THIS COMPUTATION MAY FAIL:
      --            `mkParser` must be in the Either monad
      -- XXX: Consider `r` here - we must either return a list, always, or
      --      a data type that ensures that at least one value is present:
      --      `X Xs`, where both `X` and `Xs` are data constructors.
      pure empty


Implements a ReaderT example for "interpret"

module Example.Interpret.Main where

import Prelude

import Control.Monad.Reader (ReaderT, ask, runReaderT)
import Control.Monad.Trans.Class (lift)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (class Newtype)
import Effect (Effect)
import Effect.Aff (Aff)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.VDom.Driver (runUI)
import Network.HTTP.Affjax as AX
import Network.HTTP.Affjax.Response as AXResponse

type Env = { githubToken :: Maybe String }

newtype App a = App (ReaderT Env Aff a)
derive instance newtypeApp ∷ Newtype (App a) _
derive newtype instance functorApp ∷ Functor App
derive newtype instance applyApp ∷ Apply App
derive newtype instance applicativeApp ∷ Applicative App
derive newtype instance bindApp ∷ Bind App
derive newtype instance monadApp ∷ Monad App

runApp :: forall a. Env -> App a -> Aff a
runApp env (App app) = runReaderT app env

class Monad m <= GithubAPI m where
  searchUser ∷ String → m String

instance githubAPI ∷ GithubAPI App where
  searchUser q = App do
    { githubToken } <- ask
    { response } <- case githubToken of
      Nothing ->
        lift $ AX.get AXResponse.string ("https://api.github.com/users/" <> q)
      Just token ->
        lift $ AX.get AXResponse.string ("https://api.github.com/users/" <> q <> "?access_token=" <> token)
    pure response

type State = { userData :: Maybe String }

data Action = FetchData

ui :: forall f i o m. GithubAPI m => H.Component HH.HTML f i o m
ui =
  H.mkComponent
    { initialState: const initialState
    , render
    , eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
    }
  where

  initialState :: State
  initialState = { userData: Nothing }

  render :: State -> H.ComponentHTML Action () m
  render state =
    HH.div_
      [ HH.h1_
          [ HH.text "Fetch user data" ]
      , HH.button
          [ HE.onClick \_ -> Just FetchData ]
          [ HH.text "Fetch" ]
      , HH.p_
          [ HH.text (fromMaybe "No user data" state.userData) ]
      ]

handleAction :: forall o m. GithubAPI m => Action -> H.HalogenM State Action () o m Unit
handleAction = case _ of
  FetchData -> do
    userData <- lift $ searchUser "kRITZCREEK"
    H.put { userData: Just userData }

ui' :: forall f i o. H.Component HH.HTML f i o Aff
ui' = H.hoist (runApp { githubToken: Nothing }) ui

main :: Effect Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  runUI ui' unit body

module Example.Interpret.Main where

import Prelude

import Control.Monad.Free (Free, liftF, foldFree)
import Data.Maybe (Maybe(..))
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Console (log)
import Halogen (liftEffect)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.VDom.Driver (runUI)

type State = { on :: Boolean }

data Query a = ToggleState a

data MyAlgebra a = Log String a
type MyMonad = Free MyAlgebra

output :: String -> MyMonad Unit
output msg = liftF (Log msg unit)

ui :: H.Component HH.HTML Query Unit Void MyMonad
ui =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    , initializer: Nothing
    , finalizer: Nothing
    }
  where

  initialState :: State
  initialState = { on: false }

  render :: forall m. State -> H.ComponentHTML (Query Unit) () m
  render state =
    HH.div_
      [ HH.h1_
          [ HH.text "Toggle Button" ]
      , HH.button
          [ HE.onClick (HE.input_ ToggleState) ]
          [ HH.text (if state.on then "On" else "Off") ]
      ]

  eval :: Query ~> H.HalogenM State (Query Unit) () Void MyMonad
  eval (ToggleState next) = do
    H.modify_ (\state -> { on: not state.on })
    H.lift $ output "State was toggled"
    pure next

ui' :: H.Component HH.HTML Query Unit Void Aff
ui' = H.hoist (foldFree evalMyAlgebra) ui
  where
  evalMyAlgebra :: MyAlgebra ~> Aff
  evalMyAlgebra (Log msg next) = do
    liftEffect $ log msg
    pure next

main :: Effect Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  runUI ui' unit body


Use Int for randomInt, uppercase effect name

module Control.Monad.Eff.Random where

import Control.Monad.Eff (Eff())
import Data.Int (Int(), fromNumber, toNumber)

-- | The `RANDOM` effect indicates that an Eff action may access or modify the
-- | JavaScript global random number generator, i.e. `Math.random()`.
foreign import data RANDOM :: !

-- | Returns a random number between 0 (inclusive) and 1 (exclusive). This is
-- | a direct wrapper around JavaScript's `Math.random()`.
foreign import random
  """
  function random() {
    return Math.random();
  }
  """ :: forall e. Eff (random :: RANDOM | e) Number

-- | Takes a range specified by `low` (the first argument) and `high` (the
-- | second), and returns a random integer uniformly distributed in the closed
-- | interval `[low, high]`. It is unspecified what happens if `low > high`,
-- | or if either of `low` or `high` is not an integer.
-- |
-- | For example:
-- | ``` purescript
-- | randomInt (fromNumber 1) (fromNumber 10) >>= Console.print
-- | ```
-- | will print a random integer between 1 and 10.
randomInt :: forall e . Int -> Int -> Eff (random :: RANDOM | e) Int
randomInt low high = fromNumber <<< ((toNumber ((high - low + one) + low)) *) <$> random

-- | Returns a random number between a minimum value (inclusive) and a maximum
-- | value (exclusive). It is unspecified what happens if `maximum < minimum`.
-- |
-- | For example:
-- | ``` purescript
-- | randomRange 1 2 >>= Console.print
-- | ```
-- | will print a random number between 1 and 2.
randomRange :: forall e . Number -> Number -> Eff (random :: RANDOM | e) Number
randomRange min max = (((max - min) + min) *) <$> random

module Control.Monad.Eff.Random where

import Control.Monad.Eff
import Math (floor)

-- | The `Random` effect indicates that an Eff action may access or modify the
-- | JavaScript global random number generator, i.e. `Math.random()`.
foreign import data Random :: !

-- | Returns a random number between 0 (inclusive) and 1 (exclusive). This is
-- | a direct wrapper around JavaScript's `Math.random()`.
foreign import random
  """
  function random() {
    return Math.random();
  }
  """ :: forall e. Eff (random :: Random | e) Number

-- | Takes a range specified by `low` (the first argument) and `high` (the
-- | second), and returns a random integer uniformly distributed in the closed
-- | interval `[low, high]`. It is unspecified what happens if `low > high`,
-- | or if either of `low` or `high` is not an integer.
-- |
-- | For example:
-- |
-- | * `randomInt 1 10 >>= Debug.Trace.print`
-- |
-- | will print a random integer between 1 and 10.
randomInt :: forall e . Number -> Number -> Eff (random :: Random | e) Number
randomInt low high = do
  rand <- random
  return (floor (rand * (high - low + 1)) + low)

-- | Returns a random number between a minimum value (inclusive) and a maximum
-- | value (exclusive). It is unspecified what happens if `maximum < minimum`.
-- |
-- | For example:
-- |
-- | * `randomRange 1 2 >>= Debug.Trace.print`
-- |
-- | will print a random number between 1 and 2.
randomRange :: forall e . Number -> Number -> Eff (random :: Random | e) Number
randomRange min max = do
  r <- random
  return (r * (max - min) + min)


Use new config functions in main Container

module Genetics.Browser.UI.Container
       where

import Prelude
import Genetics.Browser.Renderer.GWAS as GWAS
import Genetics.Browser.Renderer.Lineplot as QTL
import Genetics.Browser.UI.Biodalliance as UIBD
import Genetics.Browser.UI.Cytoscape as UICy
import Halogen as H
import Halogen.Aff as HA
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import DOM.HTML.Types (HTMLElement)
import Data.Array (null)
import Data.Const (Const)
import Data.Either.Nested (Either2)
import Data.Foldable (foldMap)
import Data.Functor.Coproduct.Nested (type (<\/>))
import Data.Maybe (Maybe(Just, Nothing))
import Data.Newtype (wrap)
import Data.Options (Options, (:=))
import Genetics.Browser.Biodalliance (RendererInfo, initBD, renderers, sources)
import Genetics.Browser.Config (BrowserConfig(..))
import Genetics.Browser.Config.Track (CyGraphConfig, validateConfigs)
import Genetics.Browser.Events (JsonEvent)
import Genetics.Browser.Renderer.Lineplot (LinePlotConfig)
import Genetics.Browser.Types (BD, Biodalliance, Renderer)
import Genetics.Browser.Units (Bp(Bp), Chr)
import Global.Unsafe (unsafeStringify)
import Halogen.VDom.Driver (runUI)

qtlGlyphify :: LinePlotConfig -> Renderer
qtlGlyphify = QTL.render

gwasGlyphify :: Renderer
gwasGlyphify = GWAS.render

data Track = BDTrack | CyTrack

type State = Unit

data Query a
  = Nop a
  | CreateBD (∀ eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance) a
  | BDScroll Bp a
  | BDJump Chr Bp Bp a
  | CreateCy String a
  | ResetCy a
  | DistEvent Track JsonEvent a

type ChildSlot = Either2 UIBD.Slot UICy.Slot

type ChildQuery = UIBD.Query <\/> UICy.Query <\/> Const Void

type Effects eff = UIBD.Effects (UICy.Effects eff)

component :: ∀ eff. H.Component HH.HTML Query Unit Void (Aff (Effects eff))
component =
  H.parentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  initialState :: State
  initialState = unit

  -- #svgHolder {
  --     width: 100%,
  --     float: left;
  -- }
  -- #cyHolder {
  --     width: 100%;
  --     height: 300px;
  --     float: left;
  --     display: block;
  -- }

  render :: State -> H.ParentHTML Query ChildQuery ChildSlot (Aff (Effects eff))
  render state =
    HH.div_
      [ HH.div_
        [ HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp (-1000000.0))))
          ]
          [ HH.text "Scroll left 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp 1000000.0)))
          ]
          [ HH.text "Scroll right 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ ResetCy)
          ]
          [ HH.text "Reset cytoscape" ]
          -- these divs are used to control the sizes of the subcomponents without having to query the children
        , HH.div
            [] [HH.slot' CP.cp1 UIBD.Slot UIBD.component unit handleBDMessage]
        , HH.div
            [] [HH.slot' CP.cp2 UICy.Slot UICy.component unit handleCyMessage]
        ]
      -- , HH.div
      --     [
      --       -- fix stylesheet - should be on the right hand side, not too wide...
      --     ]
      --     [
      --     ]
      ]

  addCyGraph :: Maybe CyGraphConfig -> _
  addCyGraph = case _ of
    Nothing -> []
    Just cy -> [HH.div [] [HH.slot' CP.cp2 UICy.Slot UICy.component unit handleCyMessage]]

  handleBDMessage :: UIBD.Message -> Maybe (Query Unit)
  handleBDMessage UIBD.Initialized = Just $ ResetCy unit
  handleBDMessage (UIBD.SendEvent obj) = Just $ DistEvent BDTrack obj unit

     -- TODO the event source track should be handled automatically somehow
  handleCyMessage :: UICy.Output -> Maybe (Query Unit)
  handleCyMessage (UICy.SendEvent ev) = Just $ DistEvent CyTrack ev unit

  eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Void (Aff (Effects eff))
  eval = case _ of
    Nop next -> do
      pure next

    CreateBD bd next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Initialize bd)
      pure next
    BDScroll dist next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Scroll dist)
      pure next
    BDJump chr xl xr next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Jump chr xl xr)
      pure next

    CreateCy div next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action (UICy.Initialize div)
      pure next
    ResetCy next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action UICy.Reset
      pure next

    DistEvent from ev next -> do
      liftEff $ log "container is distributing event:"
      liftEff $ log $ unsafeStringify ev

      _ <- case from of
        BDTrack ->
          H.query' CP.cp2 UICy.Slot $ H.action (UICy.RecvEvent ev)
        CyTrack ->
          H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.RecvEvent ev)

      pure next

qtlRenderer :: RendererInfo
qtlRenderer = { name: "qtlRenderer"
              , renderer: qtlGlyphify { minScore: 4.0
                                      , maxScore: 6.0
                                      , color: "#ff0000"
                                      }
              , canvasHeight: 200.0
              }

gwasRenderer :: RendererInfo
gwasRenderer = { name: "gwasRenderer"
               , renderer: gwasGlyphify
               , canvasHeight: 300.0
               }

bdOpts :: Options Biodalliance
bdOpts = renderers := [ qtlRenderer, gwasRenderer ]

main :: BrowserConfig -> Eff _ Unit
main (BrowserConfig { wrapRenderer, browser, tracks }) = HA.runHalogenAff do

  let {bdTracks, cyGraphs} = validateConfigs tracks

      opts' = bdOpts <> sources := bdTracks.results

  liftEff $ log $ "BDTrack errors: " <> foldMap ((<>) ", ") bdTracks.errors
  liftEff $ log $ "CyGraph errors: " <> foldMap ((<>) ", ") cyGraphs.errors

  let mkBd :: (∀ eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance)
      mkBd = initBD opts' wrapRenderer browser

  liftEff $ log "running main"
  HA.awaitLoad
  el <- HA.selectElement (wrap "#psgbHolder")
  case el of
    Nothing -> do
      liftEff $ log "no element for browser!"
    Just el' -> do
      io <- runUI component unit el'
      liftEff $ log "creating BD"
      io.query $ H.action (CreateBD mkBd)
      liftEff $ log "created BD!"
      liftEff $ log $ "cytoscape enabled: " <> show (not null cyGraphs.results)
      when (not null cyGraphs.results) $ do
        liftEff $ log "creating Cy.js"
        io.query $ H.action (CreateCy "http://localhost:8080/eles.json")
        liftEff $ log "created cy!"

module Genetics.Browser.UI.Container
       where

import Prelude
import Genetics.Browser.Renderer.GWAS as GWAS
import Genetics.Browser.Renderer.Lineplot as QTL
import Genetics.Browser.UI.Biodalliance as UIBD
import Genetics.Browser.UI.Cytoscape as UICy
import Halogen as H
import Halogen.Aff as HA
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (_Array)
import Data.Array (foldr, null, (:))
import Data.Const (Const)
import Data.Either (Either(Right, Left))
import Data.Either.Nested (Either2)
import Data.Foldable (foldMap)
import Data.Functor.Coproduct.Nested (type (<\/>))
import Data.Lens ((^?))
import Data.Maybe (Maybe(Just, Nothing), isNothing, maybe)
import Data.Newtype (wrap)
import Data.Options (Options, (:=))
import Genetics.Browser.Biodalliance (RendererInfo, initBD, renderers, sources)
import Genetics.Browser.Config (BrowserConfig(..))
import Genetics.Browser.Config.Track (CyGraphConfig, validateBDConfig, validateCyConfig)
import Genetics.Browser.Events (JsonEvent)
import Genetics.Browser.Renderer.Lineplot (LinePlotConfig)
import Genetics.Browser.Types (BD, Biodalliance, Renderer)
import Genetics.Browser.Units (Bp(Bp), Chr)
import Global.Unsafe (unsafeStringify)
import Halogen.VDom.Driver (runUI)

qtlGlyphify :: LinePlotConfig -> Renderer
qtlGlyphify = QTL.render

gwasGlyphify :: Renderer
gwasGlyphify = GWAS.render

data Track = BDTrack | CyTrack

type State = Unit

data Query a
  = Nop a
  | CreateBD (∀ eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance) a
  | BDScroll Bp a
  | BDJump Chr Bp Bp a
  | CreateCy String a
  | ResetCy a
  | DistEvent Track JsonEvent a

type ChildSlot = Either2 UIBD.Slot UICy.Slot

type ChildQuery = UIBD.Query <\/> UICy.Query <\/> Const Void

type Effects eff = UIBD.Effects (UICy.Effects eff)

component :: ∀ eff. H.Component HH.HTML Query Unit Void (Aff (Effects eff))
component =
  H.parentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  initialState :: State
  initialState = unit

  -- #svgHolder {
  --     width: 100%,
  --     float: left;
  -- }
  -- #cyHolder {
  --     width: 100%;
  --     height: 300px;
  --     float: left;
  --     display: block;
  -- }

  render :: State -> H.ParentHTML Query ChildQuery ChildSlot (Aff (Effects eff))
  render state =
    HH.div_
      [ HH.div_
        [ HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp (-1000000.0))))
          ]
          [ HH.text "Scroll left 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp 1000000.0)))
          ]
          [ HH.text "Scroll right 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ ResetCy)
          ]
          [ HH.text "Reset cytoscape" ]
          -- these divs are used to control the sizes of the subcomponents without having to query the children
        , HH.div
            [] [HH.slot' CP.cp1 UIBD.Slot UIBD.component unit handleBDMessage]
        , HH.div
            [] [HH.slot' CP.cp2 UICy.Slot UICy.component unit handleCyMessage]
        ]
      -- , HH.div
      --     [
      --       -- fix stylesheet - should be on the right hand side, not too wide...
      --     ]
      --     [
      --     ]
      ]

  addCyGraph :: Maybe CyGraphConfig -> _
  addCyGraph = case _ of
    Nothing -> []
    Just cy -> [HH.div [] [HH.slot' CP.cp2 UICy.Slot UICy.component unit handleCyMessage]]

  handleBDMessage :: UIBD.Message -> Maybe (Query Unit)
  handleBDMessage UIBD.Initialized = Just $ ResetCy unit
  handleBDMessage (UIBD.SendEvent obj) = Just $ DistEvent BDTrack obj unit

     -- TODO the event source track should be handled automatically somehow
  handleCyMessage :: UICy.Output -> Maybe (Query Unit)
  handleCyMessage (UICy.SendEvent ev) = Just $ DistEvent CyTrack ev unit

  eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Void (Aff (Effects eff))
  eval = case _ of
    Nop next -> do
      pure next

    CreateBD bd next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Initialize bd)
      pure next
    BDScroll dist next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Scroll dist)
      pure next
    BDJump chr xl xr next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Jump chr xl xr)
      pure next

    CreateCy div next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action (UICy.Initialize div)
      pure next
    ResetCy next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action UICy.Reset
      pure next

    DistEvent from ev next -> do
      liftEff $ log "container is distributing event:"
      liftEff $ log $ unsafeStringify ev

      _ <- case from of
        BDTrack ->
          H.query' CP.cp2 UICy.Slot $ H.action (UICy.RecvEvent ev)
        CyTrack ->
          H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.RecvEvent ev)

      pure next

qtlRenderer :: RendererInfo
qtlRenderer = { name: "qtlRenderer"
              , renderer: qtlGlyphify { minScore: 4.0
                                      , maxScore: 6.0
                                      , color: "#ff0000"
                                      }
              , canvasHeight: 200.0
              }

gwasRenderer :: RendererInfo
gwasRenderer = { name: "gwasRenderer"
               , renderer: gwasGlyphify
               , canvasHeight: 300.0
               }

bdOpts :: Options Biodalliance
bdOpts = renderers := [ qtlRenderer, gwasRenderer ]

main :: BrowserConfig -> Eff _ Unit
main (BrowserConfig { wrapRenderer, browser, tracks }) = HA.runHalogenAff do
  when (isNothing $ tracks ^? _Array) $ liftEff $ log "Tracks config is not an array"

  let validated = maybe [] (map validateBDConfig) $ tracks ^? _Array
      validatedCy = maybe [] (map validateCyConfig) $ tracks ^? _Array

      {errors, tracks} = foldr (\c {errors, tracks} ->
                                 case c of Left  e -> {errors: (e : errors), tracks}
                                           Right t -> {errors, tracks: (t : tracks)}
                               ) { errors: [], tracks: [] } validated

      opts' = bdOpts <> sources := tracks

  liftEff $ log $ "Track errors: " <> foldMap ((<>) ", ") errors

  let mkBd :: (∀ eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance)
      mkBd = initBD opts' wrapRenderer browser

  liftEff $ log "running main"
  HA.awaitLoad
  el <- HA.selectElement (wrap "#psgbHolder")
  case el of
    Nothing -> do
      liftEff $ log "no element for browser!"
    Just el' -> do
      io <- runUI component unit el'
      liftEff $ log "creating BD"
      io.query $ H.action (CreateBD mkBd)
      liftEff $ log "created BD!"
      liftEff $ log $ "cytoscape enabled: " <> show (not null validatedCy)
      when (not null validatedCy) $ do
        liftEff $ log "creating Cy.js"
        io.query $ H.action (CreateCy "http://localhost:8080/eles.json")
        liftEff $ log "created cy!"


Avoid Discard constraint

Avoid Discard constraint

module Control.Monad.Aff
  ( Aff
  , Canceler(..)
  , PureAff(..)
  , apathize
  , attempt
  , cancel
  , cancelWith
  , finally
  , forkAff
  , forkAll
  , later
  , later'
  , launchAff
  , liftEff'
  , makeAff
  , makeAff'
  , nonCanceler
  , runAff
  , ParAff(..)
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Monad.Aff.Internal (AVBox, AVar, _killVar, _putVar, _takeVar, _makeVar)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, throwException, error)
import Control.Monad.Error.Class (class MonadError, throwError)
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.MonadPlus (class MonadZero, class MonadPlus)
import Control.Parallel (class Parallel)
import Control.Plus (class Plus, empty)

import Data.Either (Either(..), either)
import Data.Foldable (class Foldable, foldl)
import Data.Function.Uncurried (Fn2, Fn3, runFn2, runFn3)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple(..), fst, snd)

import Unsafe.Coerce (unsafeCoerce)

-- | An asynchronous computation with effects `e`. The computation either
-- | errors or produces a value of type `a`.
-- |
-- | This is moral equivalent of `ErrorT (ContT Unit (Eff e)) a`.
foreign import data Aff :: # ! -> * -> *

-- | A pure asynchronous computation, having no effects other than
-- | asynchronous computation.
type PureAff a = forall e. Aff e a

-- | A canceler is an asynchronous function that can be used to attempt the
-- | cancelation of a computation. Returns a boolean flag indicating whether
-- | or not the cancellation was successful. Many computations may be composite,
-- | in such cases the flag indicates whether any part of the computation was
-- | successfully canceled. The flag should not be used for communication.
newtype Canceler e = Canceler (Error -> Aff e Boolean)

-- | Unwraps the canceler function from the newtype that wraps it.
cancel :: forall e. Canceler e -> Error -> Aff e Boolean
cancel (Canceler f) = f

-- | This function allows you to attach a custom canceler to an asynchronous
-- | computation. If the computation is canceled, then the custom canceler
-- | will be run along side the computation's own canceler.
cancelWith :: forall e a. Aff e a -> Canceler e -> Aff e a
cancelWith aff c = runFn3 _cancelWith nonCanceler aff c

-- | Converts the asynchronous computation into a synchronous one. All values
-- | are ignored, and if the computation produces an error, it is thrown.
-- |
-- | Catching exceptions by using `catchException` with the resulting Eff
-- | computation is not recommended, as exceptions may end up being thrown
-- | asynchronously, in which case they cannot be caught.
-- |
-- | If you do need to handle exceptions, you can use `runAff` instead, or
-- | you can handle the exception within the Aff computation, using
-- | `catchError` (or any of the other mechanisms).
launchAff :: forall e a. Aff e a -> Eff (err :: EXCEPTION | e) (Canceler e)
launchAff = lowerEx <<< runAff throwException (const (pure unit)) <<< liftEx
  where
  liftEx :: Aff e a -> Aff (err :: EXCEPTION | e) a
  liftEx = _unsafeInterleaveAff
  lowerEx :: Eff (err :: EXCEPTION | e) (Canceler (err :: EXCEPTION | e)) -> Eff (err :: EXCEPTION | e) (Canceler e)
  lowerEx = map (Canceler <<< map _unsafeInterleaveAff <<< cancel)

-- | Runs the asynchronous computation. You must supply an error callback and a
-- | success callback.
-- |
-- | Returns a canceler that can be used to attempt cancellation of the
-- | asynchronous computation.
runAff :: forall e a. (Error -> Eff e Unit) -> (a -> Eff e Unit) -> Aff e a -> Eff e (Canceler e)
runAff ex f aff = runFn3 _runAff ex f aff

-- | Creates an asynchronous effect from a function that accepts error and
-- | success callbacks. This function can be used for asynchronous computations
-- | that cannot be canceled.
makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e Unit) -> Aff e a
makeAff h = makeAff' (\e a -> const nonCanceler <$> h e a)

-- | Creates an asynchronous effect from a function that accepts error and
-- | success callbacks, and returns a canceler for the computation. This
-- | function can be used for asynchronous computations that can be canceled.
makeAff' :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e (Canceler e)) -> Aff e a
makeAff' h = _makeAff h

-- | Runs the asynchronous computation off the current execution context.
later :: forall e a. Aff e a -> Aff e a
later = later' 0

-- | Runs the specified asynchronous computation later, by the specified
-- | number of milliseconds.
later' :: forall e a. Int -> Aff e a -> Aff e a
later' n aff = runFn3 _setTimeout nonCanceler n aff

-- | Compute `aff1`, followed by `aff2` regardless of whether `aff1` terminated successfully.
finally :: forall e a b. Aff e a -> Aff e b -> Aff e a
finally aff1 aff2 = do
  x <- attempt aff1
  _ <- aff2
  either throwError pure x

-- | Forks the specified asynchronous computation so subsequent computations
-- | will not block on the result of the computation.
-- |
-- | Returns a canceler that can be used to attempt cancellation of the
-- | forked computation.
forkAff :: forall e a. Aff e a -> Aff e (Canceler e)
forkAff aff = runFn2 _forkAff nonCanceler aff

-- | Forks many asynchronous computation in a synchronous manner while being
-- | stack-safe up to the selected Foldable instance.
-- |
-- | Returns a canceler that can be used to attempt cancellation of all
-- | forked computations.
forkAll :: forall f e a. (Foldable f) => f (Aff e a) -> Aff e (Canceler e)
forkAll affs = runFn3 _forkAll nonCanceler foldl affs

-- | Promotes any error to the value level of the asynchronous monad.
attempt :: forall e a. Aff e a -> Aff e (Either Error a)
attempt aff = runFn3 _attempt Left Right aff

-- | Ignores any errors.
apathize :: forall e a. Aff e a -> Aff e Unit
apathize a = const unit <$> attempt a

-- | Lifts a synchronous computation and makes explicit any failure from exceptions.
liftEff' :: forall e a. Eff (err :: EXCEPTION | e) a -> Aff e (Either Error a)
liftEff' eff = attempt (_unsafeInterleaveAff (runFn2 _liftEff nonCanceler eff))

-- | A constant canceller that always returns false.
nonCanceler :: forall e. Canceler e
nonCanceler = Canceler (const (pure false))

-- | A constant canceller that always returns true.
alwaysCanceler :: forall e. Canceler e
alwaysCanceler = Canceler (const (pure true))

instance semigroupAff :: (Semigroup a) => Semigroup (Aff e a) where
  append a b = (<>) <$> a <*> b

instance monoidAff :: (Monoid a) => Monoid (Aff e a) where
  mempty = pure mempty

instance functorAff :: Functor (Aff e) where
  map f fa = runFn2 _fmap f fa

instance applyAff :: Apply (Aff e) where
  apply ff fa = runFn3 _bind alwaysCanceler ff (\f -> f <$> fa)

instance applicativeAff :: Applicative (Aff e) where
  pure v = runFn2 _pure nonCanceler v

instance bindAff :: Bind (Aff e) where
  bind fa f = runFn3 _bind alwaysCanceler fa f

instance monadAff :: Monad (Aff e)

instance monadEffAff :: MonadEff e (Aff e) where
  liftEff eff = runFn2 _liftEff nonCanceler eff

-- | Allows users to catch and throw errors on the error channel of the
-- | asynchronous computation. See documentation in `purescript-transformers`.
instance monadErrorAff :: MonadError Error (Aff e) where
  throwError e = runFn2 _throwError nonCanceler e

  catchError aff ex = attempt aff >>= either ex pure

instance altAff :: Alt (Aff e) where
  alt a1 a2 = attempt a1 >>= either (const a2) pure

instance plusAff :: Plus (Aff e) where
  empty = throwError $ error "Always fails"

instance alternativeAff :: Alternative (Aff e)

instance monadZero :: MonadZero (Aff e)

instance monadPlusAff :: MonadPlus (Aff e)

instance monadRecAff :: MonadRec (Aff e) where
  tailRecM f a = runFn3 _tailRecM isLoop f a
    where
    isLoop (Loop _) = true
    isLoop _ = false

instance semigroupCanceler :: Semigroup (Canceler e) where
  append (Canceler f1) (Canceler f2) = Canceler (\e -> (||) <$> f1 e <*> f2 e)

instance monoidCanceler :: Monoid (Canceler e) where
  mempty = Canceler (const (pure true))

newtype ParAff e a = ParAff (Aff e a)

derive instance newtypeParAff :: Newtype (ParAff e a) _

instance semigroupParAff :: (Semigroup a) => Semigroup (ParAff e a) where
  append a b = append <$> a <*> b

instance monoidParAff :: (Monoid a) => Monoid (ParAff e a) where
  mempty = pure mempty

derive newtype instance functorParAff :: Functor (ParAff e)

instance applyParAff :: Apply (ParAff e) where
  apply (ParAff ff) (ParAff fa) = ParAff do
    va <- makeVar
    vb <- makeVar
    c1 <- forkAff (putOrKill va =<< attempt ff)
    c2 <- forkAff (putOrKill vb =<< attempt fa)
    (takeVar va <*> takeVar vb) `cancelWith` (c1 <> c2)
    where
    putOrKill :: forall a. AVar a -> Either Error a -> Aff e Unit
    putOrKill v = either (killVar v) (putVar v)

instance applicativeParAff :: Applicative (ParAff e) where
  pure = ParAff <<< pure

-- | Returns the first value, or the first error if both error.
instance altParAff :: Alt (ParAff e) where
  alt (ParAff a1) (ParAff a2) = ParAff do
    va <- makeVar -- the `a` value
    ve <- makeVar -- the error count (starts at 0)
    cs <- makeVar -- the cancelers
    putVar ve 0
    c1 <- forkAff $ either (maybeKill va ve) (done cs snd va) =<< attempt a1
    c2 <- forkAff $ either (maybeKill va ve) (done cs fst va) =<< attempt a2
    putVar cs (Tuple c1 c2)
    takeVar va `cancelWith` (c1 <> c2)
    where
    done :: forall a. AVar (Tuple (Canceler e) (Canceler e)) -> (forall x. Tuple x x -> x) -> AVar a -> a -> Aff e Unit
    done cs get va x = do
      putVar va x
      c <- get <$> takeVar cs
      void $ cancel c (error "Alt early exit")
    maybeKill :: forall a. AVar a -> AVar Int -> Error -> Aff e Unit
    maybeKill va ve err = do
      e <- takeVar ve
      when (e == 1) $ killVar va err
      putVar ve (e + 1)

instance plusParAff :: Plus (ParAff e) where
  empty = ParAff empty

instance alternativeParAff :: Alternative (ParAff e)

instance parallelParAff :: Parallel (ParAff e) (Aff e) where
  parallel = ParAff
  sequential (ParAff ma) = ma

makeVar :: forall e a. Aff e (AVar a)
makeVar = fromAVBox $ _makeVar nonCanceler

takeVar :: forall e a. AVar a -> Aff e a
takeVar q = fromAVBox $ runFn2 _takeVar nonCanceler q

putVar :: forall e a. AVar a -> a -> Aff e Unit
putVar q a = fromAVBox $ runFn3 _putVar nonCanceler q a

killVar :: forall e a. AVar a -> Error -> Aff e Unit
killVar q e = fromAVBox $ runFn3 _killVar nonCanceler q e

fromAVBox :: forall a e. AVBox a -> Aff e a
fromAVBox = unsafeCoerce

foreign import _cancelWith :: forall e a. Fn3 (Canceler e) (Aff e a) (Canceler e) (Aff e a)

foreign import _setTimeout :: forall e a. Fn3 (Canceler e) Int (Aff e a) (Aff e a)

foreign import _unsafeInterleaveAff :: forall e1 e2 a. Aff e1 a -> Aff e2 a

foreign import _forkAff :: forall e a. Fn2 (Canceler e) (Aff e a) (Aff e (Canceler e))

foreign import _forkAll :: forall f e a b. Fn3 (Canceler e) ((b -> a -> b) -> b -> f a -> b) (f (Aff e a)) (Aff e (Canceler e))

foreign import _makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e (Canceler e)) -> Aff e a

foreign import _pure :: forall e a. Fn2 (Canceler e) a (Aff e a)

foreign import _throwError :: forall e a. Fn2 (Canceler e) Error (Aff e a)

foreign import _fmap :: forall e a b. Fn2 (a -> b) (Aff e a) (Aff e b)

foreign import _bind :: forall e a b. Fn3 (Canceler e) (Aff e a) (a -> Aff e b) (Aff e b)

foreign import _attempt :: forall e a. Fn3 (forall x y. x -> Either x y) (forall x y. y -> Either x y) (Aff e a) (Aff e (Either Error a))

foreign import _runAff :: forall e a. Fn3 (Error -> Eff e Unit) (a -> Eff e Unit) (Aff e a) (Eff e (Canceler e))

foreign import _liftEff :: forall e a. Fn2 (Canceler e) (Eff e a) (Aff e a)

foreign import _tailRecM :: forall e a b. Fn3 (Step a b -> Boolean) (a -> Aff e (Step a b)) a (Aff e b)

module Control.Monad.Aff
  ( Aff
  , Canceler(..)
  , PureAff(..)
  , apathize
  , attempt
  , cancel
  , cancelWith
  , finally
  , forkAff
  , forkAll
  , later
  , later'
  , launchAff
  , liftEff'
  , makeAff
  , makeAff'
  , nonCanceler
  , runAff
  , ParAff(..)
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Monad.Aff.Internal (AVBox, AVar, _killVar, _putVar, _takeVar, _makeVar)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, throwException, error)
import Control.Monad.Error.Class (class MonadError, throwError)
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.MonadPlus (class MonadZero, class MonadPlus)
import Control.Parallel (class Parallel)
import Control.Plus (class Plus, empty)

import Data.Either (Either(..), either)
import Data.Foldable (class Foldable, foldl)
import Data.Function.Uncurried (Fn2, Fn3, runFn2, runFn3)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple(..), fst, snd)

import Unsafe.Coerce (unsafeCoerce)

-- | An asynchronous computation with effects `e`. The computation either
-- | errors or produces a value of type `a`.
-- |
-- | This is moral equivalent of `ErrorT (ContT Unit (Eff e)) a`.
foreign import data Aff :: # ! -> * -> *

-- | A pure asynchronous computation, having no effects other than
-- | asynchronous computation.
type PureAff a = forall e. Aff e a

-- | A canceler is an asynchronous function that can be used to attempt the
-- | cancelation of a computation. Returns a boolean flag indicating whether
-- | or not the cancellation was successful. Many computations may be composite,
-- | in such cases the flag indicates whether any part of the computation was
-- | successfully canceled. The flag should not be used for communication.
newtype Canceler e = Canceler (Error -> Aff e Boolean)

-- | Unwraps the canceler function from the newtype that wraps it.
cancel :: forall e. Canceler e -> Error -> Aff e Boolean
cancel (Canceler f) = f

-- | This function allows you to attach a custom canceler to an asynchronous
-- | computation. If the computation is canceled, then the custom canceler
-- | will be run along side the computation's own canceler.
cancelWith :: forall e a. Aff e a -> Canceler e -> Aff e a
cancelWith aff c = runFn3 _cancelWith nonCanceler aff c

-- | Converts the asynchronous computation into a synchronous one. All values
-- | are ignored, and if the computation produces an error, it is thrown.
-- |
-- | Catching exceptions by using `catchException` with the resulting Eff
-- | computation is not recommended, as exceptions may end up being thrown
-- | asynchronously, in which case they cannot be caught.
-- |
-- | If you do need to handle exceptions, you can use `runAff` instead, or
-- | you can handle the exception within the Aff computation, using
-- | `catchError` (or any of the other mechanisms).
launchAff :: forall e a. Aff e a -> Eff (err :: EXCEPTION | e) (Canceler e)
launchAff = lowerEx <<< runAff throwException (const (pure unit)) <<< liftEx
  where
  liftEx :: Aff e a -> Aff (err :: EXCEPTION | e) a
  liftEx = _unsafeInterleaveAff
  lowerEx :: Eff (err :: EXCEPTION | e) (Canceler (err :: EXCEPTION | e)) -> Eff (err :: EXCEPTION | e) (Canceler e)
  lowerEx = map (Canceler <<< map _unsafeInterleaveAff <<< cancel)

-- | Runs the asynchronous computation. You must supply an error callback and a
-- | success callback.
-- |
-- | Returns a canceler that can be used to attempt cancellation of the
-- | asynchronous computation.
runAff :: forall e a. (Error -> Eff e Unit) -> (a -> Eff e Unit) -> Aff e a -> Eff e (Canceler e)
runAff ex f aff = runFn3 _runAff ex f aff

-- | Creates an asynchronous effect from a function that accepts error and
-- | success callbacks. This function can be used for asynchronous computations
-- | that cannot be canceled.
makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e Unit) -> Aff e a
makeAff h = makeAff' (\e a -> const nonCanceler <$> h e a)

-- | Creates an asynchronous effect from a function that accepts error and
-- | success callbacks, and returns a canceler for the computation. This
-- | function can be used for asynchronous computations that can be canceled.
makeAff' :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e (Canceler e)) -> Aff e a
makeAff' h = _makeAff h

-- | Runs the asynchronous computation off the current execution context.
later :: forall e a. Aff e a -> Aff e a
later = later' 0

-- | Runs the specified asynchronous computation later, by the specified
-- | number of milliseconds.
later' :: forall e a. Int -> Aff e a -> Aff e a
later' n aff = runFn3 _setTimeout nonCanceler n aff

-- | Compute `aff1`, followed by `aff2` regardless of whether `aff1` terminated successfully.
finally :: forall e a b. Aff e a -> Aff e b -> Aff e a
finally aff1 aff2 = do
  x <- attempt aff1
  aff2
  either throwError pure x

-- | Forks the specified asynchronous computation so subsequent computations
-- | will not block on the result of the computation.
-- |
-- | Returns a canceler that can be used to attempt cancellation of the
-- | forked computation.
forkAff :: forall e a. Aff e a -> Aff e (Canceler e)
forkAff aff = runFn2 _forkAff nonCanceler aff

-- | Forks many asynchronous computation in a synchronous manner while being
-- | stack-safe up to the selected Foldable instance.
-- |
-- | Returns a canceler that can be used to attempt cancellation of all
-- | forked computations.
forkAll :: forall f e a. (Foldable f) => f (Aff e a) -> Aff e (Canceler e)
forkAll affs = runFn3 _forkAll nonCanceler foldl affs

-- | Promotes any error to the value level of the asynchronous monad.
attempt :: forall e a. Aff e a -> Aff e (Either Error a)
attempt aff = runFn3 _attempt Left Right aff

-- | Ignores any errors.
apathize :: forall e a. Aff e a -> Aff e Unit
apathize a = const unit <$> attempt a

-- | Lifts a synchronous computation and makes explicit any failure from exceptions.
liftEff' :: forall e a. Eff (err :: EXCEPTION | e) a -> Aff e (Either Error a)
liftEff' eff = attempt (_unsafeInterleaveAff (runFn2 _liftEff nonCanceler eff))

-- | A constant canceller that always returns false.
nonCanceler :: forall e. Canceler e
nonCanceler = Canceler (const (pure false))

-- | A constant canceller that always returns true.
alwaysCanceler :: forall e. Canceler e
alwaysCanceler = Canceler (const (pure true))

instance semigroupAff :: (Semigroup a) => Semigroup (Aff e a) where
  append a b = (<>) <$> a <*> b

instance monoidAff :: (Monoid a) => Monoid (Aff e a) where
  mempty = pure mempty

instance functorAff :: Functor (Aff e) where
  map f fa = runFn2 _fmap f fa

instance applyAff :: Apply (Aff e) where
  apply ff fa = runFn3 _bind alwaysCanceler ff (\f -> f <$> fa)

instance applicativeAff :: Applicative (Aff e) where
  pure v = runFn2 _pure nonCanceler v

instance bindAff :: Bind (Aff e) where
  bind fa f = runFn3 _bind alwaysCanceler fa f

instance monadAff :: Monad (Aff e)

instance monadEffAff :: MonadEff e (Aff e) where
  liftEff eff = runFn2 _liftEff nonCanceler eff

-- | Allows users to catch and throw errors on the error channel of the
-- | asynchronous computation. See documentation in `purescript-transformers`.
instance monadErrorAff :: MonadError Error (Aff e) where
  throwError e = runFn2 _throwError nonCanceler e

  catchError aff ex = attempt aff >>= either ex pure

instance altAff :: Alt (Aff e) where
  alt a1 a2 = attempt a1 >>= either (const a2) pure

instance plusAff :: Plus (Aff e) where
  empty = throwError $ error "Always fails"

instance alternativeAff :: Alternative (Aff e)

instance monadZero :: MonadZero (Aff e)

instance monadPlusAff :: MonadPlus (Aff e)

instance monadRecAff :: MonadRec (Aff e) where
  tailRecM f a = runFn3 _tailRecM isLoop f a
    where
    isLoop (Loop _) = true
    isLoop _ = false

instance semigroupCanceler :: Semigroup (Canceler e) where
  append (Canceler f1) (Canceler f2) = Canceler (\e -> (||) <$> f1 e <*> f2 e)

instance monoidCanceler :: Monoid (Canceler e) where
  mempty = Canceler (const (pure true))

newtype ParAff e a = ParAff (Aff e a)

derive instance newtypeParAff :: Newtype (ParAff e a) _

instance semigroupParAff :: (Semigroup a) => Semigroup (ParAff e a) where
  append a b = append <$> a <*> b

instance monoidParAff :: (Monoid a) => Monoid (ParAff e a) where
  mempty = pure mempty

derive newtype instance functorParAff :: Functor (ParAff e)

instance applyParAff :: Apply (ParAff e) where
  apply (ParAff ff) (ParAff fa) = ParAff do
    va <- makeVar
    vb <- makeVar
    c1 <- forkAff (putOrKill va =<< attempt ff)
    c2 <- forkAff (putOrKill vb =<< attempt fa)
    (takeVar va <*> takeVar vb) `cancelWith` (c1 <> c2)
    where
    putOrKill :: forall a. AVar a -> Either Error a -> Aff e Unit
    putOrKill v = either (killVar v) (putVar v)

instance applicativeParAff :: Applicative (ParAff e) where
  pure = ParAff <<< pure

-- | Returns the first value, or the first error if both error.
instance altParAff :: Alt (ParAff e) where
  alt (ParAff a1) (ParAff a2) = ParAff do
    va <- makeVar -- the `a` value
    ve <- makeVar -- the error count (starts at 0)
    cs <- makeVar -- the cancelers
    putVar ve 0
    c1 <- forkAff $ either (maybeKill va ve) (done cs snd va) =<< attempt a1
    c2 <- forkAff $ either (maybeKill va ve) (done cs fst va) =<< attempt a2
    putVar cs (Tuple c1 c2)
    takeVar va `cancelWith` (c1 <> c2)
    where
    done :: forall a. AVar (Tuple (Canceler e) (Canceler e)) -> (forall x. Tuple x x -> x) -> AVar a -> a -> Aff e Unit
    done cs get va x = do
      putVar va x
      c <- get <$> takeVar cs
      void $ cancel c (error "Alt early exit")
    maybeKill :: forall a. AVar a -> AVar Int -> Error -> Aff e Unit
    maybeKill va ve err = do
      e <- takeVar ve
      when (e == 1) $ killVar va err
      putVar ve (e + 1)

instance plusParAff :: Plus (ParAff e) where
  empty = ParAff empty

instance alternativeParAff :: Alternative (ParAff e)

instance parallelParAff :: Parallel (ParAff e) (Aff e) where
  parallel = ParAff
  sequential (ParAff ma) = ma

makeVar :: forall e a. Aff e (AVar a)
makeVar = fromAVBox $ _makeVar nonCanceler

takeVar :: forall e a. AVar a -> Aff e a
takeVar q = fromAVBox $ runFn2 _takeVar nonCanceler q

putVar :: forall e a. AVar a -> a -> Aff e Unit
putVar q a = fromAVBox $ runFn3 _putVar nonCanceler q a

killVar :: forall e a. AVar a -> Error -> Aff e Unit
killVar q e = fromAVBox $ runFn3 _killVar nonCanceler q e

fromAVBox :: forall a e. AVBox a -> Aff e a
fromAVBox = unsafeCoerce

foreign import _cancelWith :: forall e a. Fn3 (Canceler e) (Aff e a) (Canceler e) (Aff e a)

foreign import _setTimeout :: forall e a. Fn3 (Canceler e) Int (Aff e a) (Aff e a)

foreign import _unsafeInterleaveAff :: forall e1 e2 a. Aff e1 a -> Aff e2 a

foreign import _forkAff :: forall e a. Fn2 (Canceler e) (Aff e a) (Aff e (Canceler e))

foreign import _forkAll :: forall f e a b. Fn3 (Canceler e) ((b -> a -> b) -> b -> f a -> b) (f (Aff e a)) (Aff e (Canceler e))

foreign import _makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e (Canceler e)) -> Aff e a

foreign import _pure :: forall e a. Fn2 (Canceler e) a (Aff e a)

foreign import _throwError :: forall e a. Fn2 (Canceler e) Error (Aff e a)

foreign import _fmap :: forall e a b. Fn2 (a -> b) (Aff e a) (Aff e b)

foreign import _bind :: forall e a b. Fn3 (Canceler e) (Aff e a) (a -> Aff e b) (Aff e b)

foreign import _attempt :: forall e a. Fn3 (forall x y. x -> Either x y) (forall x y. y -> Either x y) (Aff e a) (Aff e (Either Error a))

foreign import _runAff :: forall e a. Fn3 (Error -> Eff e Unit) (a -> Eff e Unit) (Aff e a) (Eff e (Canceler e))

foreign import _liftEff :: forall e a. Fn2 (Canceler e) (Eff e a) (Aff e a)

foreign import _tailRecM :: forall e a b. Fn3 (Step a b -> Boolean) (a -> Aff e (Step a b)) a (Aff e b)


Fix type of setHref, returns Unit not String

module DOM.HTML.Location
  ( hash
  , setHash
  , host
  , setHost
  , hostname
  , setHostname
  , href
  , setHref
  , origin
  , setOrigin
  , pathname
  , setPathname
  , port
  , setPort
  , protocol
  , setProtocol
  , search
  , setSearch

  , assign
  , replace
  , reload
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import DOM (DOM)
import DOM.HTML.Types (Location)

foreign import hash :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setHash :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import host :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setHost :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import hostname :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setHostname :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import href :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setHref :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import origin :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setOrigin :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import pathname :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setPathname :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import port :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setPort :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import protocol :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setProtocol :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import search :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setSearch :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import assign :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit
foreign import replace :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit
foreign import reload :: forall eff. Location -> Eff (dom :: DOM | eff) Unit

module DOM.HTML.Location
  ( hash
  , setHash
  , host
  , setHost
  , hostname
  , setHostname
  , href
  , setHref
  , origin
  , setOrigin
  , pathname
  , setPathname
  , port
  , setPort
  , protocol
  , setProtocol
  , search
  , setSearch

  , assign
  , replace
  , reload
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import DOM (DOM)
import DOM.HTML.Types (Location)

foreign import hash :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setHash :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import host :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setHost :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import hostname :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setHostname :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import href :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setHref :: forall eff. String -> Location -> Eff (dom :: DOM | eff) String

foreign import origin :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setOrigin :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import pathname :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setPathname :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import port :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setPort :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import protocol :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setProtocol :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import search :: forall eff. Location -> Eff (dom :: DOM | eff) String
foreign import setSearch :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit

foreign import assign :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit
foreign import replace :: forall eff. String -> Location -> Eff (dom :: DOM | eff) Unit
foreign import reload :: forall eff. Location -> Eff (dom :: DOM | eff) Unit