Remove "TODO" comment

Remove "TODO" comment

-- | Resolve ambiguities by combining the parsed usage section with any parsed
-- | Option sections, as well as some best effort guessing.
-- |
-- | ===

module Docopt.Spec.Solver where

import Prelude
import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe.Unsafe (fromJust)
import Data.Maybe (Maybe(..), isJust, maybe, maybe', isNothing)
import Data.List (List(..), filter, head, foldM, concat, (:), singleton
                , catMaybes, toList, last, init, length)
import Data.Traversable (traverse)
import Data.Foldable (foldl)
import Control.Plus (empty)
import Data.Monoid (mempty)
import qualified Data.Array as A

import Docopt (Argument(..), Application(..), Branch(..), OptionArgument(..)
              , Value(..))
import qualified Docopt.Spec.Parser.Desc  as D
import qualified Docopt.Spec.Parser.Usage as U

data SolveError = SolveError
instance showSolveError :: Show SolveError where
  show _ = "SolveError"

solveArg :: U.Argument -> List D.Desc -> Either SolveError (List Argument)
solveArg (U.Command s) _       = singleton <$> return (Command s)
solveArg (U.Positional s r) _  = singleton <$> return (Positional s r)
solveArg o@(U.Option n a r) ds = singleton <$> do
  -- XXX: Is `head` the right thing to do here? What if there are more
  -- matches? That would indicate ambigiutiy and needs to be treated, possibly
  -- with an error?
  return $ maybe' (\_ -> Option Nothing (Just n) (toArg a) r)
                  id
                  (head $ catMaybes $ convert <$> ds)

  where
    toArg:: Maybe String -> Maybe OptionArgument
    toArg a = a >>= \an -> return $ OptionArgument an Nothing

    resolveArg :: Maybe String -> Maybe D.Argument -> Maybe OptionArgument
    resolveArg (Just an) Nothing = return $ OptionArgument an Nothing
    resolveArg Nothing (Just (D.Argument a))
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg (Just an) (Just (D.Argument a))
      -- XXX: Do we need to guard that `an == a.name` here?
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg _ _ = Nothing

    convert :: D.Desc -> Maybe Argument
    convert (D.OptionDesc (D.Option { name=D.Long n', arg=a' }))
      | n' == n
      = return $ Option Nothing (Just n) (resolveArg a a') r
    convert (D.OptionDesc (D.Option { name=D.Full f n', arg=a' }))
      | n' == n
      = return $ Option (Just f) (Just n) (resolveArg a a') r
    convert _ = Nothing

solveArg o@(U.OptionStack f fs a r) ds = do
  let fs' = f:toList fs

  -- Ensure that only the last stacked option is to be considered in
  -- "trailing" position and hence capable of expanding to take an argument.
  if length fs' > 1
    then do
      xs <- traverse (match false) (fromJust $ init fs')
      x  <- match true (fromJust $ last fs')
      return $ xs ++ singleton x
    else
      traverse (match true) fs'

  where
    match :: Boolean -> Char -> Either SolveError Argument
    match isTrailing f = do
      return $ maybe' (\_ -> Option (Just f) Nothing (toArg a) r)
                      id
                      (head $ catMaybes $ convert f isTrailing <$> ds)

    toArg:: Maybe String -> Maybe OptionArgument
    toArg a = a >>= \an -> return $ OptionArgument an Nothing

    resolveArg :: Maybe String -> Maybe D.Argument -> Maybe OptionArgument
    resolveArg (Just an) Nothing = return $ OptionArgument an Nothing
    resolveArg Nothing (Just (D.Argument a))
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg (Just an) (Just (D.Argument a))
      -- XXX: Do we need to guard that `an == a.name` here?
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)

    convert :: Char -> Boolean -> D.Desc -> Maybe Argument
    convert f isTrailing (D.OptionDesc (D.Option { name=D.Flag f', arg=a' }))
      | (f == f')
        && (isTrailing || isNothing a')
      = return $ Option (Just f) Nothing (resolveArg a a') r
    convert f isTrailing (D.OptionDesc (D.Option { name=D.Full f' n, arg=a' }))
      | (f == f')
        && (isTrailing || isNothing a')
      = return $ Option (Just f) (Just n) (resolveArg a a') r
    convert _ _ _ = Nothing

solveArg (U.Group o bs r) ds  = singleton <$> do
  flip (Group o) r <$> do
    foldM go empty bs
      where go :: List Branch -> U.Branch -> Either SolveError (List Branch)
            go a b = do
              br <- solveBranch b ds
              return (br:a)

solveBranch :: U.Branch -> List D.Desc -> Either SolveError Branch
solveBranch as ds = Branch <<< concat <$> (foldM step Nil as)
  where
    step :: List (List Argument)
          -> U.Argument
          -> Either SolveError (List (List Argument))
    step ass a = do
      xs <- solveArg a ds
      return $ ass ++ (singleton xs)

solveUsage :: U.Usage -> List D.Desc -> Either SolveError Application
solveUsage (U.Usage _ bs) ds = Application <$> (foldM step Nil bs)
  where
    step :: List Branch -> U.Branch -> Either SolveError (List Branch)
    step bs b = do
      x <- solveBranch b ds
      return $ bs ++ (singleton x)

solve :: (List U.Usage)
      -> (List D.Desc)
      -> Either SolveError (List Application)
solve us ds = foldM step Nil us
  where
    step :: List Application -> U.Usage -> Either SolveError (List Application)
    step as u = do
      x <- solveUsage u ds
      return $ as ++ (singleton x)

-- | Resolve ambiguities by combining the parsed usage section with any parsed
-- | Option sections, as well as some best effort guessing.
-- |
-- | ===

module Docopt.Spec.Solver where

import Prelude
import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe.Unsafe (fromJust)
import Data.Maybe (Maybe(..), isJust, maybe, maybe', isNothing)
import Data.List (List(..), filter, head, foldM, concat, (:), singleton
                , catMaybes, toList, last, init, length)
import Data.Traversable (traverse)
import Data.Foldable (foldl)
import Control.Plus (empty)
import Data.Monoid (mempty)
import qualified Data.Array as A

import Docopt (Argument(..), Application(..), Branch(..), OptionArgument(..)
              , Value(..))
import qualified Docopt.Spec.Parser.Desc  as D
import qualified Docopt.Spec.Parser.Usage as U

data SolveError = SolveError
instance showSolveError :: Show SolveError where
  show _ = "SolveError"

solveArg :: U.Argument -> List D.Desc -> Either SolveError (List Argument)
solveArg (U.Command s) _       = singleton <$> return (Command s)
solveArg (U.Positional s r) _  = singleton <$> return (Positional s r)
solveArg o@(U.Option n a r) ds = singleton <$> do
  -- XXX: Is `head` the right thing to do here? What if there are more
  -- matches? That would indicate ambigiutiy and needs to be treated, possibly
  -- with an error?
  return $ maybe' (\_ -> Option Nothing (Just n) (toArg a) r)
                  id
                  (head $ catMaybes $ convert <$> ds)

  where
    toArg:: Maybe String -> Maybe OptionArgument
    toArg a = a >>= \an -> return $ OptionArgument an Nothing

    resolveArg :: Maybe String -> Maybe D.Argument -> Maybe OptionArgument
    resolveArg (Just an) Nothing = return $ OptionArgument an Nothing
    resolveArg Nothing (Just (D.Argument a))
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg (Just an) (Just (D.Argument a))
      -- XXX: Do we need to guard that `an == a.name` here?
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg _ _ = Nothing

    convert :: D.Desc -> Maybe Argument
    convert (D.OptionDesc (D.Option { name=D.Long n', arg=a' }))
      | n' == n
      = return $ Option Nothing (Just n) (resolveArg a a') r
    convert (D.OptionDesc (D.Option { name=D.Full f n', arg=a' }))
      | n' == n
      = return $ Option (Just f) (Just n) (resolveArg a a') r
    convert _ = Nothing

solveArg o@(U.OptionStack f fs a r) ds = do
  -- TODO
  -- Match f and then each f in fs up with a descrption, if any, returning
  -- an Docopt.Option for each.

  let fs' = f:toList fs

  -- Ensure that only the last stacked option is to be considered in
  -- "trailing" position and hence capable of expanding to take an argument.
  if length fs' > 1
    then do
      xs <- traverse (match false) (fromJust $ init fs')
      x  <- match true (fromJust $ last fs')
      return $ xs ++ singleton x
    else
      traverse (match true) fs'

  where
    match :: Boolean -> Char -> Either SolveError Argument
    match isTrailing f = do
      return $ maybe' (\_ -> Option (Just f) Nothing (toArg a) r)
                      id
                      (head $ catMaybes $ convert f isTrailing <$> ds)

    toArg:: Maybe String -> Maybe OptionArgument
    toArg a = a >>= \an -> return $ OptionArgument an Nothing

    resolveArg :: Maybe String -> Maybe D.Argument -> Maybe OptionArgument
    resolveArg (Just an) Nothing = return $ OptionArgument an Nothing
    resolveArg Nothing (Just (D.Argument a))
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)
    resolveArg (Just an) (Just (D.Argument a))
      -- XXX: Do we need to guard that `an == a.name` here?
      -- XXX: The conversion to `StringValue` should not be needed,
      -- `Desc.Argument` should be of type `Maybe Value`.
      = return $ OptionArgument a.name (StringValue <$> a.default)

    convert :: Char -> Boolean -> D.Desc -> Maybe Argument
    convert f isTrailing (D.OptionDesc (D.Option { name=D.Flag f', arg=a' }))
      | (f == f')
        && (isTrailing || isNothing a')
      = return $ Option (Just f) Nothing (resolveArg a a') r
    convert f isTrailing (D.OptionDesc (D.Option { name=D.Full f' n, arg=a' }))
      | (f == f')
        && (isTrailing || isNothing a')
      = return $ Option (Just f) (Just n) (resolveArg a a') r
    convert _ _ _ = Nothing

solveArg (U.Group o bs r) ds  = singleton <$> do
  flip (Group o) r <$> do
    foldM go empty bs
      where go :: List Branch -> U.Branch -> Either SolveError (List Branch)
            go a b = do
              br <- solveBranch b ds
              return (br:a)

solveBranch :: U.Branch -> List D.Desc -> Either SolveError Branch
solveBranch as ds = Branch <<< concat <$> (foldM step Nil as)
  where
    step :: List (List Argument)
          -> U.Argument
          -> Either SolveError (List (List Argument))
    step ass a = do
      xs <- solveArg a ds
      return $ ass ++ (singleton xs)

solveUsage :: U.Usage -> List D.Desc -> Either SolveError Application
solveUsage (U.Usage _ bs) ds = Application <$> (foldM step Nil bs)
  where
    step :: List Branch -> U.Branch -> Either SolveError (List Branch)
    step bs b = do
      x <- solveBranch b ds
      return $ bs ++ (singleton x)

solve :: (List U.Usage)
      -> (List D.Desc)
      -> Either SolveError (List Application)
solve us ds = foldM step Nil us
  where
    step :: List Application -> U.Usage -> Either SolveError (List Application)
    step as u = do
      x <- solveUsage u ds
      return $ as ++ (singleton x)


Add missing import of retry, and missing AVAR annotations

module Api.Query (query, port, sample, SQL(), fields, count, all, templated) where

import Prelude
import Api.Common (getResponse, succeeded, retryGet)
import Config (queryUrl, dataUrl)
import Control.Apply (lift2)
import Control.Bind ((<=<), (>=>))
import Control.Monad.Aff (Aff())
import Control.Monad.Aff.AVar (AVAR())
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Combinators ((.?))
import Data.Argonaut.Core (JArray(), Json(), JObject(), jsonEmptyObject, isArray, isObject, foldJson, toArray, toObject, toNumber, fromObject)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (concat, nub, filter, head)
import Utils (encodeURIComponent)
import Data.Either (Either(..), either)
import Data.Either.Unsafe (fromRight)
import Data.Foldable (foldl)
import Data.List (uncons, fromList)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.String (split, replace)
import Data.StrMap (StrMap(), keys, toList, empty, lookup)
import Data.Tuple (Tuple(..))
import Model.Notebook.Port (VarMapValue())
import Model.Path (AnyPath())
import Model.Resource (Resource(), resourcePath, isFile, _name)
import Network.HTTP.Affjax (Affjax(), AJAX(), affjax, defaultRequest, retry)
import Network.HTTP.Method (Method(..))
import Network.HTTP.RequestHeader (RequestHeader(..))
import Optic.Core
import qualified Data.Int as I

-- | This is template string where actual path is encoded like {{path}}
type SQL = String

query :: forall e. Resource -> SQL -> Aff (ajax :: AJAX, avar :: AVAR | e) JArray
query res sql =
  if not $ isFile res
  then pure []
  else extractJArray <$> (getResponse msg $ retryGet uri)
  where
  msg = "error in query"
  uri = mkURI res sql

count :: forall e. Resource -> Aff (ajax :: AJAX, avar :: AVAR | e) Int
count res = do
  fromMaybe 0 <<< readTotal <$> query res sql
  where
  sql :: SQL
  sql = "SELECT COUNT(*) as total FROM {{path}}"

  readTotal :: JArray -> Maybe Int
  readTotal = I.fromNumber <=< toNumber <=< lookup "total" <=< toObject <=< head

port :: forall e. Resource -> Resource -> SQL ->
        StrMap VarMapValue ->
        Aff (ajax :: AJAX, avar :: AVAR | e) JObject
port res dest sql vars =
  if not (isFile dest)
  then pure empty
  else do
    result <- retry Nothing affjax $ defaultRequest
            { method = POST
            , headers = [RequestHeader "Destination" $ resourcePath dest]
            , url = queryUrl <> resourcePath res <> queryVars
            , content = Just (templated res sql)
            }

    either (throwError <<< error) pure $ content result.response
  where
  swap :: forall a b. Either a b -> Either b a
  swap (Right a) = Left a
  swap (Left a) = Right a

  -- TODO: This should be somewhere better.
  queryVars :: String
  queryVars = maybe "" makeQueryVars <<< uncons $ toList vars

  -- TODO: Need to encode query component.
  pair :: Tuple String VarMapValue -> String
  pair (Tuple a b) = a <> "=" <> b

  makeQueryVars { head = h, tail = t } =
    foldl (\a v -> a <> "&" <> pair v) ("?" <> pair h) t

  content :: String -> Either String JObject
  content input = do
    json <- jsonParser input >>= decodeJson
    swap $ json .? "error"
    pure json

sample' :: forall e. Resource -> Maybe Int -> Maybe Int -> Aff (ajax :: AJAX, avar :: AVAR | e) JArray
sample' res mbOffset mbLimit =
  if not $ isFile res
  then pure []
  else extractJArray <$> (getResponse msg $ retryGet uri)
  where
  msg = "error getting resource sample"
  uri = dataUrl <> resourcePath res <>
        (maybe "" (("?offset=" <>) <<< show) mbOffset) <>
        (maybe "" (("&limit=" <>) <<< show ) mbLimit)

sample :: forall e. Resource -> Int -> Int -> Aff (ajax :: AJAX, avar :: AVAR | e) JArray
sample res offset limit = sample' res (Just offset) (Just limit)

all :: forall e. Resource -> Aff (ajax :: AJAX, avar :: AVAR | e) JArray
all res = sample' res Nothing Nothing

fields :: forall e. Resource -> Aff (ajax :: AJAX, avar :: AVAR | e) (Array String)
fields res = do
  jarr <- sample res 0 100
  case jarr of
    [] -> throwError $ error "empty file"
    _ -> pure $ nub $ concat (getFields <$> jarr)

mkURI :: Resource -> SQL -> String
mkURI res sql =
  queryUrl <> resourcePath res <> "?q=" <> encodeURIComponent (templated res sql)

templated :: Resource -> SQL -> SQL
templated res = replace "{{path}}" ("\"" <> resourcePath res <> "\"")

extractJArray :: String -> JArray
extractJArray =
  (foldl folder []) <<< (jsonParser <$>) <<< (split "\n")
  where
  folder :: JArray -> Either _ Json -> JArray
  folder agg (Right j) = agg ++ [j]
  folder agg _ = agg

getFields :: Json -> Array String
getFields json =
  filter (/= "") $ nub $ getFields' [] json

getFields' :: Array String -> Json -> Array String
getFields' [] json = getFields' [""] json
getFields' acc json =
  if isObject json
  then maybe acc (goObj acc) $ toObject json
  else if isArray json
       then maybe acc (goArr acc) $ toArray json
       else acc

goArr :: Array String -> JArray -> Array String
goArr acc arr =
  concat $ (getFields' ((<> "[*]") <$> acc) <$> arr)

goObj :: Array String -> JObject -> Array String
goObj acc obj = concat $ (goTuple acc <$> (fromList $ toList obj))

goTuple :: Array String -> Tuple String Json -> Array String
goTuple acc (Tuple key json) = getFields' ((\x -> x <> ".\"" <> key <> "\"") <$> acc) json

module Api.Query (query, port, sample, SQL(), fields, count, all, templated) where

import Prelude
import Api.Common (getResponse, succeeded, retryGet)
import Config (queryUrl, dataUrl)
import Control.Apply (lift2)
import Control.Bind ((<=<), (>=>))
import Control.Monad.Aff (Aff())
import Control.Monad.Aff.AVar (AVAR())
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Combinators ((.?))
import Data.Argonaut.Core (JArray(), Json(), JObject(), jsonEmptyObject, isArray, isObject, foldJson, toArray, toObject, toNumber, fromObject)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (concat, nub, filter, head)
import Utils (encodeURIComponent)
import Data.Either (Either(..), either)
import Data.Either.Unsafe (fromRight)
import Data.Foldable (foldl)
import Data.List (uncons, fromList)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.String (split, replace)
import Data.StrMap (StrMap(), keys, toList, empty, lookup)
import Data.Tuple (Tuple(..))
import Model.Notebook.Port (VarMapValue())
import Model.Path (AnyPath())
import Model.Resource (Resource(), resourcePath, isFile, _name)
import Network.HTTP.Affjax (Affjax(), AJAX(), affjax, defaultRequest)
import Network.HTTP.Method (Method(..))
import Network.HTTP.RequestHeader (RequestHeader(..))
import Optic.Core
import qualified Data.Int as I

-- | This is template string where actual path is encoded like {{path}}
type SQL = String

query :: forall e. Resource -> SQL -> Aff (ajax :: AJAX, avar :: AVAR | e) JArray
query res sql =
  if not $ isFile res
  then pure []
  else extractJArray <$> (getResponse msg $ retryGet uri)
  where
  msg = "error in query"
  uri = mkURI res sql

count :: forall e. Resource -> Aff (ajax :: AJAX | e) Int
count res = do
  fromMaybe 0 <<< readTotal <$> query res sql
  where
  sql :: SQL
  sql = "SELECT COUNT(*) as total FROM {{path}}"

  readTotal :: JArray -> Maybe Int
  readTotal = I.fromNumber <=< toNumber <=< lookup "total" <=< toObject <=< head

port :: forall e. Resource -> Resource -> SQL ->
        StrMap VarMapValue ->
        Aff (ajax :: AJAX | e) JObject
port res dest sql vars =
  if not (isFile dest)
  then pure empty
  else do
    result <- retry Nothing affjax $ defaultRequest
            { method = POST
            , headers = [RequestHeader "Destination" $ resourcePath dest]
            , url = queryUrl <> resourcePath res <> queryVars
            , content = Just (templated res sql)
            }

    either (throwError <<< error) pure $ content result.response
  where
  swap :: forall a b. Either a b -> Either b a
  swap (Right a) = Left a
  swap (Left a) = Right a

  -- TODO: This should be somewhere better.
  queryVars :: String
  queryVars = maybe "" makeQueryVars <<< uncons $ toList vars

  -- TODO: Need to encode query component.
  pair :: Tuple String VarMapValue -> String
  pair (Tuple a b) = a <> "=" <> b

  makeQueryVars { head = h, tail = t } =
    foldl (\a v -> a <> "&" <> pair v) ("?" <> pair h) t

  content :: String -> Either String JObject
  content input = do
    json <- jsonParser input >>= decodeJson
    swap $ json .? "error"
    pure json

sample' :: forall e. Resource -> Maybe Int -> Maybe Int -> Aff (ajax :: AJAX, avar :: AVAR | e) JArray
sample' res mbOffset mbLimit =
  if not $ isFile res
  then pure []
  else extractJArray <$> (getResponse msg $ retryGet uri)
  where
  msg = "error getting resource sample"
  uri = dataUrl <> resourcePath res <>
        (maybe "" (("?offset=" <>) <<< show) mbOffset) <>
        (maybe "" (("&limit=" <>) <<< show ) mbLimit)

sample :: forall e. Resource -> Int -> Int -> Aff (ajax :: AJAX | e) JArray
sample res offset limit = sample' res (Just offset) (Just limit)

all :: forall e. Resource -> Aff (ajax :: AJAX | e) JArray
all res = sample' res Nothing Nothing

fields :: forall e. Resource -> Aff (ajax :: AJAX | e) (Array String)
fields res = do
  jarr <- sample res 0 100
  case jarr of
    [] -> throwError $ error "empty file"
    _ -> pure $ nub $ concat (getFields <$> jarr)

mkURI :: Resource -> SQL -> String
mkURI res sql =
  queryUrl <> resourcePath res <> "?q=" <> encodeURIComponent (templated res sql)

templated :: Resource -> SQL -> SQL
templated res = replace "{{path}}" ("\"" <> resourcePath res <> "\"")

extractJArray :: String -> JArray
extractJArray =
  (foldl folder []) <<< (jsonParser <$>) <<< (split "\n")
  where
  folder :: JArray -> Either _ Json -> JArray
  folder agg (Right j) = agg ++ [j]
  folder agg _ = agg

getFields :: Json -> Array String
getFields json =
  filter (/= "") $ nub $ getFields' [] json

getFields' :: Array String -> Json -> Array String
getFields' [] json = getFields' [""] json
getFields' acc json =
  if isObject json
  then maybe acc (goObj acc) $ toObject json
  else if isArray json
       then maybe acc (goArr acc) $ toArray json
       else acc

goArr :: Array String -> JArray -> Array String
goArr acc arr =
  concat $ (getFields' ((<> "[*]") <$> acc) <$> arr)

goObj :: Array String -> JObject -> Array String
goObj acc obj = concat $ (goTuple acc <$> (fromList $ toList obj))

goTuple :: Array String -> Tuple String Json -> Array String
goTuple acc (Tuple key json) = getFields' ((\x -> x <> ".\"" <> key <> "\"") <$> acc) json


Fix formatting in comments

Fix formatting in comments

module Data.Enum
  ( Enum
  , Cardinality(..)
  , cardinality
  , firstEnum
  , fromEnum
  , lastEnum
  , pred
  , runCardinality
  , succ
  , toEnum
  , defaultSucc
  , defaultPred
  , defaultToEnum
  , defaultFromEnum
  , intFromTo
  , intStepFromTo
  , enumFromTo
  , enumFromThenTo
  ) where

  import Data.Maybe
  import Data.Either
  import Data.Tuple
  import Data.Char
  import Data.Maybe.Unsafe
  import Data.Unfoldable

  newtype Cardinality a = Cardinality Number

  runCardinality :: forall a. Cardinality a -> Number
  runCardinality (Cardinality a) = a

  -- | Type class for enumerations. This should not be considered a part of a
  -- | numeric hierarchy, ala Haskell. Rather, this is a type class for small,
  -- | ordered sum types with statically-determined cardinality and the ability
  -- | to easily compute successor and predecessor elements. e.g. `DayOfWeek`, etc.
  -- |
  -- | Laws:
  -- |
  -- | - ```succ firstEnum >>= succ >>= succ ... succ [cardinality - 1 times] == lastEnum```
  -- | - ```pred lastEnum  >>= pred >>= pred ... pred [cardinality - 1 times] == firstEnum```
  -- | - ```e1 `compare` e2 == fromEnum e1 `compare` fromEnum e2```
  -- | - ```forall a > firstEnum: pred a >>= succ == Just a```
  -- | - ```forall a < lastEnum:  succ a >>= pred == Just a```
  -- | - ```pred >=> succ >=> pred = pred```
  -- | - ```succ >=> pred >=> succ = succ```
  -- | - ```toEnum (fromEnum a) = Just a```
  -- | - ```forall a > firstEnum: fromEnum <$> pred a = Just (fromEnum a - 1)```
  -- | - ```forall a < lastEnum:  fromEnum <$> succ a = Just (fromEnum a + 1)```

  class (Ord a) <= Enum a where
    cardinality :: Cardinality a

    firstEnum :: a

    lastEnum :: a

    succ :: a -> Maybe a

    pred :: a -> Maybe a

    toEnum :: Number -> Maybe a

    fromEnum :: a -> Number

  -- | ```defaultSucc toEnum fromEnum = succ```
  defaultSucc :: forall a. (Number -> Maybe a) -> (a -> Number) -> (a -> Maybe a)
  defaultSucc toEnum' fromEnum' a = toEnum' (fromEnum' a + 1)

  -- | ```defaultPred toEnum fromEnum = pred```
  defaultPred :: forall a. (Number -> Maybe a) -> (a -> Number) -> (a -> Maybe a)
  defaultPred toEnum' fromEnum' a = toEnum' (fromEnum' a - 1)

  -- | Runs in `O(n)` where `n` is `fromEnum a`
  -- |
  -- | ```defaultToEnum succ firstEnum = toEnum```
  defaultToEnum :: forall a. (a -> Maybe a) -> a -> (Number -> Maybe a)
  defaultToEnum succ' firstEnum' n | n < 0 = Nothing
  defaultToEnum succ' firstEnum' 0         = Just firstEnum'
  defaultToEnum succ' firstEnum' n         = defaultToEnum succ' firstEnum' (n - 1) >>= succ'

  -- | Runs in `O(n)` where `n` is `fromEnum a`
  -- |
  -- | ```defaultFromEnum pred = fromEnum```
  defaultFromEnum :: forall a. (a -> Maybe a) -> (a -> Number)
  defaultFromEnum pred' e = maybe 0 (\prd -> defaultFromEnum pred' prd + 1) (pred' e)

  -- | Property: ```fromEnum a = a', fromEnum b = b' => forall e', a' <= e' <= b': Exists e: toEnum e' = Just e```
  -- |
  -- | Following from the propery of `intFromTo`, we are sure all elements in `intFromTo (fromEnum a) (fromEnum b)` are `Just`s.
  enumFromTo :: forall a. (Enum a) => a -> a -> [a]
  enumFromTo a b = (toEnum >>> fromJust) <$> intFromTo a' b'
    where a' = fromEnum a
          b' = fromEnum b

  -- | `[a,b..c]`
  -- |
  -- | Correctness for using `fromJust` is the same as for `enumFromTo`.
  enumFromThenTo :: forall a. (Enum a) => a -> a -> a -> [a]
  enumFromThenTo a b c = (toEnum >>> fromJust) <$> intStepFromTo (b' - a') a' c'
    where a' = fromEnum a
          b' = fromEnum b
          c' = fromEnum c

  -- | Property: ```forall e in intFromTo a b: a <= e <= b```
  intFromTo :: Number -> Number -> [Number]
  intFromTo = intStepFromTo 1

  -- | Property: ```forall e in intStepFromTo step a b: a <= e <= b```
  intStepFromTo :: Number -> Number -> Number -> [Number]
  intStepFromTo step from to =
    unfoldr (\e ->
              if e <= to
              then Just $ Tuple e (e + step)  -- Output the value e, set the next state to (e + step)
              else Nothing                    -- End of the collection.
            ) from -- starting value/state.

  -- | Instances

  instance enumChar :: Enum Char where
    cardinality = Cardinality (65535 + 1)

    firstEnum = fromCharCode 0

    lastEnum = fromCharCode 65535

    succ = defaultSucc charToEnum charFromEnum

    pred = defaultPred charToEnum charFromEnum

    toEnum = charToEnum

    fromEnum = charFromEnum

  -- | To avoid a compiler bug - can't pass self-class functions, workaround: need to make a concrete function.
  charToEnum :: Number -> Maybe Char
  charToEnum n | n >= 0 && n <= 65535 = Just $ fromCharCode n
  charToEnum _ = Nothing

  charFromEnum :: Char -> Number
  charFromEnum = toCharCode

  instance enumMaybe :: (Enum a) => Enum (Maybe a) where
    cardinality = maybeCardinality cardinality

    firstEnum = Nothing

    lastEnum = Just $ lastEnum

    succ Nothing = Just $ firstEnum
    succ (Just a) = Just <$> succ a

    pred Nothing = Nothing
    pred (Just a) = Just <$> pred a

    toEnum = maybeToEnum cardinality

    fromEnum Nothing = 0
    fromEnum (Just e) = fromEnum e + 1

  maybeToEnum :: forall a. (Enum a) => Cardinality a -> Number -> Maybe (Maybe a)
  maybeToEnum carda n | n <= runCardinality (maybeCardinality carda) =
    if n == 0
    then Just $ Nothing
    else Just $ toEnum (n - 1)
  maybeToEnum _    _ = Nothing

  maybeCardinality :: forall a. (Enum a) => Cardinality a -> Cardinality (Maybe a)
  maybeCardinality c = Cardinality $ 1 + (runCardinality c)

  instance enumBoolean :: Enum Boolean where
    cardinality = Cardinality 2

    firstEnum = booleanFirstEnum

    lastEnum = true

    succ = booleanSucc

    pred = booleanPred

    toEnum = defaultToEnum booleanSucc booleanFirstEnum

    fromEnum = defaultFromEnum booleanPred

  booleanFirstEnum :: Boolean
  booleanFirstEnum = false

  booleanSucc :: Boolean -> Maybe Boolean
  booleanSucc false = Just true
  booleanSucc _     = Nothing

  booleanPred :: Boolean -> Maybe Boolean
  booleanPred true  = Just false
  booleanPred _     = Nothing

  -- | Until we get `Int`, `floor` and `div` in the Prelude
  foreign import floor "function floor(n){ return Math.floor(n); }" :: Number -> Number

  div a b = floor (a / b)

  instance enumTuple :: (Enum a, Enum b) => Enum (Tuple a b) where
    cardinality = tupleCardinality cardinality cardinality

    firstEnum = Tuple firstEnum firstEnum

    lastEnum = Tuple lastEnum lastEnum

    succ (Tuple a b) = maybe (flip Tuple firstEnum <$> succ a) (Just <<< Tuple a) (succ b)

    pred (Tuple a b) = maybe (flip Tuple firstEnum <$> pred a) (Just <<< Tuple a) (pred b)

    toEnum = tupleToEnum cardinality

    fromEnum = tupleFromEnum cardinality

  -- | All of these are as a workaround for `ScopedTypeVariables`. (not yet supported in Purescript)
  tupleToEnum :: forall a b. (Enum a, Enum b) => Cardinality b -> Number -> Maybe (Tuple a b)
  tupleToEnum cardb n = Tuple <$> (toEnum (n `div` (runCardinality cardb))) <*> (toEnum (n % (runCardinality cardb)))

  tupleFromEnum :: forall a b. (Enum a, Enum b) => Cardinality b -> Tuple a b -> Number
  tupleFromEnum cardb (Tuple a b) = (fromEnum a) * runCardinality cardb + fromEnum b

  tupleCardinality :: forall a b. (Enum a, Enum b) => Cardinality a -> Cardinality b -> Cardinality (Tuple a b)
  tupleCardinality l r = Cardinality $ (runCardinality l) * (runCardinality r)

  instance enumEither :: (Enum a, Enum b) => Enum (Either a b) where
    cardinality = eitherCardinality cardinality cardinality

    firstEnum = Left firstEnum

    lastEnum = Right lastEnum

    succ (Left a) = maybe (Just $ Right firstEnum) (Just <<< Left) (succ a)
    succ (Right b) = maybe (Nothing) (Just <<< Right) (succ b)

    pred (Left a) = maybe (Nothing) (Just <<< Left) (pred a)
    pred (Right b) = maybe (Just $ Left lastEnum) (Just <<< Right) (pred b)

    toEnum = eitherToEnum cardinality cardinality

    fromEnum = eitherFromEnum cardinality

  eitherToEnum :: forall a b. (Enum a, Enum b) => Cardinality a -> Cardinality b -> Number -> Maybe (Either a b)
  eitherToEnum carda cardb n =
        if n >= 0 && n < runCardinality carda
        then Left <$> toEnum n
        else if n >= (runCardinality carda) && n < runCardinality (eitherCardinality carda cardb)
             then Right <$> toEnum (n - runCardinality carda)
             else Nothing

  eitherFromEnum :: forall a b. (Enum a, Enum b) => Cardinality a -> (Either a b -> Number)
  eitherFromEnum carda (Left a) = fromEnum a
  eitherFromEnum carda (Right b) = fromEnum b + runCardinality carda

  eitherCardinality :: forall a b. (Enum a, Enum b) => Cardinality a -> Cardinality b -> Cardinality (Either a b)
  eitherCardinality l r = Cardinality $ (runCardinality l) + (runCardinality r)

module Data.Enum
  ( Enum
  , Cardinality(..)
  , cardinality
  , firstEnum
  , fromEnum
  , lastEnum
  , pred
  , runCardinality
  , succ
  , toEnum
  , defaultSucc
  , defaultPred
  , defaultToEnum
  , defaultFromEnum
  , intFromTo
  , intStepFromTo
  , enumFromTo
  , enumFromThenTo
  ) where

  import Data.Maybe
  import Data.Either
  import Data.Tuple
  import Data.Char
  import Data.Maybe.Unsafe
  import Data.Unfoldable

  newtype Cardinality a = Cardinality Number

  runCardinality :: forall a. Cardinality a -> Number
  runCardinality (Cardinality a) = a

  -- | Type class for enumerations. This should not be considered a part of a
  -- | numeric hierarchy, ala Haskell. Rather, this is a type class for small,
  -- | ordered sum types with statically-determined cardinality and the ability
  -- | to easily compute successor and predecessor elements. e.g. DayOfWeek, etc.
  -- |
  -- | Laws:
  -- |   succ firstEnum >>= succ >>= succ ... succ [cardinality - 1 times] == lastEnum
  -- |   pred lastEnum  >>= pred >>= pred ... pred [cardinality - 1 times] == firstEnum
  -- |
  -- |   e1 `compare` e2 == fromEnum e1 `compare` fromEnum e2
  -- |
  -- |   for all a > firstEnum: pred a >>= succ == Just a
  -- |   for all a < lastEnum:  succ a >>= pred == Just a
  -- |
  -- |   pred >=> succ >=> pred = pred
  -- |   succ >=> pred >=> succ = succ
  -- |
  -- |   toEnum (fromEnum a) = Just a
  -- |
  -- |   for all a > firstEnum: fromEnum <$> pred a = Just (fromEnum a - 1)
  -- |   for all a < lastEnum:  fromEnum <$> succ a = Just (fromEnum a + 1)

  class (Ord a) <= Enum a where
    cardinality :: Cardinality a

    firstEnum :: a

    lastEnum :: a

    succ :: a -> Maybe a

    pred :: a -> Maybe a

    toEnum :: Number -> Maybe a

    fromEnum :: a -> Number

  -- | defaultSucc toEnum fromEnum = succ
  defaultSucc :: forall a. (Number -> Maybe a) -> (a -> Number) -> (a -> Maybe a)
  defaultSucc toEnum' fromEnum' a = toEnum' (fromEnum' a + 1)

  -- | defaultPred toEnum fromEnum = pred
  defaultPred :: forall a. (Number -> Maybe a) -> (a -> Number) -> (a -> Maybe a)
  defaultPred toEnum' fromEnum' a = toEnum' (fromEnum' a - 1)

  -- | Runs in O(n) where n is (fromEnum a)
  -- | defaultToEnum succ firstEnum = toEnum
  defaultToEnum :: forall a. (a -> Maybe a) -> a -> (Number -> Maybe a)
  defaultToEnum succ' firstEnum' n | n < 0 = Nothing
  defaultToEnum succ' firstEnum' 0         = Just firstEnum'
  defaultToEnum succ' firstEnum' n         = defaultToEnum succ' firstEnum' (n - 1) >>= succ'

  -- | Runs in O(n) where n is (fromEnum a)
  -- | defaultFromEnum pred = fromEnum
  defaultFromEnum :: forall a. (a -> Maybe a) -> (a -> Number)
  defaultFromEnum pred' e = maybe 0 (\prd -> defaultFromEnum pred' prd + 1) (pred' e)

  -- Property: fromEnum a = a', fromEnum b = b' => forall e', a' <= e' <= b': Exists e: toEnum e' = Just e
  -- Following from the propery of intFromTo, We are sure all elements in intFromTo (fromEnum a) (fromEnum b) are Justs.
  enumFromTo :: forall a. (Enum a) => a -> a -> [a]
  enumFromTo a b = (toEnum >>> fromJust) <$> intFromTo a' b'
    where a' = fromEnum a
          b' = fromEnum b

  -- [a,b..c]
  -- Correctness for using fromJust is the same as for enumFromTo.
  enumFromThenTo :: forall a. (Enum a) => a -> a -> a -> [a]
  enumFromThenTo a b c = (toEnum >>> fromJust) <$> intStepFromTo (b' - a') a' c'
    where a' = fromEnum a
          b' = fromEnum b
          c' = fromEnum c

  -- Property: forall e in intFromTo a b: a <= e <= b
  -- intFromTo :: Int -> Int -> List Int
  intFromTo :: Number -> Number -> [Number]
  intFromTo = intStepFromTo 1

  -- Property: forall e in intStepFromTo step a b: a <= e <= b
  -- intStepFromTo :: Int -> Int -> Int -> List Int
  intStepFromTo :: Number -> Number -> Number -> [Number]
  intStepFromTo step from to =
    unfoldr (\e ->
              if e <= to
              then Just $ Tuple e (e + step)  -- Output the value e, set the next state to (e + step)
              else Nothing                    -- End of the collection.
            ) from -- starting value/state.

  -- | Instances

  instance enumChar :: Enum Char where
    cardinality = Cardinality (65535 + 1)

    firstEnum = fromCharCode 0

    lastEnum = fromCharCode 65535

    succ = defaultSucc charToEnum charFromEnum

    pred = defaultPred charToEnum charFromEnum

    toEnum = charToEnum

    fromEnum = charFromEnum

  -- To avoid a compiler bug - can't pass self-class functions, workaround: need to make a concrete function.
  charToEnum :: Number -> Maybe Char
  charToEnum n | n >= 0 && n <= 65535 = Just $ fromCharCode n
  charToEnum _ = Nothing

  charFromEnum :: Char -> Number
  charFromEnum = toCharCode

  instance enumMaybe :: (Enum a) => Enum (Maybe a) where
    cardinality = maybeCardinality cardinality

    firstEnum = Nothing

    lastEnum = Just $ lastEnum

    succ Nothing = Just $ firstEnum
    succ (Just a) = Just <$> succ a

    pred Nothing = Nothing
    pred (Just a) = Just <$> pred a

    toEnum = maybeToEnum cardinality

    fromEnum Nothing = 0
    fromEnum (Just e) = fromEnum e + 1

  maybeToEnum :: forall a. (Enum a) => Cardinality a -> Number -> Maybe (Maybe a)
  maybeToEnum carda n | n <= runCardinality (maybeCardinality carda) =
    if n == 0
    then Just $ Nothing
    else Just $ toEnum (n - 1)
  maybeToEnum _    _ = Nothing

  maybeCardinality :: forall a. (Enum a) => Cardinality a -> Cardinality (Maybe a)
  maybeCardinality c = Cardinality $ 1 + (runCardinality c)

  instance enumBoolean :: Enum Boolean where
    cardinality = Cardinality 2

    firstEnum = booleanFirstEnum

    lastEnum = true

    succ = booleanSucc

    pred = booleanPred

    toEnum = defaultToEnum booleanSucc booleanFirstEnum

    fromEnum = defaultFromEnum booleanPred

  booleanFirstEnum :: Boolean
  booleanFirstEnum = false

  booleanSucc :: Boolean -> Maybe Boolean
  booleanSucc false = Just true
  booleanSucc _     = Nothing

  booleanPred :: Boolean -> Maybe Boolean
  booleanPred true  = Just false
  booleanPred _     = Nothing

  -- Until we get Int, floor and div in the prelude
  foreign import floor "function floor(n){ return Math.floor(n); }" :: Number -> Number
  div a b = floor (a / b)

  instance enumTuple :: (Enum a, Enum b) => Enum (Tuple a b) where
    cardinality = tupleCardinality cardinality cardinality

    firstEnum = Tuple firstEnum firstEnum

    lastEnum = Tuple lastEnum lastEnum

    succ (Tuple a b) = maybe (flip Tuple firstEnum <$> succ a) (Just <<< Tuple a) (succ b)

    pred (Tuple a b) = maybe (flip Tuple firstEnum <$> pred a) (Just <<< Tuple a) (pred b)

    toEnum = tupleToEnum cardinality

    fromEnum = tupleFromEnum cardinality

  -- All of these are as a workaround for ScopedTypeVariables. (not yet supported in Purescript)
  tupleToEnum :: forall a b. (Enum a, Enum b) => Cardinality b -> Number -> Maybe (Tuple a b)
  tupleToEnum cardb n = Tuple <$> (toEnum (n `div` (runCardinality cardb))) <*> (toEnum (n % (runCardinality cardb)))

  tupleFromEnum :: forall a b. (Enum a, Enum b) => Cardinality b -> Tuple a b -> Number
  tupleFromEnum cardb (Tuple a b) = (fromEnum a) * runCardinality cardb + fromEnum b

  tupleCardinality :: forall a b. (Enum a, Enum b) => Cardinality a -> Cardinality b -> Cardinality (Tuple a b)
  tupleCardinality l r = Cardinality $ (runCardinality l) * (runCardinality r)

  instance enumEither :: (Enum a, Enum b) => Enum (Either a b) where
    cardinality = eitherCardinality cardinality cardinality

    firstEnum = Left firstEnum

    lastEnum = Right lastEnum

    succ (Left a) = maybe (Just $ Right firstEnum) (Just <<< Left) (succ a)
    succ (Right b) = maybe (Nothing) (Just <<< Right) (succ b)

    pred (Left a) = maybe (Nothing) (Just <<< Left) (pred a)
    pred (Right b) = maybe (Just $ Left lastEnum) (Just <<< Right) (pred b)

    toEnum = eitherToEnum cardinality cardinality

    fromEnum = eitherFromEnum cardinality

  eitherToEnum :: forall a b. (Enum a, Enum b) => Cardinality a -> Cardinality b -> Number -> Maybe (Either a b)
  eitherToEnum carda cardb n =
        if n >= 0 && n < runCardinality carda
        then Left <$> toEnum n
        else if n >= (runCardinality carda) && n < runCardinality (eitherCardinality carda cardb)
             then Right <$> toEnum (n - runCardinality carda)
             else Nothing

  eitherFromEnum :: forall a b. (Enum a, Enum b) => Cardinality a -> (Either a b -> Number)
  eitherFromEnum carda (Left a) = fromEnum a
  eitherFromEnum carda (Right b) = fromEnum b + runCardinality carda

  eitherCardinality :: forall a b. (Enum a, Enum b) => Cardinality a -> Cardinality b -> Cardinality (Either a b)
  eitherCardinality l r = Cardinality $ (runCardinality l) + (runCardinality r)


Fix warnings generated by purescript-0.8.0

-- | A monad for lazily-computed values

module Data.Lazy where

import Prelude (class Show, class Monad, class Bind, class Applicative, class Apply, class Functor, class BooleanAlgebra, class Semigroup, class BoundedOrd, class Bounded, class Ord, class Eq, class Num, class DivisionRing, class ModuloSemiring, class Ring, class Semiring, Unit, unit, show, (++), ($), (<<<), not, (<$>), (<*>), disj, conj, (<>), bottom, top, compare, (==), mod, (/), (-), one, (*), zero, (+))

import Control.Comonad (class Comonad)
import Control.Extend (class Extend)
import Data.Monoid (class Monoid, mempty)
import Control.Lazy as CL

-- | `Lazy a` represents lazily-computed values of type `a`.
-- |
-- | A lazy value is computed at most once - the result is saved
-- | after the first computation, and subsequent attempts to read
-- | the value simply return the saved value.
-- |
-- | `Lazy` values can be created with `defer`, or by using the provided
-- | type class instances.
-- |
-- | `Lazy` values can be evaluated by using the `force` function.
foreign import data Lazy :: * -> *

-- | Defer a computation, creating a `Lazy` value.
foreign import defer :: forall a. (Unit -> a) -> Lazy a

-- | Force evaluation of a `Lazy` value.
foreign import force :: forall a. Lazy a -> a

instance semiringLazy :: (Semiring a) => Semiring (Lazy a) where
  add a b = defer \_ -> force a + force b
  zero = defer \_ -> zero
  mul a b = defer \_ -> force a * force b
  one = defer \_ -> one

instance ringLazy :: (Ring a) => Ring (Lazy a) where
  sub a b = defer \_ -> force a - force b

instance moduloSemiringLazy :: (ModuloSemiring a) => ModuloSemiring (Lazy a) where
  div a b = defer \_ -> force a / force b
  mod a b = defer \_ -> force a `mod` force b

instance divisionRingLazy :: (DivisionRing a) => DivisionRing (Lazy a)

instance numLazy :: (Num a) => Num (Lazy a)

instance eqLazy :: (Eq a) => Eq (Lazy a) where
  eq x y = (force x) == (force y)

instance ordLazy :: (Ord a) => Ord (Lazy a) where
  compare x y = compare (force x) (force y)

instance boundedLazy :: (Bounded a) => Bounded (Lazy a) where
  top = defer \_ -> top
  bottom = defer \_ -> bottom

instance boundedOrdLazy :: (BoundedOrd a) => BoundedOrd (Lazy a)

instance semigroupLazy :: (Semigroup a) => Semigroup (Lazy a) where
  append a b = defer \_ -> force a <> force b

instance monoidLazy :: (Monoid a) => Monoid (Lazy a) where
  mempty = defer \_ -> mempty

instance booleanAlgebraLazy :: (BooleanAlgebra a) => BooleanAlgebra (Lazy a) where
  conj a b = conj <$> a <*> b
  disj a b = disj <$> a <*> b
  not a = not <$> a

instance functorLazy :: Functor Lazy where
  map f l = defer \_ -> f (force l)

instance applyLazy :: Apply Lazy where
  apply f x = defer \_ -> force f $ force x

instance applicativeLazy :: Applicative Lazy where
  pure a = defer \_ -> a

instance bindLazy :: Bind Lazy where
  bind l f = defer \_ -> force <<< f <<< force $ l

instance monadLazy :: Monad Lazy

instance extendLazy :: Extend Lazy where
  extend f x = defer \_ -> f x

instance comonadLazy :: Comonad Lazy where
  extract = force

instance showLazy :: (Show a) => Show (Lazy a) where
  show x = "Lazy " ++ show (force x)

instance lazyLazy :: CL.Lazy (Lazy a) where
  defer f = defer \_ -> force (f unit)

-- | A monad for lazily-computed values

module Data.Lazy where

import Prelude

import Control.Comonad (Comonad)
import Control.Extend (Extend)
import Data.Monoid (Monoid, mempty)
import qualified Control.Lazy as CL

-- | `Lazy a` represents lazily-computed values of type `a`.
-- |
-- | A lazy value is computed at most once - the result is saved
-- | after the first computation, and subsequent attempts to read
-- | the value simply return the saved value.
-- |
-- | `Lazy` values can be created with `defer`, or by using the provided
-- | type class instances.
-- |
-- | `Lazy` values can be evaluated by using the `force` function.
foreign import data Lazy :: * -> *

-- | Defer a computation, creating a `Lazy` value.
foreign import defer :: forall a. (Unit -> a) -> Lazy a

-- | Force evaluation of a `Lazy` value.
foreign import force :: forall a. Lazy a -> a

instance semiringLazy :: (Semiring a) => Semiring (Lazy a) where
  add a b = defer \_ -> force a + force b
  zero = defer \_ -> zero
  mul a b = defer \_ -> force a * force b
  one = defer \_ -> one

instance ringLazy :: (Ring a) => Ring (Lazy a) where
  sub a b = defer \_ -> force a - force b

instance moduloSemiringLazy :: (ModuloSemiring a) => ModuloSemiring (Lazy a) where
  div a b = defer \_ -> force a / force b
  mod a b = defer \_ -> force a `mod` force b

instance divisionRingLazy :: (DivisionRing a) => DivisionRing (Lazy a)

instance numLazy :: (Num a) => Num (Lazy a)

instance eqLazy :: (Eq a) => Eq (Lazy a) where
  eq x y = (force x) == (force y)

instance ordLazy :: (Ord a) => Ord (Lazy a) where
  compare x y = compare (force x) (force y)

instance boundedLazy :: (Bounded a) => Bounded (Lazy a) where
  top = defer \_ -> top
  bottom = defer \_ -> bottom

instance boundedOrdLazy :: (BoundedOrd a) => BoundedOrd (Lazy a)

instance semigroupLazy :: (Semigroup a) => Semigroup (Lazy a) where
  append a b = defer \_ -> force a <> force b

instance monoidLazy :: (Monoid a) => Monoid (Lazy a) where
  mempty = defer \_ -> mempty

instance booleanAlgebraLazy :: (BooleanAlgebra a) => BooleanAlgebra (Lazy a) where
  conj a b = conj <$> a <*> b
  disj a b = disj <$> a <*> b
  not a = not <$> a

instance functorLazy :: Functor Lazy where
  map f l = defer \_ -> f (force l)

instance applyLazy :: Apply Lazy where
  apply f x = defer \_ -> force f $ force x

instance applicativeLazy :: Applicative Lazy where
  pure a = defer \_ -> a

instance bindLazy :: Bind Lazy where
  bind l f = defer \_ -> force <<< f <<< force $ l

instance monadLazy :: Monad Lazy

instance extendLazy :: Extend Lazy where
  extend f x = defer \_ -> f x

instance comonadLazy :: Comonad Lazy where
  extract = force

instance showLazy :: (Show a) => Show (Lazy a) where
  show x = "Lazy " ++ show (force x)

instance lazyLazy :: CL.Lazy (Lazy a) where
  defer f = defer \_ -> force (f unit)


removing redundant import

removing redundant import

{-
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.GlobalMenu.Component
  ( component
  , Query(..)
  , MenuOpen(..)
  , Message(..)
  , AuthenticateOrPresentHelp(..)
  , State
  , module SlamData.GlobalMenu.Bus
  ) where

import SlamData.Prelude

import Control.UI.Browser as Browser
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff as Eff
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Exception as Exception

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource as ES
import Halogen.HTML.Events as HE

import OIDC.Crypt as Crypt

import Quasar.Advanced.Types (ProviderR)

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.Workspace.Eval.Card as EvalCard
import SlamData.GlobalError (GlobalError)
import SlamData.GlobalError as GlobalError
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.Monad (Slam)
import SlamData.Quasar as Api
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Auth.Authentication (AuthenticationError, toNotificationOptions)
import SlamData.Quasar.Auth.Store as AuthStore
import SlamData.Render.Icon as I
import SlamData.Wiring as Wiring
import SlamData.Workspace.Eval.Persistence as Persistence

import Utils.DOM as DOM

data AuthenticateOrPresentHelp

data Query a
  = Authenticate (Maybe ProviderR) a
  | DismissSubmenu a
  | HandleGlobalError GlobalError a
  | Init a
  | PresentAttribution a
  | SignOut a
  | StopPropagation DOM.Event (Query a)
  | ToggleMenu MenuOpen a

data MenuOpen
 = SignInMenu
 | HelpMenu

derive instance eqMenuOpen ∷ Eq MenuOpen

type State =
  { email ∷ Maybe String
  , loggedIn ∷ Boolean
  , menuOpen ∷ Maybe MenuOpen
  , providers ∷ Maybe (Array ProviderR)
  }

data Message =
  PresentAttributionsDialog

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Message Slam

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.lifecycleComponent
    { initialState: \_ →
      { email: Nothing
      , loggedIn: false
      , menuOpen: Nothing
      , providers: Nothing
      }
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  let
    stopProp action e =
      Just $ StopPropagation (DOM.toEvent e) $ H.action action

    container ∷ HH.ClassName
    container = HH.ClassName "menu-container"

    active ∷ HH.ClassName
    active = HH.ClassName "active"

    submenuItem =
      HP.classes $ HH.ClassName <$> [ "menu-item", "submenu-item" ]

    submenu = HH.ul [ HP.class_ $ HH.ClassName "submenu" ]

    -- wraps stiff in `li > button`
    sitem provider =
      HH.li [ submenuItem ]
        [ HH.button
            [ HP.classes $ HH.ClassName <$> [ "menu-item-button", "submenu-item-button" ]
            , HE.onClick $ stopProp $ Authenticate $ pure provider
            ]
            [ HH.text $ "Sign in with " <> provider.displayName ]
        ]

    -- wraps stuff in `li > a`
    hitem attrs children =
      HH.li [ submenuItem ]
        [ HH.a
          ([ HP.classes $ HH.ClassName <$> [ "menu-item-link", "submenu-item-link" ] ] <> attrs)
          children
        ]

    userInfo =
      flip foldMap state.email \e →
        [ HH.div [ HP.class_ $ HH.ClassName "user-info" ] [ HH.text e ] ]

    signInMenu =
      case state.providers, state.email of
        Just ps, _ →
          [ HH.div
            [ HP.classes $ [ container, HH.ClassName "sign-in-menu-container" ] ] $
            [ HH.button
                [ HP.classes $ [ HH.ClassName "sign-in-menu-button " ]
                  <> if state.menuOpen == Just SignInMenu then [ active ] else []
                , HE.onClick $ stopProp $ ToggleMenu SignInMenu
                ]
                [ I.lockSm, HH.text "Sign in" ]
            ] <>
              if state.menuOpen == Just SignInMenu then
                [ submenu $ sitem <$> ps ]
              else
                []
          ]
        _, Just _ →
          [ HH.div
              [ HP.classes [ container, HH.ClassName "sign-in-menu-container" ] ] $
              [ HH.button
                  [ HP.class_ $ HH.ClassName "sign-in-menu-button "
                  , HE.onClick $ stopProp $ SignOut -- Authenticate Nothing
                  ]
                  [ I.unlockSm, HH.text "Sign out" ]
              ]
          ]
        _, _ →
          []

    helpMenu =
      HH.div
        [ HP.classes $ [ container, HH.ClassName "help-menu-container" ] ] $
        [ HH.button
            [ HP.classes $ [ HH.ClassName "help-menu-button" ]
                <> if state.menuOpen == Just HelpMenu then [ active ] else []
            , HE.onClick $ stopProp $ ToggleMenu HelpMenu
            ]
            [ I.helpSm, HH.text "Help" ]
        ] <>
          if state.menuOpen == Just HelpMenu then
            [ submenu
              [ hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/users-guide.html" ]
                  [ HH.text "User guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/administration-guide.html" ]
                  [ HH.text "Administrator guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/developers-guide.html" ]
                  [ HH.text "Developer guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/helpful-tips.html" ]
                  [ HH.text "Helpful tips" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/sql-squared-reference.html" ]
                  [ HH.text "SQL² reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/slamdown-reference.html" ]
                  [ HH.text "SlamDown reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/troubleshooting-faq.html" ]
                  [ HH.text "Troubleshooting FAQ" ]
              , HH.li [ submenuItem ]
                  [ HH.button
                      [ HP.classes $ HH.ClassName <$>
                          [ "menu-item-button", "submenu-item-button" ]
                      , HE.onClick $ stopProp $ PresentAttribution
                      ]
                      [ HH.text $ "Attribution" ]
                  ]
              ]
            ]
          else
            []

  in
    HH.div
      [ HP.classes $ [ HH.ClassName "sd-global-menu" ] ] $
      userInfo <> signInMenu <> [ helpMenu ]

eval ∷ Query ~> DSL
eval = case _ of
  Authenticate providerR next → do
    authenticate providerR
    pure next
  DismissSubmenu next → do
    H.modify _{ menuOpen = Nothing }
    pure next
  HandleGlobalError error next →
    case error of
      GlobalError.Unauthorized _ → update $> next
      _ → pure next
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (flip HandleGlobalError ES.Listening) bus.globalError
    update
    pure next
  PresentAttribution next → do
    H.modify _{ menuOpen = Nothing }
    H.raise PresentAttributionsDialog
    pure next
  SignOut next → do
    H.modify _{ email = Nothing }
    eval $ Authenticate Nothing next
  StopPropagation e q → do
    H.liftEff $ DEE.stopPropagation e
    eval q
  ToggleMenu which next → do
    menuOpen ← H.gets _.menuOpen
    let
      m = case menuOpen, which of
        Just HelpMenu, HelpMenu → Nothing
        Just SignInMenu, SignInMenu → Nothing
        _, _ → Just which
    H.modify _{ menuOpen = m }
    pure next

update ∷ DSL Unit
update = do
  maybeIdToken ← H.lift Auth.getIdToken
  case maybeIdToken of
    Just idToken → do
      either
        (const retrieveProvidersAndUpdateMenu)
        putEmailToMenu
        (Eff.runPure $ Exception.try $ Crypt.readPayload idToken)
    Nothing →
      retrieveProvidersAndUpdateMenu
  where
  putEmailToMenu ∷ Crypt.Payload → DSL Unit
  putEmailToMenu payload =
    H.modify _{ loggedIn = true, email = map unwrap $ Crypt.pluckEmail payload }

  retrieveProvidersAndUpdateMenu ∷ DSL Unit
  retrieveProvidersAndUpdateMenu = void do
    eProviders ← Api.retrieveAuthProviders
    case eProviders of
      Right p → H.modify _{ providers = p }
      _ → pure unit

authenticate ∷ Maybe ProviderR → DSL Unit
authenticate = maybe logOut logIn
  where
  keySuffix ∷ String
  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  logOut ∷ DSL Unit
  logOut = do
    AuthStore.removeIdToken keySuffix
    AuthStore.removeUnhashedNonce keySuffix
    AuthStore.removeProvider keySuffix
    update

  logIn ∷ ProviderR → DSL Unit
  logIn providerR = do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff AVar.makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ AVar.takeVar idToken)

  signInSuccess ∷ DSL Unit
  signInSuccess = do
    wiring ← Wiring.expose
    update
    traverse_ (lift ∘ Persistence.queueEvalImmediate ∘ EvalCard.toAll)
      =<< (H.liftEff $ Ref.readRef wiring.auth.retryEval)
    whenM
      (H.liftEff $ Ref.readRef wiring.auth.retrySave)
      (void $ lift $ Persistence.saveWorkspace)
    H.liftAff $ Bus.write SignInSuccess wiring.auth.signIn

  signInFailure ∷ AuthenticationError → DSL Unit
  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      maybe (pure unit) (flip Bus.write bus.notify) (toNotificationOptions error)
      Bus.write SignInFailure auth.signIn

presentHelp ∷ String → DSL Unit
presentHelp = H.liftEff ∘ Browser.newTab

{-
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.GlobalMenu.Component
  ( component
  , Query(..)
  , MenuOpen(..)
  , Message(..)
  , AuthenticateOrPresentHelp(..)
  , State
  , module SlamData.GlobalMenu.Bus
  ) where

import SlamData.Prelude

import DOM.Event.Event as DEE

import Control.UI.Browser as Browser
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff as Eff
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Exception as Exception

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource as ES
import Halogen.HTML.Events as HE

import OIDC.Crypt as Crypt

import Quasar.Advanced.Types (ProviderR)

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.Workspace.Eval.Card as EvalCard
import SlamData.GlobalError (GlobalError)
import SlamData.GlobalError as GlobalError
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.Monad (Slam)
import SlamData.Quasar as Api
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Auth.Authentication (AuthenticationError, toNotificationOptions)
import SlamData.Quasar.Auth.Store as AuthStore
import SlamData.Render.Icon as I
import SlamData.Wiring as Wiring
import SlamData.Workspace.Eval.Persistence as Persistence

import Utils.DOM as DOM

data AuthenticateOrPresentHelp

data Query a
  = Authenticate (Maybe ProviderR) a
  | DismissSubmenu a
  | HandleGlobalError GlobalError a
  | Init a
  | PresentAttribution a
  | SignOut a
  | StopPropagation DOM.Event (Query a)
  | ToggleMenu MenuOpen a

data MenuOpen
 = SignInMenu
 | HelpMenu

derive instance eqMenuOpen ∷ Eq MenuOpen

type State =
  { email ∷ Maybe String
  , loggedIn ∷ Boolean
  , menuOpen ∷ Maybe MenuOpen
  , providers ∷ Maybe (Array ProviderR)
  }

data Message =
  PresentAttributionsDialog

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Message Slam

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.lifecycleComponent
    { initialState: \_ →
      { email: Nothing
      , loggedIn: false
      , menuOpen: Nothing
      , providers: Nothing
      }
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  let
    stopProp action e =
      Just $ StopPropagation (DOM.toEvent e) $ H.action action

    container ∷ HH.ClassName
    container = HH.ClassName "menu-container"

    active ∷ HH.ClassName
    active = HH.ClassName "active"

    submenuItem =
      HP.classes $ HH.ClassName <$> [ "menu-item", "submenu-item" ]

    submenu = HH.ul [ HP.class_ $ HH.ClassName "submenu" ]

    -- wraps stiff in `li > button`
    sitem provider =
      HH.li [ submenuItem ]
        [ HH.button
            [ HP.classes $ HH.ClassName <$> [ "menu-item-button", "submenu-item-button" ]
            , HE.onClick $ stopProp $ Authenticate $ pure provider
            ]
            [ HH.text $ "Sign in with " <> provider.displayName ]
        ]

    -- wraps stuff in `li > a`
    hitem attrs children =
      HH.li [ submenuItem ]
        [ HH.a
          ([ HP.classes $ HH.ClassName <$> [ "menu-item-link", "submenu-item-link" ] ] <> attrs)
          children
        ]

    userInfo =
      flip foldMap state.email \e →
        [ HH.div [ HP.class_ $ HH.ClassName "user-info" ] [ HH.text e ] ]

    signInMenu =
      case state.providers, state.email of
        Just ps, _ →
          [ HH.div
            [ HP.classes $ [ container, HH.ClassName "sign-in-menu-container" ] ] $
            [ HH.button
                [ HP.classes $ [ HH.ClassName "sign-in-menu-button " ]
                  <> if state.menuOpen == Just SignInMenu then [ active ] else []
                , HE.onClick $ stopProp $ ToggleMenu SignInMenu
                ]
                [ I.lockSm, HH.text "Sign in" ]
            ] <>
              if state.menuOpen == Just SignInMenu then
                [ submenu $ sitem <$> ps ]
              else
                []
          ]
        _, Just _ →
          [ HH.div
              [ HP.classes [ container, HH.ClassName "sign-in-menu-container" ] ] $
              [ HH.button
                  [ HP.class_ $ HH.ClassName "sign-in-menu-button "
                  , HE.onClick $ stopProp $ SignOut -- Authenticate Nothing
                  ]
                  [ I.unlockSm, HH.text "Sign out" ]
              ]
          ]
        _, _ →
          []

    helpMenu =
      HH.div
        [ HP.classes $ [ container, HH.ClassName "help-menu-container" ] ] $
        [ HH.button
            [ HP.classes $ [ HH.ClassName "help-menu-button" ]
                <> if state.menuOpen == Just HelpMenu then [ active ] else []
            , HE.onClick $ stopProp $ ToggleMenu HelpMenu
            ]
            [ I.helpSm, HH.text "Help" ]
        ] <>
          if state.menuOpen == Just HelpMenu then
            [ submenu
              [ hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/users-guide.html" ]
                  [ HH.text "User guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/administration-guide.html" ]
                  [ HH.text "Administrator guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/developers-guide.html" ]
                  [ HH.text "Developer guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/helpful-tips.html" ]
                  [ HH.text "Helpful tips" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/sql-squared-reference.html" ]
                  [ HH.text "SQL² reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/slamdown-reference.html" ]
                  [ HH.text "SlamDown reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/troubleshooting-faq.html" ]
                  [ HH.text "Troubleshooting FAQ" ]
              , HH.li [ submenuItem ]
                  [ HH.button
                      [ HP.classes $ HH.ClassName <$>
                          [ "menu-item-button", "submenu-item-button" ]
                      , HE.onClick $ stopProp $ PresentAttribution
                      ]
                      [ HH.text $ "Attribution" ]
                  ]
              ]
            ]
          else
            []

  in
    HH.div
      [ HP.classes $ [ HH.ClassName "sd-global-menu" ] ] $
      userInfo <> signInMenu <> [ helpMenu ]

eval ∷ Query ~> DSL
eval = case _ of
  Authenticate providerR next → do
    authenticate providerR
    pure next
  DismissSubmenu next → do
    H.modify _{ menuOpen = Nothing }
    pure next
  HandleGlobalError error next →
    case error of
      GlobalError.Unauthorized _ → update $> next
      _ → pure next
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (flip HandleGlobalError ES.Listening) bus.globalError
    update
    pure next
  PresentAttribution next → do
    H.modify _{ menuOpen = Nothing }
    H.raise PresentAttributionsDialog
    pure next
  SignOut next → do
    H.modify _{ email = Nothing }
    eval $ Authenticate Nothing next
  StopPropagation e q → do
    H.liftEff $ DEE.stopPropagation e
    eval q
  ToggleMenu which next → do
    menuOpen ← H.gets _.menuOpen
    let
      m = case menuOpen, which of
        Just HelpMenu, HelpMenu → Nothing
        Just SignInMenu, SignInMenu → Nothing
        _, _ → Just which
    H.modify _{ menuOpen = m }
    pure next

update ∷ DSL Unit
update = do
  maybeIdToken ← H.lift Auth.getIdToken
  case maybeIdToken of
    Just idToken → do
      either
        (const retrieveProvidersAndUpdateMenu)
        putEmailToMenu
        (Eff.runPure $ Exception.try $ Crypt.readPayload idToken)
    Nothing →
      retrieveProvidersAndUpdateMenu
  where
  putEmailToMenu ∷ Crypt.Payload → DSL Unit
  putEmailToMenu payload =
    H.modify _{ loggedIn = true, email = map unwrap $ Crypt.pluckEmail payload }

  retrieveProvidersAndUpdateMenu ∷ DSL Unit
  retrieveProvidersAndUpdateMenu = void do
    eProviders ← Api.retrieveAuthProviders
    case eProviders of
      Right p → H.modify _{ providers = p }
      _ → pure unit

authenticate ∷ Maybe ProviderR → DSL Unit
authenticate = maybe logOut logIn
  where
  keySuffix ∷ String
  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  logOut ∷ DSL Unit
  logOut = do
    AuthStore.removeIdToken keySuffix
    AuthStore.removeUnhashedNonce keySuffix
    AuthStore.removeProvider keySuffix
    update

  logIn ∷ ProviderR → DSL Unit
  logIn providerR = do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff AVar.makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ AVar.takeVar idToken)

  signInSuccess ∷ DSL Unit
  signInSuccess = do
    wiring ← Wiring.expose
    update
    traverse_ (lift ∘ Persistence.queueEvalImmediate ∘ EvalCard.toAll)
      =<< (H.liftEff $ Ref.readRef wiring.auth.retryEval)
    whenM
      (H.liftEff $ Ref.readRef wiring.auth.retrySave)
      (void $ lift $ Persistence.saveWorkspace)
    H.liftAff $ Bus.write SignInSuccess wiring.auth.signIn

  signInFailure ∷ AuthenticationError → DSL Unit
  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      maybe (pure unit) (flip Bus.write bus.notify) (toNotificationOptions error)
      Bus.write SignInFailure auth.signIn

presentHelp ∷ String → DSL Unit
presentHelp = H.liftEff ∘ Browser.newTab


Add query for attaching event handler to BD

module Genetics.Browser.UI.Biodalliance
       where

import Prelude
import Genetics.Browser.Biodalliance as Biodalliance
import Genetics.Browser.UI.Events.Biodalliance as BDEvents
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Control.Monad.Aff (Aff, forkAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import Control.Monad.Rec.Class (forever)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (_Number, _String)
import Data.Argonaut.Core (JObject)
import Data.Either (Either(..))
import Data.Foreign (F)
import Data.Foreign.Class (decode, encode)
import Data.Lens (re, (^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..))
import Data.Variant (Variant, default, inj, on)
import Genetics.Browser.Events (Event(..), EventLocation, EventRange, Location, Range, _eventLocation, _eventRange, handleLocation, handleRange)
import Genetics.Browser.Types (BD, Biodalliance)
import Genetics.Browser.Units (Bp, Chr, MBp(MBp), _Bp, _Chr, bp, mbp)
import Global.Unsafe (unsafeStringify)
import Unsafe.Coerce (unsafeCoerce)

type State = { bd :: Maybe Biodalliance
             }

data Query a
  = Scroll Bp a
  | Jump Chr Bp Bp a
  | Initialize (forall eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance) a
  | AttachHandler (Biodalliance -> Aff (bd :: BD, console :: CONSOLE, avar :: AVAR ) Unit) a
  -- | AttachHandler (forall eff. Biodalliance -> Aff (bd :: BD, console :: CONSOLE, avar :: AVAR | eff) Unit) a
  | InitializeCallback (H.SubscribeStatus -> a)
  | EventFromBD JObject (H.SubscribeStatus -> a)
  -- | RecvEvent (Event r) a

data Message
  = Initialized

type Effects eff = (avar :: AVAR, bd :: BD, console :: CONSOLE | eff)

data Slot = Slot
derive instance eqBDSlot :: Eq Slot
derive instance ordBDSlot :: Ord Slot

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

  initialState :: State
  initialState = { bd: Nothing }

  render :: State -> H.ComponentHTML Query
  render = const $ HH.div [ HP.ref (H.RefLabel "bd")
                          , HP.id_ "bdDiv"
                          ] []

  eval :: Query ~> H.ComponentDSL State Query Message (Aff (Effects eff))
  eval = case _ of
    Initialize mkBd next -> do
      H.getHTMLElementRef (H.RefLabel "bd") >>= case _ of
        Nothing -> pure unit
        Just el -> do
          bd <- liftEff $ mkBd el

          H.subscribe $ H.eventSource_ (Biodalliance.onInit bd) (H.request InitializeCallback)

          H.subscribe $ H.eventSource (Biodalliance.addFeatureListener bd)
            $ Just <<< H.request <<< EventFromBD

          H.modify (_ { bd = Just bd })
      pure next

    AttachHandler h next -> do
      mbd <- H.gets _.bd
      case mbd of
        Nothing -> pure unit
        Just bd -> do
          _ <- liftAff $ forkAff $ unsafeCoerce $ h bd
          pure unit
          -- _ <- forkAff h bd
      pure next

    Scroll n next -> do
      mbd <- H.gets _.bd
      case mbd of
        Nothing -> pure next
        Just bd -> do
          liftEff $ Biodalliance.scrollView bd n
          pure next

    Jump chr xl xr next -> do
      mbd <- H.gets _.bd
      case mbd of
        Nothing -> pure next
        Just bd -> do
          liftEff $ Biodalliance.setLocation bd chr xl xr
          pure next

    InitializeCallback reply -> do
      H.raise $ Initialized
      pure $ reply H.Listening

    EventFromBD ft reply -> do

      -- _ <- createEvent SendEvent ft
      -- let obj = do
      --       chr <- ft ^? ix "chr" <<< _String <<< re _Chr
      --       minPos <- ft ^? ix "min" <<< _Number <<< re _Bp
      --       maxPos <- ft ^? ix "max" <<< _Number <<< re _Bp
      --       pure $ { chr, minPos, maxPos }

      -- case obj of
      --   Nothing -> liftEff $ log "Error when parsing chr, min, max of BD event"
      --   Just o  -> do
      --     liftEff $ log "sending event from BD:"
      --     liftEff $ log $ unsafeStringify o
      --     H.raise $ SendEvent $ Event $ inj _eventRange o

      pure $ reply H.Listening

    -- RecvEvent (Event v) next -> do
    --   mbd <- H.gets _.bd

    --   case mbd of
    --     Nothing -> pure next
    --     Just bd -> do

    --       _ <- handleEvent bd v
          -- (default (pure unit)
          --   # handleLocation (\loc -> do
          --     let minPos = loc.pos - bp (MBp 1.5)
          --         maxPos = loc.pos + bp (MBp 1.5)
          --     liftEff $ Biodalliance.setLocation bd loc.chr (mbp minPos) (mbp maxPos))
          --   # handleRange (\ran -> do
          --     liftEff $ Biodalliance.setLocation bd ran.chr ran.minPos ran.maxPos)
          --   ) v

          -- pure next

module Genetics.Browser.UI.Biodalliance
       where

import Prelude
import Genetics.Browser.Biodalliance as Biodalliance
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (_Number, _String)
import Data.Argonaut.Core (JObject)
import Data.Either (Either(..))
import Data.Foreign (F)
import Data.Foreign.Class (decode, encode)
import Data.Lens (re, (^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..))
import Data.Variant (Variant, default, inj, on)
import Genetics.Browser.Events (Event(..), EventLocation, EventRange, Location, Range, _eventLocation, _eventRange, handleLocation, handleRange)
import Genetics.Browser.Types (BD, Biodalliance)
import Genetics.Browser.Units (Bp, Chr, MBp(MBp), _Bp, _Chr, bp, mbp)
import Global.Unsafe (unsafeStringify)

type State = { bd :: Maybe Biodalliance
             }

data Query a
  = Scroll Bp a
  | Jump Chr Bp Bp a
  | Initialize (forall eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance) a
  | InitializeCallback (H.SubscribeStatus -> a)
  | EventFromBD JObject (H.SubscribeStatus -> a)
  -- | RecvEvent (Event r) a

data Message
  = Initialized

type Effects eff = (avar :: AVAR, bd :: BD, console :: CONSOLE | eff)

data Slot = Slot
derive instance eqBDSlot :: Eq Slot
derive instance ordBDSlot :: Ord Slot

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

  initialState :: State
  initialState = { bd: Nothing }

  render :: State -> H.ComponentHTML (Query (HandledEvents rq))
  render = const $ HH.div [ HP.ref (H.RefLabel "bd")
                          , HP.id_ "bdDiv"
                          ] []

  eval :: (Query (HandledEvents rq)) ~> H.ComponentDSL State (Query (HandledEvents rq)) (Message (PossibleEvents rm)) (Aff (Effects eff))
  eval = case _ of
    Initialize mkBd next -> do
      H.getHTMLElementRef (H.RefLabel "bd") >>= case _ of
        Nothing -> pure unit
        Just el -> do
          bd <- liftEff $ mkBd el

          H.subscribe $ H.eventSource_ (Biodalliance.onInit bd) (H.request InitializeCallback)

          H.subscribe $ H.eventSource (Biodalliance.addFeatureListener bd)
            $ Just <<< H.request <<< EventFromBD

          H.modify (_ { bd = Just bd })
      pure next

    Scroll n next -> do
      mbd <- H.gets _.bd
      case mbd of
        Nothing -> pure next
        Just bd -> do
          liftEff $ Biodalliance.scrollView bd n
          pure next

    Jump chr xl xr next -> do
      mbd <- H.gets _.bd
      case mbd of
        Nothing -> pure next
        Just bd -> do
          liftEff $ Biodalliance.setLocation bd chr xl xr
          pure next

    InitializeCallback reply -> do
      H.raise $ Initialized
      pure $ reply H.Listening

    EventFromBD ft reply -> do

      -- _ <- createEvent SendEvent ft
      -- let obj = do
      --       chr <- ft ^? ix "chr" <<< _String <<< re _Chr
      --       minPos <- ft ^? ix "min" <<< _Number <<< re _Bp
      --       maxPos <- ft ^? ix "max" <<< _Number <<< re _Bp
      --       pure $ { chr, minPos, maxPos }

      -- case obj of
      --   Nothing -> liftEff $ log "Error when parsing chr, min, max of BD event"
      --   Just o  -> do
      --     liftEff $ log "sending event from BD:"
      --     liftEff $ log $ unsafeStringify o
      --     H.raise $ SendEvent $ Event $ inj _eventRange o

      pure $ reply H.Listening

    -- RecvEvent (Event v) next -> do
    --   mbd <- H.gets _.bd

    --   case mbd of
    --     Nothing -> pure next
    --     Just bd -> do

    --       _ <- handleEvent bd v
          -- (default (pure unit)
          --   # handleLocation (\loc -> do
          --     let minPos = loc.pos - bp (MBp 1.5)
          --         maxPos = loc.pos + bp (MBp 1.5)
          --     liftEff $ Biodalliance.setLocation bd loc.chr (mbp minPos) (mbp maxPos))
          --   # handleRange (\ran -> do
          --     liftEff $ Biodalliance.setLocation bd ran.chr ran.minPos ran.maxPos)
          --   ) v

          -- pure next