[CSL-1188] Fix build

[CSL-1188] Fix build

module Daedalus.Types
       ( module CT
       , module C
       , module E
       , module BP
       , module DT
       , _address
       , _ccoin
       , _passPhrase
       , mkCCoin
       , mkCId
       , mkCAccountMeta
       , mkCAccountInit
       , mkCAccountId
       , mkCTxMeta
       , mkCTxId
       , mkCProfile
       , _ctxIdValue
       , mkBackupPhrase
       , mkCWalletRedeem
       , mkCPaperVendWalletRedeem
       , mkCInitialized
       , mkCPassPhrase
       , emptyCPassPhrase
       , getProfileLocale
       , walletAddressToUrl
       , mkCWalletInit
       , mkCWalletAssurance
       ) where

import Prelude

import Pos.Wallet.Web.ClientTypes (CId (..), CHash (..), CPassPhrase (..), CCoin (..), Wal (..), CAccountId (..), CWalletMeta (..))

import Pos.Wallet.Web.ClientTypes as CT
import Pos.Core.Types as C
import Pos.Wallet.Web.Error.Types as E
import Pos.Util.BackupPhrase (BackupPhrase (..))
import Pos.Util.BackupPhrase as BP

import Control.Monad.Eff.Exception (error, Error)
import Data.Either (either, Either (..))
import Data.Maybe (Maybe (..))
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Argonaut.Core (fromString)
import Data.Generic (gShow)
import Data.Array.Partial (last)
import Data.Array (length, filter)
import Partial.Unsafe (unsafePartial)
import Data.String (split, null, trim, joinWith, Pattern (..))

import Daedalus.Crypto (isValidMnemonic, blake2b, bytesToB16)
import Data.Types (mkTime)
import Data.Types as DT
import Data.Int53 (fromInt, toString)

space :: Pattern
space = Pattern " "

dot :: Pattern
dot = Pattern "."

backupMnemonicLen :: Int
backupMnemonicLen = 12

paperVendMnemonicLen :: Int
paperVendMnemonicLen = 9

-- NOTE: if you will be bumping bip39 to >=2.2.0 be aware of https://issues.serokell.io/issue/VD-95 . In this case you will have to modify how we validate paperVendMnemonics.
mkBackupPhrase :: Int -> String -> Either Error BackupPhrase
mkBackupPhrase len mnemonic = mkBackupPhraseIgnoreChecksum len mnemonic >>= const do
    if not $ isValidMnemonic mnemonicCleaned
        then Left $ error "Invalid mnemonic: checksum missmatch"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    mnemonicCleaned = cleanMnemonic mnemonic

cleanMnemonic :: String -> String
cleanMnemonic = joinWith " " <<< filter (not <<< null) <<< split space <<< trim

mkBackupPhraseIgnoreChecksum :: Int -> String -> Either Error BackupPhrase
mkBackupPhraseIgnoreChecksum len mnemonic =
    if not $ hasExactlyNwords len mnemonicCleaned
        then Left $ error $ "Invalid mnemonic: mnemonic should have exactly " <> show len <> " words"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    hasExactlyNwords len' = (==) len' <<< length <<< split space
    mnemonicCleaned = cleanMnemonic mnemonic

-- TODO: it would be useful to extend purescript-bridge
-- and generate lenses
walletAddressToUrl :: CAccountId -> String
walletAddressToUrl (CAccountId r) = r

_hash :: CHash -> String
_hash (CHash h) = h

_address :: forall a. CId a -> String
_address (CId a) = _hash a

_passPhrase :: CPassPhrase -> String
_passPhrase (CPassPhrase p) = p

emptyCPassPhrase :: CPassPhrase
emptyCPassPhrase = CPassPhrase ""

mkCPassPhrase :: String -> Maybe CPassPhrase
mkCPassPhrase "" = Nothing
mkCPassPhrase pass = Just <<< CPassPhrase <<< bytesToB16 $ blake2b pass

mkCId :: forall a. String -> CId a
mkCId = CId <<< CHash

_ccoin :: CCoin -> String
_ccoin (CCoin c) = c.getCCoin

mkCCoin :: String -> CCoin
mkCCoin amount = CCoin { getCCoin: amount }

-- NOTE: use genericRead maybe https://github.com/paluh/purescript-generic-read-example
mkCWSetAssurance :: String -> CT.CWalletAssurance
mkCWSetAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCAccountMeta :: String -> CT.CAccountMeta
mkCAccountMeta wName =
    CT.CAccountMeta { caName: wName
                   }

mkCAccountId :: String -> CT.CAccountId
mkCAccountId = CAccountId

mkCInitialized :: Int -> Int -> CT.CInitialized
mkCInitialized total preInit =
    CT.CInitialized { cTotalTime: fromInt total
                    , cPreInit: fromInt preInit
                    }

mkCAccountInit :: String -> CId Wal -> CT.CAccountInit
mkCAccountInit wName wSetId =
    CT.CAccountInit { cwInitWId: wSetId
                   , caInitMeta: mkCAccountMeta wName
                   }

mkCWalletAssurance :: String -> CT.CWalletAssurance
mkCWalletAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCWalletInit :: String -> String -> Int -> String -> Either Error CT.CWalletInit
mkCWalletInit wSetName wsAssurance wsUnit mnemonic = do
    bp <- mkBackupPhrase backupMnemonicLen mnemonic
    pure $ CT.CWalletInit { cwInitMeta:
                                CWalletMeta
                                    { cwName: wSetName
                                    , cwAssurance: mkCWalletAssurance wsAssurance
                                    , csUnit: wsUnit
                                    }
                             , cwBackupPhrase: bp
                             }

mkCWalletRedeem :: String -> CAccountId -> CT.CWalletRedeem
mkCWalletRedeem seed wAddress = do
    CT.CWalletRedeem { crWalletId: wAddress
                     , crSeed: seed
                     }

-- NOTE: if you will be bumping bip39 to >=2.2.0 be aware of https://issues.serokell.io/issue/VD-95 . In this case you will have to modify how we validate paperVendMnemonics.
mkCPaperVendWalletRedeem :: String -> String -> CAccountId -> Either Error CT.CPaperVendWalletRedeem
mkCPaperVendWalletRedeem seed mnemonic wAddress = do
    bp <- mkBackupPhrase paperVendMnemonicLen mnemonic
    pure $ CT.CPaperVendWalletRedeem { pvWalletId: wAddress
                                     , pvBackupPhrase: bp
                                     , pvSeed: seed
                                     }

_ctxIdValue :: CT.CTxId -> String
_ctxIdValue (CT.CTxId tx) = _hash tx

mkCTxId :: String -> CT.CTxId
mkCTxId = CT.CTxId <<< CHash

mkCTxMeta :: String -> String -> Number -> CT.CTxMeta
mkCTxMeta title description date =
    CT.CTxMeta { ctmTitle: title
               , ctmDescription: description
               , ctmDate: mkTime date
               }

mkCProfile :: String -> CT.CProfile
mkCProfile locale =
    CT.CProfile { cpLocale: locale
                }

getProfileLocale :: CT.CProfile -> String
getProfileLocale (CT.CProfile r) = r.cpLocale

module Daedalus.Types
       ( module CT
       , module C
       , module E
       , module BP
       , module DT
       , _address
       , _ccoin
       , _passPhrase
       , mkCCoin
       , mkCId
       , mkCAccountMeta
       , mkCAccountInit
       , mkCAccountId
       , mkCTxMeta
       , mkCTxId
       , mkCProfile
       , _ctxIdValue
       , mkBackupPhrase
       , mkCWalletRedeem
       , mkCPaperVendWalletRedeem
       , mkCInitialized
       , mkCPassPhrase
       , emptyCPassPhrase
       , getProfileLocale
       , walletAddressToUrl
       , mkCWalletInit
       , mkCWalletAssurance
       ) where

import Prelude

import Pos.Wallet.Web.ClientTypes (CId (..), CHash (..), CPassPhrase (..), CCoin (..), Wal (..), CAccountId (..), CWalletMeta (..))

import Pos.Wallet.Web.ClientTypes as CT
import Pos.Core.Types as C
import Pos.Wallet.Web.Error as E
import Pos.Util.BackupPhrase (BackupPhrase (..))
import Pos.Util.BackupPhrase as BP

import Control.Monad.Eff.Exception (error, Error)
import Data.Either (either, Either (..))
import Data.Maybe (Maybe (..))
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Argonaut.Core (fromString)
import Data.Generic (gShow)
import Data.Array.Partial (last)
import Data.Array (length, filter)
import Partial.Unsafe (unsafePartial)
import Data.String (split, null, trim, joinWith, Pattern (..))

import Daedalus.Crypto (isValidMnemonic, blake2b, bytesToB16)
import Data.Types (mkTime)
import Data.Types as DT
import Data.Int53 (fromInt, toString)

space :: Pattern
space = Pattern " "

dot :: Pattern
dot = Pattern "."

backupMnemonicLen :: Int
backupMnemonicLen = 12

paperVendMnemonicLen :: Int
paperVendMnemonicLen = 9

-- NOTE: if you will be bumping bip39 to >=2.2.0 be aware of https://issues.serokell.io/issue/VD-95 . In this case you will have to modify how we validate paperVendMnemonics.
mkBackupPhrase :: Int -> String -> Either Error BackupPhrase
mkBackupPhrase len mnemonic = mkBackupPhraseIgnoreChecksum len mnemonic >>= const do
    if not $ isValidMnemonic mnemonicCleaned
        then Left $ error "Invalid mnemonic: checksum missmatch"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    mnemonicCleaned = cleanMnemonic mnemonic

cleanMnemonic :: String -> String
cleanMnemonic = joinWith " " <<< filter (not <<< null) <<< split space <<< trim

mkBackupPhraseIgnoreChecksum :: Int -> String -> Either Error BackupPhrase
mkBackupPhraseIgnoreChecksum len mnemonic =
    if not $ hasExactlyNwords len mnemonicCleaned
        then Left $ error $ "Invalid mnemonic: mnemonic should have exactly " <> show len <> " words"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    hasExactlyNwords len' = (==) len' <<< length <<< split space
    mnemonicCleaned = cleanMnemonic mnemonic

-- TODO: it would be useful to extend purescript-bridge
-- and generate lenses
walletAddressToUrl :: CAccountId -> String
walletAddressToUrl (CAccountId r) = r

_hash :: CHash -> String
_hash (CHash h) = h

_address :: forall a. CId a -> String
_address (CId a) = _hash a

_passPhrase :: CPassPhrase -> String
_passPhrase (CPassPhrase p) = p

emptyCPassPhrase :: CPassPhrase
emptyCPassPhrase = CPassPhrase ""

mkCPassPhrase :: String -> Maybe CPassPhrase
mkCPassPhrase "" = Nothing
mkCPassPhrase pass = Just <<< CPassPhrase <<< bytesToB16 $ blake2b pass

mkCId :: forall a. String -> CId a
mkCId = CId <<< CHash

_ccoin :: CCoin -> String
_ccoin (CCoin c) = c.getCCoin

mkCCoin :: String -> CCoin
mkCCoin amount = CCoin { getCCoin: amount }

-- NOTE: use genericRead maybe https://github.com/paluh/purescript-generic-read-example
mkCWSetAssurance :: String -> CT.CWalletAssurance
mkCWSetAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCAccountMeta :: String -> CT.CAccountMeta
mkCAccountMeta wName =
    CT.CAccountMeta { caName: wName
                   }

mkCAccountId :: String -> CT.CAccountId
mkCAccountId = CAccountId

mkCInitialized :: Int -> Int -> CT.CInitialized
mkCInitialized total preInit =
    CT.CInitialized { cTotalTime: fromInt total
                    , cPreInit: fromInt preInit
                    }

mkCAccountInit :: String -> CId Wal -> CT.CAccountInit
mkCAccountInit wName wSetId =
    CT.CAccountInit { cwInitWId: wSetId
                   , caInitMeta: mkCAccountMeta wName
                   }

mkCWalletAssurance :: String -> CT.CWalletAssurance
mkCWalletAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCWalletInit :: String -> String -> Int -> String -> Either Error CT.CWalletInit
mkCWalletInit wSetName wsAssurance wsUnit mnemonic = do
    bp <- mkBackupPhrase backupMnemonicLen mnemonic
    pure $ CT.CWalletInit { cwInitMeta:
                                CWalletMeta
                                    { cwName: wSetName
                                    , cwAssurance: mkCWalletAssurance wsAssurance
                                    , csUnit: wsUnit
                                    }
                             , cwBackupPhrase: bp
                             }

mkCWalletRedeem :: String -> CAccountId -> CT.CWalletRedeem
mkCWalletRedeem seed wAddress = do
    CT.CWalletRedeem { crWalletId: wAddress
                     , crSeed: seed
                     }

-- NOTE: if you will be bumping bip39 to >=2.2.0 be aware of https://issues.serokell.io/issue/VD-95 . In this case you will have to modify how we validate paperVendMnemonics.
mkCPaperVendWalletRedeem :: String -> String -> CAccountId -> Either Error CT.CPaperVendWalletRedeem
mkCPaperVendWalletRedeem seed mnemonic wAddress = do
    bp <- mkBackupPhrase paperVendMnemonicLen mnemonic
    pure $ CT.CPaperVendWalletRedeem { pvWalletId: wAddress
                                     , pvBackupPhrase: bp
                                     , pvSeed: seed
                                     }

_ctxIdValue :: CT.CTxId -> String
_ctxIdValue (CT.CTxId tx) = _hash tx

mkCTxId :: String -> CT.CTxId
mkCTxId = CT.CTxId <<< CHash

mkCTxMeta :: String -> String -> Number -> CT.CTxMeta
mkCTxMeta title description date =
    CT.CTxMeta { ctmTitle: title
               , ctmDescription: description
               , ctmDate: mkTime date
               }

mkCProfile :: String -> CT.CProfile
mkCProfile locale =
    CT.CProfile { cpLocale: locale
                }

getProfileLocale :: CT.CProfile -> String
getProfileLocale (CT.CProfile r) = r.cpLocale


Fix: whitespace after equals sign breaks parsing.

Whitespace after equals sign in an argument is not skipped correctly if the argument value is
unquoted. If we refactor a bit, the bug disappears.

module Text.HTML.Parser.Internal where

import Prelude
import Control.Alt
import Control.Apply
import Data.Either
import Data.List (List(..))
import Data.Maybe
import Data.Tuple

import Text.Parsing.StringParser
import Text.Parsing.StringParser.Combinators
import Text.Parsing.StringParser.String (eof, string)

import Text.HTML.Parser.Combinators
import Text.HTML.Parser.Types

parseHTML :: String -> Either ParseError (List HTML)
parseHTML s = flip runParser s $ many parseNode <* eof

parseElement = do
  Tuple name attrs <- parseOpenTag
  children <- many parseNode
  parseCloseTag name
  pure $ Element name attrs children

parseNode = fix \_ ->
  try parseElement <|>
  try parseVoidElement <|>
  parseTextNode

parseOpenTag :: Parser (Tuple String (List Attribute))
parseOpenTag = do
  notClosedTag
  char '<'
  name <- parseTagName
  skipSpaces
  attrs <- parseAttributes
  skipSpaces
  char '>'
  pure $ Tuple name attrs

parseCloseTag :: String -> Parser Char
parseCloseTag name = do
  string "</"
  string name
  char '>'

notClosedTag :: Parser Unit
notClosedTag = notFollowedBy $ string "</"

parseVoidElement = do
  notClosedTag
  char '<'
  name <- parseTagName
  skipSpaces
  attrs <- parseAttributes
  skipSpaces
  string "/>"
  pure $ VoidElement name attrs

parseTagName :: Parser String
parseTagName = catChars <$> many1 (satisfy isAlphaNumeric)

parseTextNode :: Parser HTML
parseTextNode = TextNode <<< catChars <$> many1 (noneOf ['<', '>'])

parseAttributes :: Parser (List Attribute)
parseAttributes = sepEndBy parseAttribute skipSpaces

parseAttribute :: Parser Attribute
parseAttribute = do
  name <- parseAttributeName
  skipSpaces
  maybeEquals <- optionMaybe $ char '='
  value <- case maybeEquals of
    Nothing -> pure ""
    Just _ -> do
        skipSpaces
        parseAttributeValue
  pure $ Attribute name value

parseAttributeName :: Parser String
parseAttributeName = catChars <$> many1 (noneOf [' ', '"', '\'', '>', '/', '='])

parseAttributeValue :: Parser String
parseAttributeValue = do
  maybeOpenChar <- optionMaybe (char '"' <|> char '\'')
  case maybeOpenChar of
    Nothing -> catChars <$> many1 (noneOf [' ', '\t', '\n', '\r', '"', '\'', '=', '<', '>', '`', '/'])
    Just openChar -> do
      value <- catChars <$> many (noneOf [openChar])
      char openChar
      pure value

module Text.HTML.Parser.Internal where

import Prelude
import Control.Alt
import Control.Apply
import Data.Either
import Data.List (List(..))
import Data.Maybe
import Data.Tuple

import Text.Parsing.StringParser
import Text.Parsing.StringParser.Combinators
import Text.Parsing.StringParser.String (eof, string)

import Text.HTML.Parser.Combinators
import Text.HTML.Parser.Types

parseHTML :: String -> Either ParseError (List HTML)
parseHTML s = flip runParser s $ many parseNode <* eof

parseElement = do
  Tuple name attrs <- parseOpenTag
  children <- many parseNode
  parseCloseTag name
  pure $ Element name attrs children

parseNode = fix \_ ->
  try parseElement <|>
  try parseVoidElement <|>
  parseTextNode

parseOpenTag :: Parser (Tuple String (List Attribute))
parseOpenTag = do
  notClosedTag
  char '<'
  name <- parseTagName
  skipSpaces
  attrs <- parseAttributes
  skipSpaces
  char '>'
  pure $ Tuple name attrs

parseCloseTag :: String -> Parser Char
parseCloseTag name = do
  string "</"
  string name
  char '>'

notClosedTag :: Parser Unit
notClosedTag = notFollowedBy $ string "</"

parseVoidElement = do
  notClosedTag
  char '<'
  name <- parseTagName
  skipSpaces
  attrs <- parseAttributes
  skipSpaces
  string "/>"
  pure $ VoidElement name attrs

parseTagName :: Parser String
parseTagName = catChars <$> many1 (satisfy isAlphaNumeric)

parseTextNode :: Parser HTML
parseTextNode = TextNode <<< catChars <$> many1 (noneOf ['<', '>'])

parseAttributes :: Parser (List Attribute)
parseAttributes = sepEndBy parseAttribute skipSpaces

parseAttribute :: Parser Attribute
parseAttribute = do
  name <- parseAttributeName
  skipSpaces
  maybeEquals <- optionMaybe $ char '='
  value <- case maybeEquals of
    Nothing -> pure ""
    Just _ -> parseAttributeValue
  pure $ Attribute name value

parseAttributeName :: Parser String
parseAttributeName = catChars <$> many1 (noneOf [' ', '"', '\'', '>', '/', '='])

parseAttributeValue :: Parser String
parseAttributeValue = do
  maybeOpenChar <- optionMaybe $ skipSpaces *> (char '"' <|> char '\'')
  case maybeOpenChar of
    Nothing -> catChars <$> many1 (noneOf [' ', '\t', '\n', '\r', '"', '\'', '=', '<', '>', '`', '/'])
    Just openChar -> do
      value <- catChars <$> many (noneOf [openChar])
      char openChar
      pure value


export extent'

export extent'

module Graphics.D3.Util
  ( Magnitude
  , min
  , max
  , min'
  , max'
  , extent
  , extent'
  , (..)
  , (...)
  ) where

import Data.Foreign.EasyFFI
import Data.Date

class Magnitude n

instance numberMagnitude :: Magnitude Number
instance dateMagnitude :: Magnitude JSDate

min' :: forall d m. (Magnitude m) => (d -> m) -> [d] -> m
min' = unsafeForeignFunction ["fn", "data"] "d3.min(data, fn)"

max' :: forall d m. (Magnitude m) => (d -> m) -> [d] -> m
max' = unsafeForeignFunction ["fn", "data"] "d3.max(data, fn)"

min :: forall m. (Magnitude m) => [m] -> m
min = unsafeForeignFunction ["data"] "d3.min(data)"

max :: forall d m. (Magnitude m) => [m] -> m
max = unsafeForeignFunction ["data"] "d3.max(data)"

-- extent takes a data array and returns [min,max]
-- not restricted to Number, i.e. also works with time
extent :: forall m. (Magnitude m) => [m] -> [m]
extent = unsafeForeignFunction ["data"] "d3.extent(data)"

extent' :: forall d m. (Magnitude m) => (d->m) -> [d] -> [m]
extent' = unsafeForeignFunction ["fn", "data"] "d3.extent(data, fn)"

-- Syntactic sugar to make chained monadic statements look similar to the
-- "fluid interface" style of chained method calls in JavaScript
(..) = (>>=)

-- Reversed function application, useful for applying extended monadic chains
-- to already-obtained values
(...) = flip ($)

module Graphics.D3.Util
  ( Magnitude
  , min
  , max
  , min'
  , max'
  , extent
  , (..)
  , (...)
  ) where

import Data.Foreign.EasyFFI
import Data.Date

class Magnitude n

instance numberMagnitude :: Magnitude Number
instance dateMagnitude :: Magnitude JSDate

min' :: forall d m. (Magnitude m) => (d -> m) -> [d] -> m
min' = unsafeForeignFunction ["fn", "data"] "d3.min(data, fn)"

max' :: forall d m. (Magnitude m) => (d -> m) -> [d] -> m
max' = unsafeForeignFunction ["fn", "data"] "d3.max(data, fn)"

min :: forall m. (Magnitude m) => [m] -> m
min = unsafeForeignFunction ["data"] "d3.min(data)"

max :: forall d m. (Magnitude m) => [m] -> m
max = unsafeForeignFunction ["data"] "d3.max(data)"

-- extent takes a data array and returns [min,max]
-- not restricted to Number, i.e. also works with time
extent :: forall m. (Magnitude m) => [m] -> [m]
extent = unsafeForeignFunction ["data"] "d3.extent(data)"

extent' :: forall d m. (Magnitude m) => (d->m) -> [d] -> [m]
extent' = unsafeForeignFunction ["fn", "data"] "d3.extent(data, fn)"

-- Syntactic sugar to make chained monadic statements look similar to the
-- "fluid interface" style of chained method calls in JavaScript
(..) = (>>=)

-- Reversed function application, useful for applying extended monadic chains
-- to already-obtained values
(...) = flip ($)


Despair on map function

Despair on map function

Signed-off-by: Joern Bernhardt <7b85a41a628204b76aba4326273a3ccc74bd009a@campudus.com>

module HList
  ( HList
  , cons
  , empty
  ) where

import Prelude (Unit, unit)

data HList a l = HNil | HCons a l

cons :: forall a b l1. a -> HList b l1 -> HList a (HList b l1)
cons a HNil = HCons a HNil
cons a (HCons b l) = HCons a (HCons b l)

empty :: forall a l. HList a l
empty = HNil

map :: forall a b l1 l2. (a -> b) -> HList a l1 -> HList b l2
map fn (HNil) = HNil
map fn (HCons a l) = HCons (fn a) (map fn l)

module HList
  ( HList
  , cons
  , empty
  ) where

import Data.Tuple.Nested (Tuple2)
import Prelude (Unit, unit)

data HList a = HNil | HCons a HList _

-- data HList h l = HNil | HList h (HList l)

cons :: forall a b l1 l2. a -> HList a l1 -> HList b l2
cons a HNil = HCons a HNil
cons a (HCons b t) = HCons a (HCons b t)

empty :: forall a b. HList a b
empty = HNil

map :: forall a b l1 l2. (a -> b) -> HList l1 -> HList l2
map fn (HCons a (HCons b t)) = cons (fn a) (map fn (HCons b t))
map fn (HCons a HNil) = cons (fn a) HNil


Revert "Fix searchHistory if search term is empty"

This reverts commit dc84ac1427428be04ea9babd187d10424de8b249.

module Daedalus.ClientApi where

import Prelude
import Control.Monad.Aff (liftEff')
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (mkCAddress, mkCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.Function.Uncurried (Fn2, mkFn2, Fn4, mkFn4, Fn3, mkFn3, Fn6, mkFn6, Fn7, mkFn7)
import Data.Function.Eff (EffFn1, runEffFn1)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto

getProfile :: forall eff. Eff(ajax :: AJAX | eff) (Promise Json)
getProfile = fromAff $ map encodeJson B.getProfile

updateProfile :: forall eff. Fn7 String String String String Number String String (Eff(ajax :: AJAX | eff) (Promise Json))
updateProfile = mkFn7 \name email phone pass date locale picture -> fromAff <<< map encodeJson <<< B.updateProfile $ mkCProfile name email phone pass date locale picture

getWallets :: forall eff. Eff(ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWallets

getWallet :: forall eff. String -> (Eff(ajax :: AJAX | eff) (Promise Json))
getWallet = fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress

getHistory :: forall eff. Fn3 String Int Int (Eff (ajax :: AJAX | eff) (Promise Json))
getHistory = mkFn3 \addr skip limit -> fromAff <<< map encodeJson $
    B.getHistory
        (mkCAddress addr)
        skip
        limit

searchHistory :: forall eff. Fn4 String String Int Int (Eff(ajax :: AJAX | eff) (Promise Json))
searchHistory = mkFn4 \addr search skip limit -> fromAff <<< map encodeJson $
    B.searchHistory
        (mkCAddress addr)
        search
        skip
        limit

send :: forall eff. Fn3 String String Int (Eff(ajax :: AJAX | eff) (Promise Json))
send = mkFn3 \addrFrom addrTo amount -> fromAff <<< map encodeJson $
    B.send
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCoin amount)

sendExtended :: forall eff. Fn6 String String Int String String String (Eff(ajax :: AJAX | eff) (Promise Json))
sendExtended = mkFn6 \addrFrom addrTo amount curr title desc -> fromAff <<< map encodeJson $
    B.sendExtended
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCoin amount)
        (mkCCurrency curr)
        title
        desc

generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
generateMnemonic = Crypto.generateMnemonic

newWallet :: forall eff . Fn4 String String String String
  (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
newWallet = mkFn4 \wType wCurrency wName mnemonic -> fromAff <<< map encodeJson <<<
    either throwError B.newWallet $ mkCWalletInit wType wCurrency wName mnemonic

-- NOTE: https://issues.serokell.io/issue/DAE-33#comment=96-1798
-- Daedalus.ClientApi.newWallet(
--     'CWTPersonal'
--   , 'ADA'
--   , 'wallet name'
--   , function(mnemonics) {
--     // if this function finishes we will send request for wallet
--     // creation to the backend. That means user validated and
--     // stored mnemonics.
--     // if an exception is thrown new wallet request will be aborted
--     // and promise should return thrown error
--     if(userSavedMnemonics) {
--       // do nothing
--     } else {
--       throw new Error("Wallet canceled")
--     }
--   }
--   )()
--   .then(function(value) {
--     console.log('SUCCESS', value);
--   }, function(reason) {
--     console.log('ERROR', reason);
--   })
newWalletDeprecated :: forall eff . Fn4 String String String (EffFn1 (err :: EXCEPTION | eff) String Unit)
  (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
newWalletDeprecated = mkFn4 \wType wCurrency wName wConfirmMnemonic -> fromAff $ map encodeJson $ do

    mnemonic <- liftEff Crypto.generateMnemonic
    -- FIXME: @jens how did we satisfy this with notify? I am having trouble again
    isConfirmed <- liftEff' $ unsafeInterleaveEff $ runEffFn1 wConfirmMnemonic mnemonic
    either throwError B.newWallet $ do
        isConfirmed
        mkCWalletInit wType wCurrency wName mnemonic

updateWallet :: forall eff. Fn4 String String String String
  (Eff (ajax :: AJAX | eff) (Promise Json))
updateWallet = mkFn4 \addr wType wCurrency wName -> fromAff <<< map encodeJson <<<
    B.updateWallet
        (mkCAddress addr)
        $ mkCWalletMeta wType wCurrency wName

updateTransaction :: forall eff. Fn6 String String String String String Number (Eff (ajax :: AJAX | eff) (Promise Unit))
updateTransaction = mkFn6 \addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
    B.updateTransaction
        (mkCAddress addr)
        (mkCTxId ctxId)
        $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate

deleteWallet :: forall eff. String -> (Eff(ajax :: AJAX | eff) (Promise Unit))
deleteWallet = fromAff <<< B.deleteWallet <<< mkCAddress

isValidAddress :: forall eff. Fn2 String String (Eff(ajax :: AJAX | eff) (Promise Boolean))
isValidAddress = mkFn2 \currency -> fromAff <<< B.isValidAddress (mkCCurrency currency)

notify :: forall eff. Fn2 (NotifyCb eff) (ErrorCb eff) (Eff (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) Unit)
notify = mkFn2 \messageCb errorCb -> do
    -- TODO (akegalj) grab global (mutable) state of  here
    -- instead of creating newRef
    conn <- newRef WSNotConnected
    openConn $ mkWSState conn messageCb errorCb

blockchainSlotDuration :: forall eff. Eff (ajax :: AJAX | eff) (Promise Int)
blockchainSlotDuration = fromAff B.blockchainSlotDuration

module Daedalus.ClientApi where

import Prelude
import Control.Monad.Aff (liftEff')
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (mkCAddress, mkCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.Function.Uncurried (Fn2, mkFn2, Fn4, mkFn4, Fn3, runFn3, mkFn3, Fn6, mkFn6, Fn7, mkFn7)
import Data.Function.Eff (EffFn1, runEffFn1)
import Data.String (null)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto

getProfile :: forall eff. Eff(ajax :: AJAX | eff) (Promise Json)
getProfile = fromAff $ map encodeJson B.getProfile

updateProfile :: forall eff. Fn7 String String String String Number String String (Eff(ajax :: AJAX | eff) (Promise Json))
updateProfile = mkFn7 \name email phone pass date locale picture -> fromAff <<< map encodeJson <<< B.updateProfile $ mkCProfile name email phone pass date locale picture

getWallets :: forall eff. Eff(ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWallets

getWallet :: forall eff. String -> (Eff(ajax :: AJAX | eff) (Promise Json))
getWallet = fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress

getHistory :: forall eff. Fn3 String Int Int (Eff (ajax :: AJAX | eff) (Promise Json))
getHistory = mkFn3 \addr skip limit -> fromAff <<< map encodeJson $
    B.getHistory
        (mkCAddress addr)
        skip
        limit

searchHistory :: forall eff. Fn4 String String Int Int (Eff(ajax :: AJAX | eff) (Promise Json))
searchHistory = mkFn4 \addr search skip limit ->
    if null search
        then runFn3 getHistory addr skip limit
        else fromAff <<< map encodeJson $ B.searchHistory (mkCAddress addr) search skip limit

send :: forall eff. Fn3 String String Int (Eff(ajax :: AJAX | eff) (Promise Json))
send = mkFn3 \addrFrom addrTo amount -> fromAff <<< map encodeJson $
    B.send
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCoin amount)

sendExtended :: forall eff. Fn6 String String Int String String String (Eff(ajax :: AJAX | eff) (Promise Json))
sendExtended = mkFn6 \addrFrom addrTo amount curr title desc -> fromAff <<< map encodeJson $
    B.sendExtended
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCoin amount)
        (mkCCurrency curr)
        title
        desc

generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
generateMnemonic = Crypto.generateMnemonic

newWallet :: forall eff . Fn4 String String String String
  (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
newWallet = mkFn4 \wType wCurrency wName mnemonic -> fromAff <<< map encodeJson <<<
    either throwError B.newWallet $ mkCWalletInit wType wCurrency wName mnemonic

-- NOTE: https://issues.serokell.io/issue/DAE-33#comment=96-1798
-- Daedalus.ClientApi.newWallet(
--     'CWTPersonal'
--   , 'ADA'
--   , 'wallet name'
--   , function(mnemonics) {
--     // if this function finishes we will send request for wallet
--     // creation to the backend. That means user validated and
--     // stored mnemonics.
--     // if an exception is thrown new wallet request will be aborted
--     // and promise should return thrown error
--     if(userSavedMnemonics) {
--       // do nothing
--     } else {
--       throw new Error("Wallet canceled")
--     }
--   }
--   )()
--   .then(function(value) {
--     console.log('SUCCESS', value);
--   }, function(reason) {
--     console.log('ERROR', reason);
--   })
newWalletDeprecated :: forall eff . Fn4 String String String (EffFn1 (err :: EXCEPTION | eff) String Unit)
  (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
newWalletDeprecated = mkFn4 \wType wCurrency wName wConfirmMnemonic -> fromAff $ map encodeJson $ do

    mnemonic <- liftEff Crypto.generateMnemonic
    -- FIXME: @jens how did we satisfy this with notify? I am having trouble again
    isConfirmed <- liftEff' $ unsafeInterleaveEff $ runEffFn1 wConfirmMnemonic mnemonic
    either throwError B.newWallet $ do
        isConfirmed
        mkCWalletInit wType wCurrency wName mnemonic

updateWallet :: forall eff. Fn4 String String String String
  (Eff (ajax :: AJAX | eff) (Promise Json))
updateWallet = mkFn4 \addr wType wCurrency wName -> fromAff <<< map encodeJson <<<
    B.updateWallet
        (mkCAddress addr)
        $ mkCWalletMeta wType wCurrency wName

updateTransaction :: forall eff. Fn6 String String String String String Number (Eff (ajax :: AJAX | eff) (Promise Unit))
updateTransaction = mkFn6 \addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
    B.updateTransaction
        (mkCAddress addr)
        (mkCTxId ctxId)
        $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate

deleteWallet :: forall eff. String -> (Eff(ajax :: AJAX | eff) (Promise Unit))
deleteWallet = fromAff <<< B.deleteWallet <<< mkCAddress

isValidAddress :: forall eff. Fn2 String String (Eff(ajax :: AJAX | eff) (Promise Boolean))
isValidAddress = mkFn2 \currency -> fromAff <<< B.isValidAddress (mkCCurrency currency)

notify :: forall eff. Fn2 (NotifyCb eff) (ErrorCb eff) (Eff (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) Unit)
notify = mkFn2 \messageCb errorCb -> do
    -- TODO (akegalj) grab global (mutable) state of  here
    -- instead of creating newRef
    conn <- newRef WSNotConnected
    openConn $ mkWSState conn messageCb errorCb

blockchainSlotDuration :: forall eff. Eff (ajax :: AJAX | eff) (Promise Int)
blockchainSlotDuration = fromAff B.blockchainSlotDuration


Switch renderers in UI

Switch renderers in UI

Original commit 5269b469d7f166f2b8759975460ee0b257831091

module Main where

import IR
import Prelude
import Types
import Doc as Doc

import CSharp as CSharp
import Swift as Swift

import Data.Argonaut.Core (Json, foldJson)
import Data.Argonaut.Parser (jsonParser)

import Data.Array as A
import Data.Either (Either)
import Data.Map as Map
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))

renderers :: Array Renderer
renderers = [
    CSharp.renderer,
    Swift.renderer
]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\_ -> pure IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = runIR do
    topLevel <- makeTypeFromJson name json
    replaceSimilarClasses

renderJson :: Renderer -> String -> Either String String
renderJson renderer json =
    jsonParser json
    <#> makeTypeAndUnify "TopLevel"
    <#> Doc.runDoc renderer.doc

module Main where

import Prelude

import IR
import Doc as Doc
import CSharp as CSharp
import Swift as Swift

import Data.Argonaut.Core (Json, foldJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array as A
import Data.Either (Either)
import Data.Map as Map
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\_ -> pure IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = runIR do
    topLevel <- makeTypeFromJson name json
    replaceSimilarClasses

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeTypeAndUnify "TopLevel"
    <#> Doc.runDoc CSharp.renderer.doc


Avoid Discard constraint

Avoid Discard constraint

-- | This module defines a type of native Javascript maps which
-- | require the keys to be strings.
-- |
-- | To maximize performance, Javascript objects are not wrapped,
-- | and some native code is used even when it's not necessary.

module Data.StrMap
  ( StrMap
  , empty
  , isEmpty
  , size
  , singleton
  , insert
  , lookup
  , toList
  , toUnfoldable
  , fromFoldable
  , fromFoldableWith
  , delete
  , pop
  , member
  , alter
  , update
  , mapWithKey
  , keys
  , values
  , union
  , unions
  , isSubmap
  , fold
  , foldMap
  , foldM
  , foldMaybe
  , all
  , thawST
  , freezeST
  , runST
  , pureST
  ) where

import Prelude

import Control.Monad.Eff (Eff, runPure)
import Control.Monad.ST as ST

import Data.Foldable (class Foldable, foldl, foldr, for_)
import Data.Function.Uncurried (Fn2, runFn2, Fn4, runFn4)
import Data.List as L
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.StrMap.ST as SM
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(..), uncurry)
import Data.Unfoldable (class Unfoldable)

-- | `StrMap a` represents a map from `String`s to values of type `a`.
foreign import data StrMap :: * -> *

foreign import _copyEff :: forall a b h r. a -> Eff (st :: ST.ST h | r) b

-- | Convert an immutable map into a mutable map
thawST :: forall a h r. StrMap a -> Eff (st :: ST.ST h | r) (SM.STStrMap h a)
thawST = _copyEff

-- | Convert a mutable map into an immutable map
freezeST :: forall a h r. SM.STStrMap h a -> Eff (st :: ST.ST h | r) (StrMap a)
freezeST = _copyEff

-- | Freeze a mutable map, creating an immutable map. Use this function as you would use
-- | `Prelude.runST` to freeze a mutable reference.
-- |
-- | The rank-2 type prevents the map from escaping the scope of `runST`.
foreign import runST :: forall a r. (forall h. Eff (st :: ST.ST h | r) (SM.STStrMap h a)) -> Eff r (StrMap a)

pureST :: forall a. (forall h e. Eff (st :: ST.ST h | e) (SM.STStrMap h a)) -> StrMap a
pureST f = runPure (runST f)

mutate :: forall a b. (forall h e. SM.STStrMap h a -> Eff (st :: ST.ST h | e) b) -> StrMap a -> StrMap a
mutate f m = pureST do
  s <- thawST m
  _ <- f s
  pure s

foreign import _fmapStrMap :: forall a b. Fn2 (StrMap a) (a -> b) (StrMap b)

instance functorStrMap :: Functor StrMap where
  map f m = runFn2 _fmapStrMap m f

foreign import _foldM :: forall a m z. (m -> (z -> m) -> m) -> (z -> String -> a -> m) -> m -> StrMap a -> m

-- | Fold the keys and values of a map
fold :: forall a z. (z -> String -> a -> z) -> z -> StrMap a -> z
fold = _foldM ((#))

-- | Fold the keys and values of a map, accumulating values using
-- | some `Monoid`.
foldMap :: forall a m. (Monoid m) => (String -> a -> m) -> StrMap a -> m
foldMap f = fold (\acc k v -> acc <> f k v) mempty

-- | Fold the keys and values of a map, accumulating values and effects in
-- | some `Monad`.
foldM :: forall a m z. (Monad m) => (z -> String -> a -> m z) -> z -> StrMap a -> m z
foldM f z = _foldM (>>=) f (pure z)

instance foldableStrMap :: Foldable StrMap where
  foldl f = fold (\z _ -> f z)
  foldr f z m = foldr f z (values m)
  foldMap f = foldMap (const f)

instance traversableStrMap :: Traversable StrMap where
  traverse f ms = foldr (\x acc -> union <$> x <*> acc) (pure empty) ((map (uncurry singleton)) <$> (traverse f <$> toList ms))
  sequence = traverse id

-- Unfortunately the above are not short-circuitable (consider using purescript-machines)
-- so we need special cases:

foreign import _foldSCStrMap :: forall a z. Fn4 (StrMap a) z (z -> String -> a -> Maybe z) (forall b. b -> Maybe b -> b) z

-- | Fold the keys and values of a map.
-- |
-- | This function allows the folding function to terminate the fold early,
-- | using `Maybe`.
foldMaybe :: forall a z. (z -> String -> a -> Maybe z) -> z -> StrMap a -> z
foldMaybe f z m = runFn4 _foldSCStrMap m z f fromMaybe

-- | Test whether all key/value pairs in a `StrMap` satisfy a predicate.
foreign import all :: forall a. (String -> a -> Boolean) -> StrMap a -> Boolean

instance eqStrMap :: (Eq a) => Eq (StrMap a) where
  eq m1 m2 = (isSubmap m1 m2) && (isSubmap m2 m1)

instance showStrMap :: (Show a) => Show (StrMap a) where
  show m = "fromList " <> show (toList m)

-- | An empty map
foreign import empty :: forall a. StrMap a

-- | Test whether one map contains all of the keys and values contained in another map
isSubmap :: forall a. (Eq a) => StrMap a -> StrMap a -> Boolean
isSubmap m1 m2 = all f m1 where
  f k v = runFn4 _lookup false ((==) v) k m2

-- | Test whether a map is empty
isEmpty :: forall a. StrMap a -> Boolean
isEmpty = all (\_ _ -> false)

-- | Calculate the number of key/value pairs in a map
foreign import size :: forall a. StrMap a -> Number

-- | Create a map with one key/value pair
singleton :: forall a. String -> a -> StrMap a
singleton k v = pureST do
  s <- SM.new
  _ <- SM.poke s k v
  pure s

foreign import _lookup :: forall a z. Fn4 z (a -> z) String (StrMap a) z

-- | Lookup the value for a key in a map
lookup :: forall a. String -> StrMap a -> Maybe a
lookup = runFn4 _lookup Nothing Just

-- | Test whether a `String` appears as a key in a map
member :: forall a. String -> StrMap a -> Boolean
member = runFn4 _lookup false (const true)

-- | Insert a key and value into a map
insert :: forall a. String -> a -> StrMap a -> StrMap a
insert k v = mutate (\s -> void $ SM.poke s k v)

foreign import _unsafeDeleteStrMap :: forall a. Fn2 (StrMap a) String (StrMap a)

-- | Delete a key and value from a map
delete :: forall a. String -> StrMap a -> StrMap a
delete k = mutate (\s -> void $ SM.delete s k)

-- | Delete a key and value from a map, returning the value
-- | as well as the subsequent map
pop :: forall a. String -> StrMap a -> Maybe (Tuple a (StrMap a))
pop k m = lookup k m <#> \a -> Tuple a (delete k m)

-- | Insert, remove or update a value for a key in a map
alter :: forall a. (Maybe a -> Maybe a) -> String -> StrMap a -> StrMap a
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

-- | Remove or update a value for a key in a map
update :: forall a. (a -> Maybe a) -> String -> StrMap a -> StrMap a
update f k m = alter (maybe Nothing f) k m

-- | Create a map from a foldable collection of key/value pairs
fromFoldable :: forall f a. Foldable f => f (Tuple String a) -> StrMap a
fromFoldable l = pureST (do
  s <- SM.new
  for_ l (\(Tuple k v) -> SM.poke s k v)
  pure s)

foreign import _lookupST :: forall a h r z. Fn4 z (a -> z) String (SM.STStrMap h a) (Eff (st :: ST.ST h | r) z)

-- | Create a map from a foldable collection of key/value pairs, using the
-- | specified function to combine values for duplicate keys.
fromFoldableWith :: forall f a. Foldable f => (a -> a -> a) -> f (Tuple String a) -> StrMap a
fromFoldableWith f l = pureST (do
  s <- SM.new
  for_ l (\(Tuple k v) -> runFn4 _lookupST v (f v) k s >>= SM.poke s k)
  pure s)

foreign import _collect :: forall a b . (String -> a -> b) -> StrMap a -> Array b

-- | Convert a map into a list of key/value pairs
toList :: forall a. StrMap a -> L.List (Tuple String a)
toList = L.fromFoldable <<< _collect Tuple

toUnfoldable :: forall f a. Unfoldable f => StrMap a -> f (Tuple String a)
toUnfoldable = L.toUnfoldable <<< toList

-- | Get an array of the keys in a map
foreign import keys :: forall a. StrMap a -> Array String

-- | Get a list of the values in a map
values :: forall a. StrMap a -> L.List a
values = L.fromFoldable <<< _collect (\_ v -> v)

-- | Compute the union of two maps, preferring the first map in the case of
-- | duplicate keys.
union :: forall a. StrMap a -> StrMap a -> StrMap a
union m = mutate (\s -> void $ foldM SM.poke s m)

-- | Compute the union of a collection of maps
unions :: forall a. L.List (StrMap a) -> StrMap a
unions = foldl union empty

foreign import _mapWithKey :: forall a b. Fn2 (StrMap a) (String -> a -> b) (StrMap b)

-- | Apply a function of two arguments to each key/value pair, producing a new map
mapWithKey :: forall a b. (String -> a -> b) -> StrMap a -> StrMap b
mapWithKey f m = runFn2 _mapWithKey m f

instance semigroupStrMap :: (Semigroup a) => Semigroup (StrMap a) where
  append m1 m2 = mutate (\s1 -> void $ foldM (\s2 k v2 -> SM.poke s2 k (runFn4 _lookup v2 (\v1 -> v1 <> v2) k m2)) s1 m1) m2

instance monoidStrMap :: (Semigroup a) => Monoid (StrMap a) where
  mempty = empty

-- | This module defines a type of native Javascript maps which
-- | require the keys to be strings.
-- |
-- | To maximize performance, Javascript objects are not wrapped,
-- | and some native code is used even when it's not necessary.

module Data.StrMap
  ( StrMap
  , empty
  , isEmpty
  , size
  , singleton
  , insert
  , lookup
  , toList
  , toUnfoldable
  , fromFoldable
  , fromFoldableWith
  , delete
  , pop
  , member
  , alter
  , update
  , mapWithKey
  , keys
  , values
  , union
  , unions
  , isSubmap
  , fold
  , foldMap
  , foldM
  , foldMaybe
  , all
  , thawST
  , freezeST
  , runST
  , pureST
  ) where

import Prelude

import Control.Monad.Eff (Eff, runPure)
import Control.Monad.ST as ST

import Data.Foldable (class Foldable, foldl, foldr, for_)
import Data.Function.Uncurried (Fn2, runFn2, Fn4, runFn4)
import Data.List as L
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.StrMap.ST as SM
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(..), uncurry)
import Data.Unfoldable (class Unfoldable)

-- | `StrMap a` represents a map from `String`s to values of type `a`.
foreign import data StrMap :: * -> *

foreign import _copyEff :: forall a b h r. a -> Eff (st :: ST.ST h | r) b

-- | Convert an immutable map into a mutable map
thawST :: forall a h r. StrMap a -> Eff (st :: ST.ST h | r) (SM.STStrMap h a)
thawST = _copyEff

-- | Convert a mutable map into an immutable map
freezeST :: forall a h r. SM.STStrMap h a -> Eff (st :: ST.ST h | r) (StrMap a)
freezeST = _copyEff

-- | Freeze a mutable map, creating an immutable map. Use this function as you would use
-- | `Prelude.runST` to freeze a mutable reference.
-- |
-- | The rank-2 type prevents the map from escaping the scope of `runST`.
foreign import runST :: forall a r. (forall h. Eff (st :: ST.ST h | r) (SM.STStrMap h a)) -> Eff r (StrMap a)

pureST :: forall a. (forall h e. Eff (st :: ST.ST h | e) (SM.STStrMap h a)) -> StrMap a
pureST f = runPure (runST f)

mutate :: forall a b. (forall h e. SM.STStrMap h a -> Eff (st :: ST.ST h | e) b) -> StrMap a -> StrMap a
mutate f m = pureST (do
  s <- thawST m
  f s
  pure s)

foreign import _fmapStrMap :: forall a b. Fn2 (StrMap a) (a -> b) (StrMap b)

instance functorStrMap :: Functor StrMap where
  map f m = runFn2 _fmapStrMap m f

foreign import _foldM :: forall a m z. (m -> (z -> m) -> m) -> (z -> String -> a -> m) -> m -> StrMap a -> m

-- | Fold the keys and values of a map
fold :: forall a z. (z -> String -> a -> z) -> z -> StrMap a -> z
fold = _foldM ((#))

-- | Fold the keys and values of a map, accumulating values using
-- | some `Monoid`.
foldMap :: forall a m. (Monoid m) => (String -> a -> m) -> StrMap a -> m
foldMap f = fold (\acc k v -> acc <> f k v) mempty

-- | Fold the keys and values of a map, accumulating values and effects in
-- | some `Monad`.
foldM :: forall a m z. (Monad m) => (z -> String -> a -> m z) -> z -> StrMap a -> m z
foldM f z = _foldM (>>=) f (pure z)

instance foldableStrMap :: Foldable StrMap where
  foldl f = fold (\z _ -> f z)
  foldr f z m = foldr f z (values m)
  foldMap f = foldMap (const f)

instance traversableStrMap :: Traversable StrMap where
  traverse f ms = foldr (\x acc -> union <$> x <*> acc) (pure empty) ((map (uncurry singleton)) <$> (traverse f <$> toList ms))
  sequence = traverse id

-- Unfortunately the above are not short-circuitable (consider using purescript-machines)
-- so we need special cases:

foreign import _foldSCStrMap :: forall a z. Fn4 (StrMap a) z (z -> String -> a -> Maybe z) (forall b. b -> Maybe b -> b) z

-- | Fold the keys and values of a map.
-- |
-- | This function allows the folding function to terminate the fold early,
-- | using `Maybe`.
foldMaybe :: forall a z. (z -> String -> a -> Maybe z) -> z -> StrMap a -> z
foldMaybe f z m = runFn4 _foldSCStrMap m z f fromMaybe

-- | Test whether all key/value pairs in a `StrMap` satisfy a predicate.
foreign import all :: forall a. (String -> a -> Boolean) -> StrMap a -> Boolean

instance eqStrMap :: (Eq a) => Eq (StrMap a) where
  eq m1 m2 = (isSubmap m1 m2) && (isSubmap m2 m1)

instance showStrMap :: (Show a) => Show (StrMap a) where
  show m = "fromList " <> show (toList m)

-- | An empty map
foreign import empty :: forall a. StrMap a

-- | Test whether one map contains all of the keys and values contained in another map
isSubmap :: forall a. (Eq a) => StrMap a -> StrMap a -> Boolean
isSubmap m1 m2 = all f m1 where
  f k v = runFn4 _lookup false ((==) v) k m2

-- | Test whether a map is empty
isEmpty :: forall a. StrMap a -> Boolean
isEmpty = all (\_ _ -> false)

-- | Calculate the number of key/value pairs in a map
foreign import size :: forall a. StrMap a -> Number

-- | Create a map with one key/value pair
singleton :: forall a. String -> a -> StrMap a
singleton k v = pureST (do
  s <- SM.new
  SM.poke s k v
  pure s)

foreign import _lookup :: forall a z. Fn4 z (a -> z) String (StrMap a) z

-- | Lookup the value for a key in a map
lookup :: forall a. String -> StrMap a -> Maybe a
lookup = runFn4 _lookup Nothing Just

-- | Test whether a `String` appears as a key in a map
member :: forall a. String -> StrMap a -> Boolean
member = runFn4 _lookup false (const true)

-- | Insert a key and value into a map
insert :: forall a. String -> a -> StrMap a -> StrMap a
insert k v = mutate (\s -> SM.poke s k v)

foreign import _unsafeDeleteStrMap :: forall a. Fn2 (StrMap a) String (StrMap a)

-- | Delete a key and value from a map
delete :: forall a. String -> StrMap a -> StrMap a
delete k = mutate (\s -> SM.delete s k)

-- | Delete a key and value from a map, returning the value
-- | as well as the subsequent map
pop :: forall a. String -> StrMap a -> Maybe (Tuple a (StrMap a))
pop k m = lookup k m <#> \a -> Tuple a (delete k m)

-- | Insert, remove or update a value for a key in a map
alter :: forall a. (Maybe a -> Maybe a) -> String -> StrMap a -> StrMap a
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

-- | Remove or update a value for a key in a map
update :: forall a. (a -> Maybe a) -> String -> StrMap a -> StrMap a
update f k m = alter (maybe Nothing f) k m

-- | Create a map from a foldable collection of key/value pairs
fromFoldable :: forall f a. Foldable f => f (Tuple String a) -> StrMap a
fromFoldable l = pureST (do
  s <- SM.new
  for_ l (\(Tuple k v) -> SM.poke s k v)
  pure s)

foreign import _lookupST :: forall a h r z. Fn4 z (a -> z) String (SM.STStrMap h a) (Eff (st :: ST.ST h | r) z)

-- | Create a map from a foldable collection of key/value pairs, using the
-- | specified function to combine values for duplicate keys.
fromFoldableWith :: forall f a. Foldable f => (a -> a -> a) -> f (Tuple String a) -> StrMap a
fromFoldableWith f l = pureST (do
  s <- SM.new
  for_ l (\(Tuple k v) -> runFn4 _lookupST v (f v) k s >>= SM.poke s k)
  pure s)

foreign import _collect :: forall a b . (String -> a -> b) -> StrMap a -> Array b

-- | Convert a map into a list of key/value pairs
toList :: forall a. StrMap a -> L.List (Tuple String a)
toList = L.fromFoldable <<< _collect Tuple

toUnfoldable :: forall f a. Unfoldable f => StrMap a -> f (Tuple String a)
toUnfoldable = L.toUnfoldable <<< toList

-- | Get an array of the keys in a map
foreign import keys :: forall a. StrMap a -> Array String

-- | Get a list of the values in a map
values :: forall a. StrMap a -> L.List a
values = L.fromFoldable <<< _collect (\_ v -> v)

-- | Compute the union of two maps, preferring the first map in the case of
-- | duplicate keys.
union :: forall a. StrMap a -> StrMap a -> StrMap a
union m = mutate (\s -> foldM SM.poke s m)

-- | Compute the union of a collection of maps
unions :: forall a. L.List (StrMap a) -> StrMap a
unions = foldl union empty

foreign import _mapWithKey :: forall a b. Fn2 (StrMap a) (String -> a -> b) (StrMap b)

-- | Apply a function of two arguments to each key/value pair, producing a new map
mapWithKey :: forall a b. (String -> a -> b) -> StrMap a -> StrMap b
mapWithKey f m = runFn2 _mapWithKey m f

instance semigroupStrMap :: (Semigroup a) => Semigroup (StrMap a) where
  append m1 m2 = mutate (\s1 -> foldM (\s2 k v2 -> SM.poke s2 k (runFn4 _lookup v2 (\v1 -> v1 <> v2) k m2)) s1 m1) m2

instance monoidStrMap :: (Semigroup a) => Monoid (StrMap a) where
  mempty = empty


Hush!

Hush!

module PscIde.Command where

import Prelude

import Control.Alt ((<|>))
import Data.Argonaut (JObject, getField)
import Data.Argonaut.Core (jsonEmptyObject, jsonSingletonObject, jsonNull, Json, toString)
import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.?))
import Data.Argonaut.Encode (class EncodeJson, encodeJson, (~>), (:=))
import Data.Argonaut.Parser (jsonParser)
import Data.Array (singleton)
import Data.Either (Either(..), either, hush)
import Data.Maybe (Maybe(..), maybe)
import Data.String (joinWith)

data PursuitType = Package | Ident

instance showPursuitType :: Show PursuitType where
  show Package = "package"
  show Ident   = "completion"

instance encodePursuitType :: EncodeJson PursuitType where
  encodeJson = encodeJson <<< show

data Matcher =
  Flex String
  | Distance String Int

instance encodeMatcher :: EncodeJson Matcher where
  encodeJson (Flex q) =
    "matcher" := "flex"
    ~> "params" := (jsonSingletonObject' "search" q)
    ~> jsonEmptyObject
  encodeJson (Distance q maxDist) =
    "matcher" := "distance"
    ~> "params" := (
       "search" := q
       ~> "maximumDistance" := maxDist
       ~> jsonEmptyObject
      )
    ~> jsonEmptyObject

data Filter =
  ExactFilter String
  | PrefixFilter String
  | ModuleFilter (Array String)
  | DependencyFilter (Array String)

filterWrapper :: forall a. (EncodeJson a) => String -> a -> Json
filterWrapper f q =
  "filter" := f
  ~> ("params" := q)
  ~> jsonEmptyObject

jsonSingletonObject' :: forall a. (EncodeJson a) => String -> a -> Json
jsonSingletonObject' s o = jsonSingletonObject s (encodeJson o)

instance encodeFilter :: EncodeJson Filter where
  encodeJson (ExactFilter q) =
    filterWrapper "exact" (jsonSingletonObject' "search" q)
  encodeJson (PrefixFilter q) =
    filterWrapper "prefix" (jsonSingletonObject' "search" q)
  encodeJson (ModuleFilter modules) =
    filterWrapper "modules" (jsonSingletonObject' "modules" modules)
  encodeJson (DependencyFilter deps) =
    filterWrapper "dependencies" (jsonSingletonObject' "modules" deps)

newtype CompletionOptions = CompletionOptions {
  maxResults :: Maybe Int,
  groupReexports :: Boolean
}

instance encodeCompletionOptions :: EncodeJson CompletionOptions where
  encodeJson (CompletionOptions { maxResults, groupReexports }) =
   "maxResults" := encodeMaybeNull maxResults
    ~> "groupReexports" := encodeJson groupReexports
    ~> jsonEmptyObject

data Command =
  Cwd
  | Ls ListType
  | Quit
  | Reset
  | Load (Array String) (Array String)
  | Complete (Array Filter) (Maybe Matcher) (Maybe String) CompletionOptions
  | Pursuit PursuitType String
  | Type String (Array Filter) (Maybe String)
  | AddClause String Boolean
  | CaseSplit String Int Int Boolean String
  | ImportCmd FileName (Maybe FileName) (Array Filter) ImportCommand
  | RebuildCmd String (Maybe FileName)

data ListType = LoadedModules | Imports String | AvailableModules

type FileName = String
data ImportCommand = AddImplicitImport String | AddQualifiedImport String String | AddImport String (Maybe String)

commandWrapper :: forall a. (EncodeJson a) => String -> a -> Json
commandWrapper s o =
  "command" := s
  ~> ("params" := o)
  ~> jsonEmptyObject

instance encodeCommand :: EncodeJson Command where
  encodeJson Cwd = jsonSingletonObject' "command" "cwd"
  encodeJson (Ls LoadedModules) =
    commandWrapper "list" ("type" := "loadedModules" ~> jsonEmptyObject)
  encodeJson (Ls AvailableModules) =
    commandWrapper "list" ("type" := "availableModules" ~> jsonEmptyObject)
  encodeJson (Ls (Imports fp)) =
    commandWrapper "list" ("type" := "import" ~> "file" := fp ~> jsonEmptyObject)
  encodeJson Quit = jsonSingletonObject' "command" "quit"
  encodeJson Reset = jsonSingletonObject' "command" "reset"
  encodeJson (Load modules dependencies) =
    commandWrapper "load" (
      "modules" := (encodeJson modules)
      ~> "dependencies" := (encodeJson dependencies)
      ~> jsonEmptyObject
      )
  encodeJson (Complete filters matcher currentModule options) =
    commandWrapper "complete" (
      "filters" := (encodeJson filters)
      ~> "matcher" := (encodeMaybeNull matcher)
      ~> "currentModule" := (encodeMaybeNull currentModule)
      ~> "options" := (encodeJson options)
      ~> jsonEmptyObject
      )
  encodeJson (Pursuit psType q) =
    commandWrapper "pursuit" (
        "type" := (encodeJson psType)
        ~> "query" := q
        ~> jsonEmptyObject
      )
  encodeJson (Type text filters currentModule) =
    commandWrapper "type" (
        "search" := encodeJson text
        ~> "filters" := (encodeJson filters)
        ~> "currentModule" := (encodeMaybeNull currentModule)
        ~> jsonEmptyObject
      )
  encodeJson (AddClause line annotations) =
    commandWrapper "addClause" (
        "line" := encodeJson line
        ~> "annotations" := encodeJson annotations
        ~> jsonEmptyObject
      )
  encodeJson (CaseSplit line begin end annotations typ) =
    commandWrapper "caseSplit" (
        "line" := encodeJson line
        ~> "begin" := encodeJson begin
        ~> "end" := encodeJson end
        ~> "annotations" := encodeJson annotations
        ~> "type" := encodeJson typ
        ~> jsonEmptyObject
      )
  encodeJson (ImportCmd inFile outFile filters cmd) =
    commandWrapper "import" (
      "file" := encodeJson inFile
      ~> "outfile" := encodeMaybeNull outFile
      ~> "filters" := encodeJson filters
      ~> "importCommand" := encodeJson cmd
      ~> jsonEmptyObject
      )
  encodeJson (RebuildCmd file actualFile) =
    commandWrapper "rebuild" (
      "file" := encodeJson file
      ~> "actualFile" := encodeMaybeNull actualFile
      ~> jsonEmptyObject
      )

encodeMaybeNull :: forall a. (EncodeJson a) => Maybe a -> Json
encodeMaybeNull = maybe jsonNull encodeJson

instance encodeImportCommand :: EncodeJson ImportCommand where
  encodeJson (AddImplicitImport ident) =
    "importCommand" := "addImplicitImport"
    ~> "module" := encodeJson ident
    ~> jsonEmptyObject
  encodeJson (AddQualifiedImport mod qualifier) =
    "importCommand" := "addQualifiedImport"
    ~> "module" := encodeJson mod
    ~> "qualifier" := encodeJson qualifier
    ~> jsonEmptyObject
  encodeJson (AddImport mod qualifier) =
    "importCommand" := "addImport"
    ~> "identifier" := encodeJson mod
    ~> "qualifier" := encodeJson qualifier
    ~> jsonEmptyObject

type Result a = Either String a

type GenCompletion a = {
  type' :: String,
  identifier :: String,
  module' :: String
  | a
}

newtype TypePosition = TypePosition {
  name :: String,
  start :: Position,
  end :: Position
}

newtype TypeInfo = TypeInfo (GenCompletion (
  definedAt :: Maybe TypePosition,
  expandedType :: Maybe String,
  documentation :: Maybe String,
  exportedFrom :: Array String
))
newtype PursuitCompletion = PursuitCompletion {
  type' :: Maybe String,
  identifier :: String,
  module' :: String,
  package :: String,
  text :: String
  }

newtype ModuleList = ModuleList (Array String)
newtype Message = Message String
newtype ImportList = ImportList { moduleName :: Maybe String, imports :: Array Import }
newtype Import = Import
  {
    moduleName :: String,
    importType :: ImportType,
    qualifier  :: Maybe String
  }

type Position = { line :: Int, column :: Int }
type RangePosition = { startLine :: Int, startColumn :: Int, endLine :: Int, endColumn :: Int }

newtype RebuildError =
  RebuildError
  { position :: Maybe RangePosition
  , moduleName :: Maybe String
  , filename :: Maybe String
  , errorCode :: String
  , message :: String
  , errorLink :: String
  , pursIde :: Maybe PursIdeInfo
  , suggestion :: Maybe PscSuggestion
  }

newtype PscSuggestion =
  PscSuggestion
  { replacement :: String
  , replaceRange :: Maybe RangePosition
  }

newtype RebuildResult = RebuildResult (Array RebuildError)

newtype PursIdeInfo =
  PursIdeInfo
  { name :: String
  , completions :: Array TypeInfo
  }

data ImportType = Implicit | Explicit (Array String) | Hiding (Array String)

data ImportResult = SuccessFile Message | SuccessText (Array String) | MultipleResults (Array TypeInfo)

unwrapResponse :: forall a b. DecodeJson a => DecodeJson b => String -> Either String (Either a b)
unwrapResponse s = do
  json <- jsonParser s
  o <- decodeJson json
  resultType <- o .? "resultType"
  case resultType of
    "success" -> do
      result <- o .? "result"
      pure (Right result)
    _ -> do
      result <- o .? "result"
      pure (Left result)

instance decodeMessage :: DecodeJson Message where
  decodeJson json = maybe (Left "Message not string") (Right <<< Message) $ toString json

instance decodeModuleList :: DecodeJson ModuleList where
  decodeJson json = ModuleList <$> decodeJson json

instance decodeTypeInfo :: DecodeJson TypeInfo where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "identifier"
    type' <- o .? "type"
    module' <- o .? "module"
    definedAt <- o `getFieldMaybe` "definedAt"
    expandedType <- o `getFieldMaybe` "expandedType"
    documentation <- o `getFieldMaybe` "documentation"
    -- TODO: Handling both missing/incorrect exportedFrom. Remove this after 0.12
    exportedFrom <- Right $ either (const []) id $ getField o "exportedFrom"
    pure (TypeInfo { identifier, type', module', definedAt, expandedType, documentation, exportedFrom })
    where
    getFieldMaybe :: forall a. (DecodeJson a) => JObject -> String -> Either String (Maybe a)
    getFieldMaybe o f = Right $ either (const Nothing) Just $ getField o f

instance decodeTypePosition :: DecodeJson TypePosition where
  decodeJson json = do
    o <- decodeJson json
    name <- o .? "name"
    start <- o .? "start"
    end <- o .? "end"
    case start, end of
      [sl, sc], [el, ec] ->
        Right (TypePosition { name, start: { line: sl, column: sc }, end: { line: el, column: ec } })
      _, _ -> Left "Start/end should be arrays"

instance decodePursuitCompletion :: DecodeJson PursuitCompletion where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "ident"
    type' <- o .? "type"
    module' <- o .? "module"
    package <- o .? "package"
    text <- o .? "text"
    pure (PursuitCompletion {
      identifier: identifier,
      type': type',
      module': module',
      package: package,
      text: text
      })

instance decodeImportList :: DecodeJson ImportList where
  decodeJson json = decodeObject <|> decodeArray
    where
      decodeObject = do
        o <- decodeJson json
        moduleNameField <- o .? "moduleName"
        moduleName <- decodeModuleNameBug moduleNameField <|> decodeJson moduleNameField
        imports <- o .? "imports"
        pure (ImportList { moduleName: Just moduleName, imports })
      -- TODO: Working around a bug where module Foo.Bar is jsonified as ["Foo", "Bar"] instead of "Foo.Bar"
      decodeModuleNameBug moduleName = joinWith "." <$> decodeJson moduleName
      decodeArray = do
        imports <- decodeJson json
        pure (ImportList { moduleName: Nothing, imports })

instance decodeImport :: DecodeJson Import where
  decodeJson json = do
    o <- decodeJson json
    moduleName <- o .? "module"
    importType <- o .? "importType"
    q <- (Just <$> o .? "qualifier") <|> pure Nothing
    case importType of
      "implicit" -> do
        pure $ Import {moduleName: moduleName, importType: Implicit, qualifier: q}
      "explicit" -> do
        identifiers <- o .? "identifiers"
        pure $ Import {moduleName: moduleName, importType: Explicit identifiers, qualifier: q}
      "hiding"   -> do
        identifiers <- o .? "identifiers"
        pure $ Import {moduleName: moduleName, importType: Hiding identifiers, qualifier: q}
      _ -> Left "unknown importType"

instance decodeImportResult :: DecodeJson ImportResult where
  decodeJson json = do
    (SuccessText <$> decodeJson json)
    <|> (SuccessFile <$> decodeJson json)
    <|> (MultipleResults <$> decodeJson json)
    <|> (Left "Couldn't parse as ImportResult")

instance decodeRebuildError :: DecodeJson RebuildError where
  decodeJson json = do
    o <- decodeJson json
    message <- o .? "message"
    errorCode <- o .? "errorCode"
    errorLink <- o .? "errorLink"
    moduleName <- o .? "moduleName"
    filename <- o .? "filename"
    position <- pure $ hush do
      p <- o .? "position"
      { startLine: _, startColumn: _, endLine: _, endColumn: _ } <$> p .? "startLine" <*> p .? "startColumn" <*> p .? "endLine" <*> p .? "endColumn"
    pursIde <- pure $ hush do
      pio <- o .? "pursIde"
      name <- pio .? "name"
      completions <- pio .? "completions"
      pure $ PursIdeInfo { name, completions }
    suggestion <- pure $ hush do
      so <- o .? "suggestion"
      replacement <- so .? "replacement"
      rr <- so .? "replaceRange"
      replaceRange <- pure $ hush $ { startLine: _, startColumn: _, endLine: _, endColumn: _ } <$> rr .? "startLine" <*> rr .? "startColumn" <*> rr .? "endLine" <*> rr .? "endColumn"
      pure $ PscSuggestion { replacement, replaceRange }
    pure (RebuildError { errorCode, errorLink, moduleName, filename, message, position, pursIde, suggestion })

instance decodeRebuildResult :: DecodeJson RebuildResult where
  decodeJson json = RebuildResult <$> (decodeJson json <|> (singleton <$> decodeJson json))

module PscIde.Command where

import Prelude
import Control.Alt ((<|>))
import Data.Argonaut (JObject, getField)
import Data.Argonaut.Core (jsonEmptyObject, jsonSingletonObject, jsonNull, Json, toString)
import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.?))
import Data.Argonaut.Encode (class EncodeJson, encodeJson, (~>), (:=))
import Data.Argonaut.Parser (jsonParser)
import Data.Array (singleton)
import Data.Either (either, Either(..))
import Data.Maybe (Maybe(..), maybe)
import Data.String (joinWith)

data PursuitType = Package | Ident

instance showPursuitType :: Show PursuitType where
  show Package = "package"
  show Ident   = "completion"

instance encodePursuitType :: EncodeJson PursuitType where
  encodeJson = encodeJson <<< show

data Matcher =
  Flex String
  | Distance String Int

instance encodeMatcher :: EncodeJson Matcher where
  encodeJson (Flex q) =
    "matcher" := "flex"
    ~> "params" := (jsonSingletonObject' "search" q)
    ~> jsonEmptyObject
  encodeJson (Distance q maxDist) =
    "matcher" := "distance"
    ~> "params" := (
       "search" := q
       ~> "maximumDistance" := maxDist
       ~> jsonEmptyObject
      )
    ~> jsonEmptyObject

data Filter =
  ExactFilter String
  | PrefixFilter String
  | ModuleFilter (Array String)
  | DependencyFilter (Array String)

filterWrapper :: forall a. (EncodeJson a) => String -> a -> Json
filterWrapper f q =
  "filter" := f
  ~> ("params" := q)
  ~> jsonEmptyObject

jsonSingletonObject' :: forall a. (EncodeJson a) => String -> a -> Json
jsonSingletonObject' s o = jsonSingletonObject s (encodeJson o)

instance encodeFilter :: EncodeJson Filter where
  encodeJson (ExactFilter q) =
    filterWrapper "exact" (jsonSingletonObject' "search" q)
  encodeJson (PrefixFilter q) =
    filterWrapper "prefix" (jsonSingletonObject' "search" q)
  encodeJson (ModuleFilter modules) =
    filterWrapper "modules" (jsonSingletonObject' "modules" modules)
  encodeJson (DependencyFilter deps) =
    filterWrapper "dependencies" (jsonSingletonObject' "modules" deps)

newtype CompletionOptions = CompletionOptions {
  maxResults :: Maybe Int,
  groupReexports :: Boolean
}

instance encodeCompletionOptions :: EncodeJson CompletionOptions where
  encodeJson (CompletionOptions { maxResults, groupReexports }) =
   "maxResults" := encodeMaybeNull maxResults
    ~> "groupReexports" := encodeJson groupReexports
    ~> jsonEmptyObject

data Command =
  Cwd
  | Ls ListType
  | Quit
  | Reset
  | Load (Array String) (Array String)
  | Complete (Array Filter) (Maybe Matcher) (Maybe String) CompletionOptions
  | Pursuit PursuitType String
  | Type String (Array Filter) (Maybe String)
  | AddClause String Boolean
  | CaseSplit String Int Int Boolean String
  | ImportCmd FileName (Maybe FileName) (Array Filter) ImportCommand
  | RebuildCmd String (Maybe FileName)

data ListType = LoadedModules | Imports String | AvailableModules

type FileName = String
data ImportCommand = AddImplicitImport String | AddQualifiedImport String String | AddImport String (Maybe String)

commandWrapper :: forall a. (EncodeJson a) => String -> a -> Json
commandWrapper s o =
  "command" := s
  ~> ("params" := o)
  ~> jsonEmptyObject

instance encodeCommand :: EncodeJson Command where
  encodeJson Cwd = jsonSingletonObject' "command" "cwd"
  encodeJson (Ls LoadedModules) =
    commandWrapper "list" ("type" := "loadedModules" ~> jsonEmptyObject)
  encodeJson (Ls AvailableModules) =
    commandWrapper "list" ("type" := "availableModules" ~> jsonEmptyObject)
  encodeJson (Ls (Imports fp)) =
    commandWrapper "list" ("type" := "import" ~> "file" := fp ~> jsonEmptyObject)
  encodeJson Quit = jsonSingletonObject' "command" "quit"
  encodeJson Reset = jsonSingletonObject' "command" "reset"
  encodeJson (Load modules dependencies) =
    commandWrapper "load" (
      "modules" := (encodeJson modules)
      ~> "dependencies" := (encodeJson dependencies)
      ~> jsonEmptyObject
      )
  encodeJson (Complete filters matcher currentModule options) =
    commandWrapper "complete" (
      "filters" := (encodeJson filters)
      ~> "matcher" := (encodeMaybeNull matcher)
      ~> "currentModule" := (encodeMaybeNull currentModule)
      ~> "options" := (encodeJson options)
      ~> jsonEmptyObject
      )
  encodeJson (Pursuit psType q) =
    commandWrapper "pursuit" (
        "type" := (encodeJson psType)
        ~> "query" := q
        ~> jsonEmptyObject
      )
  encodeJson (Type text filters currentModule) =
    commandWrapper "type" (
        "search" := encodeJson text
        ~> "filters" := (encodeJson filters)
        ~> "currentModule" := (encodeMaybeNull currentModule)
        ~> jsonEmptyObject
      )
  encodeJson (AddClause line annotations) =
    commandWrapper "addClause" (
        "line" := encodeJson line
        ~> "annotations" := encodeJson annotations
        ~> jsonEmptyObject
      )
  encodeJson (CaseSplit line begin end annotations typ) =
    commandWrapper "caseSplit" (
        "line" := encodeJson line
        ~> "begin" := encodeJson begin
        ~> "end" := encodeJson end
        ~> "annotations" := encodeJson annotations
        ~> "type" := encodeJson typ
        ~> jsonEmptyObject
      )
  encodeJson (ImportCmd inFile outFile filters cmd) =
    commandWrapper "import" (
      "file" := encodeJson inFile
      ~> "outfile" := encodeMaybeNull outFile
      ~> "filters" := encodeJson filters
      ~> "importCommand" := encodeJson cmd
      ~> jsonEmptyObject
      )
  encodeJson (RebuildCmd file actualFile) =
    commandWrapper "rebuild" (
      "file" := encodeJson file
      ~> "actualFile" := encodeMaybeNull actualFile
      ~> jsonEmptyObject
      )

encodeMaybeNull :: forall a. (EncodeJson a) => Maybe a -> Json
encodeMaybeNull = maybe jsonNull encodeJson

instance encodeImportCommand :: EncodeJson ImportCommand where
  encodeJson (AddImplicitImport ident) =
    "importCommand" := "addImplicitImport"
    ~> "module" := encodeJson ident
    ~> jsonEmptyObject
  encodeJson (AddQualifiedImport mod qualifier) =
    "importCommand" := "addQualifiedImport"
    ~> "module" := encodeJson mod
    ~> "qualifier" := encodeJson qualifier
    ~> jsonEmptyObject
  encodeJson (AddImport mod qualifier) =
    "importCommand" := "addImport"
    ~> "identifier" := encodeJson mod
    ~> "qualifier" := encodeJson qualifier
    ~> jsonEmptyObject

type Result a = Either String a

type GenCompletion a = {
  type' :: String,
  identifier :: String,
  module' :: String
  | a
}

newtype TypePosition = TypePosition {
  name :: String,
  start :: Position,
  end :: Position
}

newtype TypeInfo = TypeInfo (GenCompletion (
  definedAt :: Maybe TypePosition,
  expandedType :: Maybe String,
  documentation :: Maybe String,
  exportedFrom :: Array String
))
newtype PursuitCompletion = PursuitCompletion {
  type' :: Maybe String,
  identifier :: String,
  module' :: String,
  package :: String,
  text :: String
  }

newtype ModuleList = ModuleList (Array String)
newtype Message = Message String
newtype ImportList = ImportList { moduleName :: Maybe String, imports :: Array Import }
newtype Import = Import
  {
    moduleName :: String,
    importType :: ImportType,
    qualifier  :: Maybe String
  }

type Position = { line :: Int, column :: Int }
type RangePosition = { startLine :: Int, startColumn :: Int, endLine :: Int, endColumn :: Int }

newtype RebuildError =
  RebuildError
  { position :: Maybe RangePosition
  , moduleName :: Maybe String
  , filename :: Maybe String
  , errorCode :: String
  , message :: String
  , errorLink :: String
  , pursIde :: Maybe PursIdeInfo
  , suggestion :: Maybe PscSuggestion
  }

newtype PscSuggestion =
  PscSuggestion
  { replacement :: String
  , replaceRange :: Maybe RangePosition
  }

newtype RebuildResult = RebuildResult (Array RebuildError)

newtype PursIdeInfo =
  PursIdeInfo
  { name :: String
  , completions :: Array TypeInfo
  }

data ImportType = Implicit | Explicit (Array String) | Hiding (Array String)

data ImportResult = SuccessFile Message | SuccessText (Array String) | MultipleResults (Array TypeInfo)

unwrapResponse :: forall a b. DecodeJson a => DecodeJson b => String -> Either String (Either a b)
unwrapResponse s = do
  json <- jsonParser s
  o <- decodeJson json
  resultType <- o .? "resultType"
  case resultType of
    "success" -> do
      result <- o .? "result"
      pure (Right result)
    _ -> do
      result <- o .? "result"
      pure (Left result)

instance decodeMessage :: DecodeJson Message where
  decodeJson json = maybe (Left "Message not string") (Right <<< Message) $ toString json

instance decodeModuleList :: DecodeJson ModuleList where
  decodeJson json = ModuleList <$> decodeJson json

instance decodeTypeInfo :: DecodeJson TypeInfo where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "identifier"
    type' <- o .? "type"
    module' <- o .? "module"
    definedAt <- o `getFieldMaybe` "definedAt"
    expandedType <- o `getFieldMaybe` "expandedType"
    documentation <- o `getFieldMaybe` "documentation"
    -- TODO: Handling both missing/incorrect exportedFrom. Remove this after 0.12
    exportedFrom <- Right $ either (const []) id $ getField o "exportedFrom"
    pure (TypeInfo { identifier, type', module', definedAt, expandedType, documentation, exportedFrom })
    where
    getFieldMaybe :: forall a. (DecodeJson a) => JObject -> String -> Either String (Maybe a)
    getFieldMaybe o f = Right $ either (const Nothing) Just $ getField o f

instance decodeTypePosition :: DecodeJson TypePosition where
  decodeJson json = do
    o <- decodeJson json
    name <- o .? "name"
    start <- o .? "start"
    end <- o .? "end"
    case start, end of
      [sl, sc], [el, ec] ->
        Right (TypePosition { name, start: { line: sl, column: sc }, end: { line: el, column: ec } })
      _, _ -> Left "Start/end should be arrays"

instance decodePursuitCompletion :: DecodeJson PursuitCompletion where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "ident"
    type' <- o .? "type"
    module' <- o .? "module"
    package <- o .? "package"
    text <- o .? "text"
    pure (PursuitCompletion {
      identifier: identifier,
      type': type',
      module': module',
      package: package,
      text: text
      })

instance decodeImportList :: DecodeJson ImportList where
  decodeJson json = decodeObject <|> decodeArray
    where
      decodeObject = do
        o <- decodeJson json
        moduleNameField <- o .? "moduleName"
        moduleName <- decodeModuleNameBug moduleNameField <|> decodeJson moduleNameField
        imports <- o .? "imports"
        pure (ImportList { moduleName: Just moduleName, imports })
      -- TODO: Working around a bug where module Foo.Bar is jsonified as ["Foo", "Bar"] instead of "Foo.Bar"
      decodeModuleNameBug moduleName = joinWith "." <$> decodeJson moduleName
      decodeArray = do
        imports <- decodeJson json
        pure (ImportList { moduleName: Nothing, imports })

instance decodeImport :: DecodeJson Import where
  decodeJson json = do
    o <- decodeJson json
    moduleName <- o .? "module"
    importType <- o .? "importType"
    q <- (Just <$> o .? "qualifier") <|> pure Nothing
    case importType of
      "implicit" -> do
        pure $ Import {moduleName: moduleName, importType: Implicit, qualifier: q}
      "explicit" -> do
        identifiers <- o .? "identifiers"
        pure $ Import {moduleName: moduleName, importType: Explicit identifiers, qualifier: q}
      "hiding"   -> do
        identifiers <- o .? "identifiers"
        pure $ Import {moduleName: moduleName, importType: Hiding identifiers, qualifier: q}
      _ -> Left "unknown importType"

instance decodeImportResult :: DecodeJson ImportResult where
  decodeJson json = do
    (SuccessText <$> decodeJson json)
    <|> (SuccessFile <$> decodeJson json)
    <|> (MultipleResults <$> decodeJson json)
    <|> (Left "Couldn't parse as ImportResult")

instance decodeRebuildError :: DecodeJson RebuildError where
  decodeJson json = do
    o <- decodeJson json
    message <- o .? "message"
    errorCode <- o .? "errorCode"
    errorLink <- o .? "errorLink"
    moduleName <- o .? "moduleName"
    filename <- o .? "filename"
    position <- pure $ eitherToMaybe do
      p <- o .? "position"
      { startLine: _, startColumn: _, endLine: _, endColumn: _ } <$> p .? "startLine" <*> p .? "startColumn" <*> p .? "endLine" <*> p .? "endColumn"
    pursIde <- pure $ eitherToMaybe do
      pio <- o .? "pursIde"
      name <- pio .? "name"
      completions <- pio .? "completions"
      pure $ PursIdeInfo { name, completions }
    suggestion <- pure $ eitherToMaybe do
      so <- o .? "suggestion"
      replacement <- so .? "replacement"
      rr <- so .? "replaceRange"
      replaceRange <- pure $ eitherToMaybe $ { startLine: _, startColumn: _, endLine: _, endColumn: _ } <$> rr .? "startLine" <*> rr .? "startColumn" <*> rr .? "endLine" <*> rr .? "endColumn"
      pure $ PscSuggestion { replacement, replaceRange }
    pure (RebuildError { errorCode, errorLink, moduleName, filename, message, position, pursIde, suggestion })
    where
    eitherToMaybe :: forall a b. Either a b -> Maybe b
    eitherToMaybe = either (const Nothing) Just

instance decodeRebuildResult :: DecodeJson RebuildResult where
  decodeJson json = RebuildResult <$> (decodeJson json <|> (singleton <$> decodeJson json))


Fix SQL^2 input in mount dialog

Fix SQL^2 input in mount dialog

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.FileSystem.Dialog.Mount.SQL2.Component
  ( comp
  , Query
  , module SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery
  , module SlamData.FileSystem.Dialog.Mount.SQL2.Component.State
  ) where

import SlamData.Prelude

import Data.Array (filter)
import Data.Path.Pathy as Pt
import Data.StrMap as Sm

import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Halogen.Component (AceQuery(..), Autocomplete(..), aceComponent)
import Ace.Types (Editor)

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Elements.Keyed as HHEK

import SlamData.Monad (Slam)
import SlamData.FileSystem.Dialog.Mount.Common.Render (propList, section)
import SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery (SettingsQuery(..), SettingsMessage(..))
import SlamData.FileSystem.Dialog.Mount.SQL2.Component.State (State, _initialQuery, _vars, emptyVar, initialState, isEmptyVar, processState, rxEmpty, stateFromViewInfo)
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Query as API

type Query = SettingsQuery State

comp ∷ H.Component HH.HTML Query Unit SettingsMessage Slam
comp =
  H.parentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ State → H.ParentHTML Query AceQuery Unit Slam
render state@{ initialQuery } =
  HHEK.div_
    [ "mount-sql2-query" × section "SQL² query"
        [ HH.slot
            unit
            (aceComponent (aceSetup initialQuery) (Just Live))
            unit
            (const (Just (H.action (ModifyState id))))
        ]
    , "mount-sql2-vars" × section "Query variables" [ propList _vars state ]
    ]

eval ∷ Query ~> H.ParentDSL State Query AceQuery Unit SettingsMessage Slam
eval (ModifyState f next) = do
  H.modify (processState <<< f)
  H.raise Modified
  pure next
eval (Validate k) = do
  sql ← fromMaybe "" <$> H.query unit (H.request GetText)
  pure $ k if sql == "" then Just "Please enter a query" else Nothing
eval (Submit parent name k) = do
  sql ← fromMaybe "" <$> H.query unit (H.request GetText)
  vars ← Sm.fromFoldable <<< filter (not isEmptyVar) <$> H.gets _.vars
  let destPath = parent Pt.</> Pt.file name
      view = R.View $ destPath
      dest = R.Mount view
  result ← API.viewQuery (Left parent) destPath sql vars
  pure $ k $ map (const view) result

aceSetup ∷ Maybe String → Editor → Slam Unit
aceSetup initialQuery editor = H.liftEff do
  Editor.setMinLines 6 editor
  Editor.setMaxLines 10000 editor
  Editor.setAutoScrollEditorIntoView true editor
  Editor.setTheme "ace/theme/chrome" editor
  Editor.setEnableLiveAutocompletion true editor
  Editor.setEnableBasicAutocompletion true editor
  session ← Editor.getSession editor
  Session.setMode "ace/mode/sql" session
  case initialQuery of
    Just q → void $ Editor.setValue q Nothing editor
    Nothing → pure unit

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.FileSystem.Dialog.Mount.SQL2.Component
  ( comp
  , Query
  , module SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery
  , module SlamData.FileSystem.Dialog.Mount.SQL2.Component.State
  ) where

import SlamData.Prelude

import Data.Array (filter)
import Data.Path.Pathy as Pt
import Data.StrMap as Sm

import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Halogen.Component (AceQuery(..), Autocomplete(..), aceComponent)
import Ace.Types (Editor)

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Elements.Keyed as HHEK

import SlamData.Monad (Slam)
import SlamData.FileSystem.Dialog.Mount.Common.Render (propList, section)
import SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery (SettingsQuery(..), SettingsMessage(..))
import SlamData.FileSystem.Dialog.Mount.SQL2.Component.State (State, _initialQuery, _vars, emptyVar, initialState, isEmptyVar, processState, rxEmpty, stateFromViewInfo)
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Query as API

type Query = SettingsQuery State

comp ∷ H.Component HH.HTML Query Unit SettingsMessage Slam
comp =
  H.parentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ State → H.ParentHTML Query AceQuery Unit Slam
render state@{ initialQuery } =
  HHEK.div_
    [ "mount-sql2" × section "SQL² query"
        [ HH.slot
            unit
            (aceComponent (aceSetup initialQuery) (Just Live))
            unit
            (const (Just (H.action (ModifyState id))))
        ]
    , "mount-sql2" × section "Query variables" [ propList _vars state ]
    ]

eval ∷ Query ~> H.ParentDSL State Query AceQuery Unit SettingsMessage Slam
eval (ModifyState f next) = do
  H.modify (processState <<< f)
  H.raise Modified
  pure next
eval (Validate k) = do
  sql ← fromMaybe "" <$> H.query unit (H.request GetText)
  pure $ k if sql == "" then Just "Please enter a query" else Nothing
eval (Submit parent name k) = do
  sql ← fromMaybe "" <$> H.query unit (H.request GetText)
  vars ← Sm.fromFoldable <<< filter (not isEmptyVar) <$> H.gets _.vars
  let destPath = parent Pt.</> Pt.file name
      view = R.View $ destPath
      dest = R.Mount view
  result ← API.viewQuery (Left parent) destPath sql vars
  pure $ k $ map (const view) result

aceSetup ∷ Maybe String → Editor → Slam Unit
aceSetup initialQuery editor = H.liftEff do
  Editor.setMinLines 6 editor
  Editor.setMaxLines 10000 editor
  Editor.setAutoScrollEditorIntoView true editor
  Editor.setTheme "ace/theme/chrome" editor
  Editor.setEnableLiveAutocompletion true editor
  Editor.setEnableBasicAutocompletion true editor
  session ← Editor.getSession editor
  Session.setMode "ace/mode/sql" session
  case initialQuery of
    Just q → void $ Editor.setValue q Nothing editor
    Nothing → pure unit


rename fromCategory

rename fromCategory

module Projections where

import Prelude (Unit, class Semigroup)
import Control.Monad.Eff (Eff, kind Effect)

data EventSource = FromStream String | FromAll | ForEachInCategory String | FromStreams (Array String)

fromStream :: String -> EventSource
fromStream streamname = FromStream streamname

fromAll :: EventSource
fromAll = FromAll

fromCategory :: String -> EventSource
fromCategory category = ForEachInCategory category

fromStreams :: Array String -> EventSource
fromStreams streams = FromStreams streams

foreign import data Projection :: Effect
foreign import data FoldE :: Type -> Type

foreign import runProjection :: forall s eff. EventSource -> s -> FoldE s -> Eff (eventFold :: Projection | eff) Unit

foreign import when :: forall e s. String -> (s -> e -> s) -> FoldE s

foreign import foreignAppend :: forall s. FoldE s -> FoldE s -> FoldE s

foreign import whenAny :: forall e s. (s -> e -> s) -> FoldE s

instance semigroupFoldE :: Semigroup (FoldE s) where
append = foreignAppend

module Projections where

import Prelude (Unit, class Semigroup)
import Control.Monad.Eff (Eff, kind Effect)

data EventSource = FromStream String | FromAll | ForEachInCategory String | FromStreams (Array String)

fromStream :: String -> EventSource
fromStream streamname = FromStream streamname

fromAll :: EventSource
fromAll = FromAll

forEachInCategory :: String -> EventSource
forEachInCategory category = ForEachInCategory category

fromStreams :: Array String -> EventSource
fromStreams streams = FromStreams streams

foreign import data Projection :: Effect
foreign import data FoldE :: Type -> Type

foreign import runProjection :: forall s eff. EventSource -> s -> FoldE s -> Eff (eventFold :: Projection | eff) Unit

foreign import when :: forall e s. String -> (s -> e -> s) -> FoldE s

foreign import foreignAppend :: forall s. FoldE s -> FoldE s -> FoldE s

foreign import whenAny :: forall e s. (s -> e -> s) -> FoldE s

instance semigroupFoldE :: Semigroup (FoldE s) where
append = foreignAppend