Fix quit command. Fixes #9

Fix quit command. Fixes #9

module IdePurescript.VSCode.Main where

import Prelude
import PscIde as P
import VSCode.Notifications as Notify
import Control.Monad.Aff (Aff, runAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Ref (REF, Ref, readRef, newRef, writeRef)
import Control.Promise (Promise, fromAff)
import Data.Array (uncons, head, length)
import Data.Either (Either, either)
import Data.Foldable (traverse_)
import Data.Function.Eff (EffFn4, EffFn3, EffFn2, EffFn1, runEffFn4, mkEffFn3, mkEffFn2, mkEffFn1)
import Data.Functor ((<$))
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.Nullable (toNullable, Nullable)
import Data.String (trim, null)
import Data.String.Regex (Regex, noFlags, regex, split)
import IdePurescript.Build (Command(Command), build, rebuild)
import IdePurescript.Modules (State, initialModulesState, getQualModule, getUnqualActiveModules, getModulesForFile, getMainModule)
import IdePurescript.PscErrors (PscError(PscError))
import IdePurescript.PscIde (getType, getTypeInfo, getCompletion, loadDeps)
import IdePurescript.PscIdeServer (ServerStartResult(..), startServer, stopServer)
import IdePurescript.Regex (match')
import IdePurescript.VSCode.Assist (addClause, caseSplit)
import IdePurescript.VSCode.Imports (addModuleImportCmd, addIdentImportCmd)
import IdePurescript.VSCode.Types (MainEff)
import Node.Process (lookupEnv)
import PscIde (NET)
import PscIde.Command as Command
import PscIde.Server (findBins, Executable(Executable))
import VSCode.Command (register)
import VSCode.Diagnostic (Diagnostic, mkDiagnostic)
import VSCode.Position (mkPosition, Position)
import VSCode.Range (mkRange)
import VSCode.Location (Location, mkLocation)

ignoreError :: forall a eff. a -> Eff eff Unit
ignoreError _ = pure unit

useEditor :: forall eff. Int -> (Ref State) -> String -> String -> Eff (net :: NET, ref :: REF | eff) Unit
useEditor port modulesStateRef path text = do
  let mainModule = getMainModule text
  case mainModule of
    Just m -> void $ runAff ignoreError ignoreError $ do
      loadDeps port m
      state <- getModulesForFile port path text
      liftEff $ writeRef modulesStateRef state
      pure unit
    Nothing -> pure unit

type GetText eff = Int -> Int -> Int -> Int -> Eff eff String -- TODO eff

moduleRegex :: Either String Regex
moduleRegex = regex """(?:^|[^A-Za-z_.])(?:((?:[A-Z][A-Za-z0-9]*\.)*(?:[A-Z][A-Za-z0-9]*))\.)?([a-zA-Z][a-zA-Z0-9_']*)?$""" noFlags

type Completion =
  { type:: String
  , identifier :: String
  , "module" :: String
  }

getCompletions :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Array Completion))
getCompletions port state line char getTextInRange = do
  line <- getTextInRange line 0 line char
  let getQualifiedModule = (flip getQualModule) state
  let parsed = case match' moduleRegex line of
        Just [ Just _, mod, tok ] | mod /= Nothing || tok /= Nothing ->
          Just { mod: fromMaybe "" mod , token: fromMaybe "" tok}
        _ -> Nothing
  let moduleCompletion = false
  case parsed of
    Just { mod, token } -> fromAff $ do
      -- TODO currentModule
      getCompletion port token Nothing mod moduleCompletion (getUnqualActiveModules state $ Just token) getQualifiedModule
    _ -> fromAff $ pure []

convPosition :: Command.Position -> Position
convPosition { line, column } = mkPosition (line-1) (column-1)

getDefinition :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Nullable Location))
getDefinition port state line char getTextInRange = do
  let beforeRegex = regex "[a-zA-Z_0-9']*$" noFlags
      afterRegex = regex "^[a-zA-Z_0-9']*" noFlags
  textBefore <- getTextInRange line 0    line char
  textAfter  <- getTextInRange line char line (char + 100)
  let word = case { before: match' beforeRegex textBefore, after: match' afterRegex textAfter } of
              { before: Just [Just s], after: Just [Just s'] } -> s<>s'
              _ -> ""
  let prefix = ""
  fromAff $ do
    info <- getTypeInfo port word Nothing prefix (getUnqualActiveModules state $ Just word) (flip getQualModule $ state)
    pure $ toNullable $ case info of
      Just { position: Just (Command.TypePosition { name, start }) } -> Just $ mkLocation name $ convPosition start
      _ -> Nothing

type MarkedString = { language :: String, value :: String }

markedString :: String -> MarkedString
markedString s = { language: "purescript", value: s }

getTooltips :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Nullable MarkedString))
getTooltips port state line char getTextInRange = do
    let beforeRegex = regex "[a-zA-Z_0-9']*$" noFlags
        afterRegex = regex "^[a-zA-Z_0-9']*" noFlags
    textBefore <- getTextInRange line 0    line char
    textAfter  <- getTextInRange line char line (char + 100)
    let word = case { before: match' beforeRegex textBefore, after: match' afterRegex textAfter } of
                { before: Just [Just s], after: Just [Just s'] } -> s<>s'
                _ -> ""
    let prefix = ""
    fromAff do
      -- TODO current module for opened idents
      ty <- getType port word Nothing prefix (getUnqualActiveModules state $ Just word) (flip getQualModule $ state)
      let marked = if null ty then Nothing else Just $ markedString $ word <> " :: " <> ty
      pure $ toNullable marked

data ErrorLevel = Success | Info | Warning | Error
type Notify eff = ErrorLevel -> String -> Eff (MainEff eff) Unit

startServer' :: forall eff. String -> Int -> String -> Notify eff -> Aff (MainEff eff) (Maybe { port:: Int, quit:: Eff (MainEff eff) Unit })
startServer' server port root cb = do
  serverBins <- findBins server
  case head serverBins of
    Nothing -> do
      processPath <- liftEffS $ lookupEnv "PATH"
      liftEffS $ cb Info $ "Couldn't find psc-ide-server, check PATH. Looked for: "
        <> server <> " in PATH: " <> fromMaybe "" processPath
      pure Nothing
    Just (Executable bin _) -> do
      -- TODO: Configure globs
      -- TODO: add port config override
      res <- startServer bin root ["src/**/*.purs", "bower_components/purescript-*/src/**/*.purs"]
      liftEff $ log $ "Resolved psc-ide-server:"
      traverse_ (\(Executable x vv) -> do
        liftEff $ log $ x <> ": " <> fromMaybe "ERROR" vv) serverBins
      liftEff $ when (length serverBins > 1) $ cb Warning $ "Found multiple psc-ide-server executables; using " <> bin

      liftEff $ case res of
        CorrectPath port -> Just { port, quit: pure unit } <$ cb Info "Found existing psc-ide-server with correct path"
        WrongPath port wrongPath -> Nothing <$ (cb Error $ "Found existing psc-ide-server with wrong path: '" <>wrongPath<>"'. Correct, kill or configure a different port, and restart.")
        Started port cp -> do
          cb Success ("Started psc-ide-server on " <> show port)
          pure $ Just { port, quit: void $ runAff (\_ -> pure unit) (\_ -> pure unit) $ stopServer port root cp }
        Closed -> Nothing <$ cb Info "psc-ide-server exited with success code"
        StartError err -> Nothing <$ (cb Error $ "Could not start psc-ide-server process. Check the configured port number is valid.\n" <>err)

  where
    liftEffS :: forall a. Eff (MainEff eff) a -> Aff (MainEff eff) a
    liftEffS = liftEff

toDiagnostic :: Boolean -> PscError -> FileDiagnostic
toDiagnostic isError (PscError { message, filename, position, suggestion }) =
  { filename: fromMaybe "" filename
  , diagnostic: mkDiagnostic (range position) message (if isError then 0 else 1)
  , quickfix: conv suggestion
  }
  where
  range (Just { startLine, startColumn, endLine, endColumn}) =
    mkRange
      (mkPosition (startLine-1) (startColumn-1))
      (mkPosition (endLine-1) (endColumn-1))
  range _ = mkRange (mkPosition 0 0) (mkPosition 0 0)

  -- TODO: Handle suggestion ranges (_)
  conv (Just { replacement }) = { suggest: true, replacement }
  conv _ = { suggest: false, replacement: "" }

type FileDiagnostic =
  { filename :: String
  , diagnostic :: Diagnostic
  , quickfix :: { suggest :: Boolean, replacement :: String }
  }
type VSBuildResult =
  { success:: Boolean
  , diagnostics :: Array FileDiagnostic
  }

quickBuild :: forall eff. Int -> String -> Eff (MainEff eff) (Promise VSBuildResult)
quickBuild port filename = fromAff $ do
  { errors, success } <- rebuild port filename
  liftEff $  log $ "Quick build done: " <> show success
  pure $ { success, diagnostics: toDiagnostic' errors }

toDiagnostic' :: { warnings :: Array PscError, errors :: Array PscError } -> Array FileDiagnostic
toDiagnostic' { warnings, errors } = map (toDiagnostic true) errors <> map (toDiagnostic false) warnings

build' :: forall eff. Notify eff -> String -> String -> Eff (MainEff eff) (Promise VSBuildResult)
build' notify command directory = fromAff $ do
  liftEff $ log "Building"
  let buildCommand = either (const []) (\reg -> (split reg <<< trim) command) (regex "\\s+" noFlags)
  case uncons buildCommand of
    Just { head: cmd, tail: args } -> do
      liftEff $ log "Parsed build command"
      liftEff $ notify Info "Building PureScript"
      res <- build { command: Command cmd args, directory }
      liftEff $ if res.success then notify Success "PureScript build succeeded"
                else notify Warning "PureScript build completed with errors"
      pure $ { success: true, diagnostics: toDiagnostic' res.errors }
    Nothing -> do
      liftEff $ notify Error "Error parsing PureScript build command"
      pure { success: false, diagnostics: [] }

main :: forall eff. Eff (MainEff eff)
  { activate :: EffFn3 (MainEff eff) String Int String (Promise Unit)
  , deactivate :: Eff (MainEff eff) Unit
  , build :: EffFn2 (MainEff eff) String String (Promise VSBuildResult)
  , quickBuild :: EffFn1 (MainEff eff) String (Promise VSBuildResult)
  , updateFile :: EffFn2 (MainEff eff) String String Unit
  , getTooltips :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Nullable MarkedString))
  , getCompletions :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Array Completion))
  , provideDefinition :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Nullable Location))
  }
main = do
  modulesState <- newRef (initialModulesState)
  deactivateRef <- newRef (pure unit :: Eff (MainEff eff) Unit)
  portRef <- newRef 0

  let cmd s f = register ("purescript." <> s) f

  let deactivate :: Eff (MainEff eff) Unit
      deactivate = join (readRef deactivateRef)

  let showError :: Notify eff
      showError level str = case level of
                             Success -> Notify.showInfo str
                             Info -> Notify.showInfo str
                             Warning -> Notify.showWarning str
                             Error -> Notify.showError str

  let liftEffMM :: forall a. Eff (MainEff eff) a -> Aff (MainEff eff) a
      liftEffMM = liftEff
  let initialise server _port root = fromAff do
        -- TODO pass in port just when explicitly defined
        startRes <- startServer' server _port root showError
        case startRes of
          Just { port, quit } -> do
            P.load port [] []
            liftEffMM $ do
              cmd "addImport" $ readRef portRef >>= addModuleImportCmd modulesState
              cmd "addExplicitImport" $ readRef portRef >>= addIdentImportCmd modulesState
              cmd "caseSplit" $ readRef portRef >>= caseSplit
              cmd "addClause" $ readRef portRef >>= addClause
              writeRef deactivateRef quit
              writeRef portRef port
          Nothing -> pure unit

  pure
    {
      activate: mkEffFn3 initialise
    , deactivate: deactivate
    , build: mkEffFn2 $ build' showError
    , quickBuild: mkEffFn1 \fname -> do
        port <- readRef portRef
        quickBuild port fname
    , updateFile: mkEffFn2 $ \fname text -> do
        port <- readRef portRef
        useEditor port modulesState fname text
    , getTooltips: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getTooltips port state line char (runEffFn4 getText)
    , getCompletions: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getCompletions port state line char (runEffFn4 getText)
    , provideDefinition: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getDefinition port state line char (runEffFn4 getText)
    }

module IdePurescript.VSCode.Main where

import Prelude
import PscIde as P
import VSCode.Notifications as Notify
import Control.Monad.Aff (Aff, runAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Ref (REF, Ref, readRef, newRef, writeRef)
import Control.Promise (Promise, fromAff)
import Data.Array (uncons, head, length)
import Data.Either (Either, either)
import Data.Foldable (traverse_)
import Data.Function.Eff (EffFn4, EffFn3, EffFn2, EffFn1, runEffFn4, mkEffFn3, mkEffFn2, mkEffFn1)
import Data.Functor ((<$))
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.Nullable (toNullable, Nullable)
import Data.Posix.Signal (Signal(SIGKILL))
import Data.String (trim, null)
import Data.String.Regex (Regex, noFlags, regex, split)
import IdePurescript.Build (Command(Command), build, rebuild)
import IdePurescript.Modules (State, initialModulesState, getQualModule, getUnqualActiveModules, getModulesForFile, getMainModule)
import IdePurescript.PscErrors (PscError(PscError))
import IdePurescript.PscIde (getType, getTypeInfo, getCompletion, loadDeps)
import IdePurescript.PscIdeServer (ServerStartResult(..), startServer)
import IdePurescript.Regex (match')
import IdePurescript.VSCode.Assist (addClause, caseSplit)
import IdePurescript.VSCode.Imports (addModuleImportCmd, addIdentImportCmd)
import IdePurescript.VSCode.Types (MainEff)
import Node.ChildProcess (kill)
import Node.Process (lookupEnv)
import PscIde (NET)
import PscIde.Command as Command
import PscIde.Server (findBins, Executable(Executable))
import VSCode.Command (register)
import VSCode.Diagnostic (Diagnostic, mkDiagnostic)
import VSCode.Position (mkPosition, Position)
import VSCode.Range (mkRange)
import VSCode.Location (Location, mkLocation)

ignoreError :: forall a eff. a -> Eff eff Unit
ignoreError _ = pure unit

useEditor :: forall eff. Int -> (Ref State) -> String -> String -> Eff (net :: NET, ref :: REF | eff) Unit
useEditor port modulesStateRef path text = do
  let mainModule = getMainModule text
  case mainModule of
    Just m -> void $ runAff ignoreError ignoreError $ do
      loadDeps port m
      state <- getModulesForFile port path text
      liftEff $ writeRef modulesStateRef state
      pure unit
    Nothing -> pure unit

type GetText eff = Int -> Int -> Int -> Int -> Eff eff String -- TODO eff

moduleRegex :: Either String Regex
moduleRegex = regex """(?:^|[^A-Za-z_.])(?:((?:[A-Z][A-Za-z0-9]*\.)*(?:[A-Z][A-Za-z0-9]*))\.)?([a-zA-Z][a-zA-Z0-9_']*)?$""" noFlags

type Completion =
  { type:: String
  , identifier :: String
  , "module" :: String
  }

getCompletions :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Array Completion))
getCompletions port state line char getTextInRange = do
  line <- getTextInRange line 0 line char
  let getQualifiedModule = (flip getQualModule) state
  let parsed = case match' moduleRegex line of
        Just [ Just _, mod, tok ] | mod /= Nothing || tok /= Nothing ->
          Just { mod: fromMaybe "" mod , token: fromMaybe "" tok}
        _ -> Nothing
  let moduleCompletion = false
  case parsed of
    Just { mod, token } -> fromAff $ do
      -- TODO currentModule
      getCompletion port token Nothing mod moduleCompletion (getUnqualActiveModules state $ Just token) getQualifiedModule
    _ -> fromAff $ pure []

convPosition :: Command.Position -> Position
convPosition { line, column } = mkPosition (line-1) (column-1)

getDefinition :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Nullable Location))
getDefinition port state line char getTextInRange = do
  let beforeRegex = regex "[a-zA-Z_0-9']*$" noFlags
      afterRegex = regex "^[a-zA-Z_0-9']*" noFlags
  textBefore <- getTextInRange line 0    line char
  textAfter  <- getTextInRange line char line (char + 100)
  let word = case { before: match' beforeRegex textBefore, after: match' afterRegex textAfter } of
              { before: Just [Just s], after: Just [Just s'] } -> s<>s'
              _ -> ""
  let prefix = ""
  fromAff $ do
    info <- getTypeInfo port word Nothing prefix (getUnqualActiveModules state $ Just word) (flip getQualModule $ state)
    pure $ toNullable $ case info of
      Just { position: Just (Command.TypePosition { name, start }) } -> Just $ mkLocation name $ convPosition start
      _ -> Nothing

type MarkedString = { language :: String, value :: String }

markedString :: String -> MarkedString
markedString s = { language: "purescript", value: s }

getTooltips :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Nullable MarkedString))
getTooltips port state line char getTextInRange = do
    let beforeRegex = regex "[a-zA-Z_0-9']*$" noFlags
        afterRegex = regex "^[a-zA-Z_0-9']*" noFlags
    textBefore <- getTextInRange line 0    line char
    textAfter  <- getTextInRange line char line (char + 100)
    let word = case { before: match' beforeRegex textBefore, after: match' afterRegex textAfter } of
                { before: Just [Just s], after: Just [Just s'] } -> s<>s'
                _ -> ""
    let prefix = ""
    fromAff do
      -- TODO current module for opened idents
      ty <- getType port word Nothing prefix (getUnqualActiveModules state $ Just word) (flip getQualModule $ state)
      let marked = if null ty then Nothing else Just $ markedString $ word <> " :: " <> ty
      pure $ toNullable marked

data ErrorLevel = Success | Info | Warning | Error
type Notify eff = ErrorLevel -> String -> Eff (MainEff eff) Unit

startServer' :: forall eff. String -> Int -> String -> Notify eff -> Aff (MainEff eff) (Maybe { port:: Int, quit:: Eff (MainEff eff) Unit })
startServer' server port root cb = do
  serverBins <- findBins server
  case head serverBins of
    Nothing -> do
      processPath <- liftEffS $ lookupEnv "PATH"
      liftEffS $ cb Info $ "Couldn't find psc-ide-server, check PATH. Looked for: "
        <> server <> " in PATH: " <> fromMaybe "" processPath
      pure Nothing
    Just (Executable bin _) -> do
      -- TODO: Configure globs
      -- TODO: add port config override
      res <- startServer bin root ["src/**/*.purs", "bower_components/purescript-*/src/**/*.purs"]
      liftEff $ log $ "Resolved psc-ide-server:"
      traverse_ (\(Executable x vv) -> do
        liftEff $ log $ x <> ": " <> fromMaybe "ERROR" vv) serverBins
      liftEff $ when (length serverBins > 1) $ cb Warning $ "Found multiple psc-ide-server executables; using " <> bin

      liftEff $ case res of
        CorrectPath port -> Just { port, quit: pure unit } <$ cb Info "Found existing psc-ide-server with correct path"
        WrongPath port wrongPath -> Nothing <$ (cb Error $ "Found existing psc-ide-server with wrong path: '" <>wrongPath<>"'. Correct, kill or configure a different port, and restart.")
        Started port cp -> Just { port, quit: void $ kill SIGKILL cp } <$ cb Success ("Started psc-ide-server on " <> show port)
        Closed -> Nothing <$ cb Info "psc-ide-server exited with success code"
        StartError err -> Nothing <$ (cb Error $ "Could not start psc-ide-server process. Check the configured port number is valid.\n" <>err)

  where
    liftEffS :: forall a. Eff (MainEff eff) a -> Aff (MainEff eff) a
    liftEffS = liftEff

toDiagnostic :: Boolean -> PscError -> FileDiagnostic
toDiagnostic isError (PscError { message, filename, position, suggestion }) =
  { filename: fromMaybe "" filename
  , diagnostic: mkDiagnostic (range position) message (if isError then 0 else 1)
  , quickfix: conv suggestion
  }
  where
  range (Just { startLine, startColumn, endLine, endColumn}) =
    mkRange
      (mkPosition (startLine-1) (startColumn-1))
      (mkPosition (endLine-1) (endColumn-1))
  range _ = mkRange (mkPosition 0 0) (mkPosition 0 0)

  -- TODO: Handle suggestion ranges (_)
  conv (Just { replacement }) = { suggest: true, replacement }
  conv _ = { suggest: false, replacement: "" }

type FileDiagnostic =
  { filename :: String
  , diagnostic :: Diagnostic
  , quickfix :: { suggest :: Boolean, replacement :: String }
  }
type VSBuildResult =
  { success:: Boolean
  , diagnostics :: Array FileDiagnostic
  }

quickBuild :: forall eff. Int -> String -> Eff (MainEff eff) (Promise VSBuildResult)
quickBuild port filename = fromAff $ do
  { errors, success } <- rebuild port filename
  liftEff $  log $ "Quick build done: " <> show success
  pure $ { success, diagnostics: toDiagnostic' errors }

toDiagnostic' :: { warnings :: Array PscError, errors :: Array PscError } -> Array FileDiagnostic
toDiagnostic' { warnings, errors } = map (toDiagnostic true) errors <> map (toDiagnostic false) warnings

build' :: forall eff. Notify eff -> String -> String -> Eff (MainEff eff) (Promise VSBuildResult)
build' notify command directory = fromAff $ do
  liftEff $ log "Building"
  let buildCommand = either (const []) (\reg -> (split reg <<< trim) command) (regex "\\s+" noFlags)
  case uncons buildCommand of
    Just { head: cmd, tail: args } -> do
      liftEff $ log "Parsed build command"
      liftEff $ notify Info "Building PureScript"
      res <- build { command: Command cmd args, directory }
      liftEff $ if res.success then notify Success "PureScript build succeeded"
                else notify Warning "PureScript build completed with errors"
      pure $ { success: true, diagnostics: toDiagnostic' res.errors }
    Nothing -> do
      liftEff $ notify Error "Error parsing PureScript build command"
      pure { success: false, diagnostics: [] }

main :: forall eff. Eff (MainEff eff)
  { activate :: EffFn3 (MainEff eff) String Int String (Promise Unit)
  , deactivate :: Eff (MainEff eff) Unit
  , build :: EffFn2 (MainEff eff) String String (Promise VSBuildResult)
  , quickBuild :: EffFn1 (MainEff eff) String (Promise VSBuildResult)
  , updateFile :: EffFn2 (MainEff eff) String String Unit
  , getTooltips :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Nullable MarkedString))
  , getCompletions :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Array Completion))
  , provideDefinition :: EffFn3 (MainEff eff) Int Int (EffFn4 (MainEff eff) Int Int Int Int String) (Promise (Nullable Location))
  }
main = do
  modulesState <- newRef (initialModulesState)
  deactivateRef <- newRef (pure unit :: Eff (MainEff eff) Unit)
  portRef <- newRef 0

  let cmd s f = register ("purescript." <> s) f

  let deactivate :: Eff (MainEff eff) Unit
      deactivate = join (readRef deactivateRef)

  let showError :: Notify eff
      showError level str = case level of
                             Success -> Notify.showInfo str
                             Info -> Notify.showInfo str
                             Warning -> Notify.showWarning str
                             Error -> Notify.showError str

  let liftEffMM :: forall a. Eff (MainEff eff) a -> Aff (MainEff eff) a
      liftEffMM = liftEff
  let initialise server _port root = fromAff do
        -- TODO pass in port just when explicitly defined
        startRes <- startServer' server _port root showError
        case startRes of
          Just { port, quit } -> do
            P.load port [] []
            liftEffMM $ do
              cmd "addImport" $ readRef portRef >>= addModuleImportCmd modulesState
              cmd "addExplicitImport" $ readRef portRef >>= addIdentImportCmd modulesState
              cmd "caseSplit" $ readRef portRef >>= caseSplit
              cmd "addClause" $ readRef portRef >>= addClause
              writeRef deactivateRef quit
              writeRef portRef port
          Nothing -> pure unit

  pure
    {
      activate: mkEffFn3 initialise
    , deactivate: deactivate
    , build: mkEffFn2 $ build' showError
    , quickBuild: mkEffFn1 \fname -> do
        port <- readRef portRef
        quickBuild port fname
    , updateFile: mkEffFn2 $ \fname text -> do
        port <- readRef portRef
        useEditor port modulesState fname text
    , getTooltips: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getTooltips port state line char (runEffFn4 getText)
    , getCompletions: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getCompletions port state line char (runEffFn4 getText)
    , provideDefinition: mkEffFn3 $ \line char getText -> do
        state <- readRef modulesState
        port <- readRef portRef
        getDefinition port state line char (runEffFn4 getText)
    }


Heatmap gen

Heatmap gen

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Setups.Chart.Heatmap.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.Heatmap.Model
  ) where

import SlamData.Prelude

import Color as C

import Data.Argonaut (Json, decodeJson, (.?))
import Data.Array as A
import Data.Foreign as Frn
import Data.Lens ((^?))
import Data.List as L
import Data.Map as M
import Data.Int as Int
import Data.Set as Set

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import SlamData.Workspace.Card.CardType.ChartType (ChartType(Heatmap))
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis as Ax
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors, getColorScheme)
import SlamData.Workspace.Card.Setups.Chart.Common as SCC
import SlamData.Workspace.Card.Setups.Chart.Common.Positioning as BCP
import SlamData.Workspace.Card.Setups.Chart.Common.Tooltip as CCT
import SlamData.Workspace.Card.Setups.Chart.Heatmap.Model (Model, ModelR)
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics as Sem

import SqlSquare as Sql

import Utils.Array (enumerate)

eval ∷ ∀ m. BCE.ChartSetupEval ModelR m
eval = BCE.chartSetupEval (SCC.buildBasicSql buildProjections buildGroupBy) buildPort

type HeatmapSeries =
  { x ∷ Maybe Number
  , y ∷ Maybe Number
  , w ∷ Maybe Number
  , h ∷ Maybe Number
  , name ∷ Maybe String
  , fontSize ∷ Maybe Int
  , items ∷ (String × String) >> Number
  }

type Item =
  { abscissa ∷ String
  , ordinate ∷ String
  , measure ∷ Number
  , series ∷ Maybe String
  }

decodeItem ∷ Json → Either String Item
decodeItem = decodeJson >=> \obj → do
  abscissa ← CCT.formatForeign ∘ jsonToForeign <$> obj .? "abscissa"
  ordinate ← CCT.formatForeign ∘ jsonToForeign <$> obj .? "ordinate"
  measure ← Sem.requiredNumber zero <$> obj .? "measure"
  series ← Sem.maybeString <$> obj .? "series"
  pure { abscissa, ordinate, measure, series }
  where
  jsonToForeign ∷ Json → Frn.Foreign
  jsonToForeign = Frn.toForeign

buildProjections ∷ ModelR → L.List (Sql.Projection Sql.Sql)
buildProjections r = L.fromFoldable
  [ r.abscissa # SCC.jcursorPrj # Sql.as "abscissa"
  , r.ordinate # SCC.jcursorPrj # Sql.as "ordinate"
  , r.value # SCC.jcursorPrj # Sql.as "measure" # SCC.applyTransform r.value
  , r.series # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "series"
  ]

buildGroupBy ∷ ModelR → Maybe (Sql.GroupBy Sql.Sql)
buildGroupBy r =
  SCC.groupBy $ L.fromFoldable $ A.catMaybes
    [ r.series <#> SCC.jcursorSql
    , Just r.abscissa <#> SCC.jcursorSql
    , Just r.ordinate <#> SCC.jcursorSql
    ]

buildPort ∷ ModelR → Ax.Axes → Array Json → Port.Port
buildPort m axes jarr =
  Port.ChartInstructions
    { options: buildOptions axes m $ buildData m jarr
    , chartType: Heatmap
    }

buildData ∷ ModelR → Array Json → Array HeatmapSeries
buildData r =
  foldMap (foldMap A.singleton ∘ decodeItem)
    >>> series
    >>> BCP.adjustRectangularPositions

  where
  series ∷ Array Item → Array HeatmapSeries
  series =
    BCE.groupOn _.series
      >>> map \(name × items) →
            { name
            , x: Nothing
            , y: Nothing
            , w: Nothing
            , h: Nothing
            , fontSize: Nothing
            , items: M.fromFoldable $ toPoint <$> items
            }

  toPoint ∷ Item → (String × String) × Number
  toPoint item = (item.abscissa × item.ordinate) × item.measure

buildOptions ∷ Ax.Axes → ModelR → Array HeatmapSeries → DSL OptionI
buildOptions axes r heatmapSeries = do
  E.tooltip do
    E.triggerAxis
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12
    E.axisPointer do
      E.crossAxisPointer
      E.crossStyle do
        E.color $ C.rgba 170 170 170 0.6
        E.widthNum 0.2
        E.solidLine
    E.formatterItem \item →
      CCT.tableRows
        [ D.jcursorLabel r.abscissa × CCT.formatAssocProp "abscissa" item
        , D.jcursorLabel r.ordinate × CCT.formatAssocProp "ordinate" item
        , D.jcursorLabel r.value × CCT.formatAssocProp "value" item
        ]

  E.animationEnabled false

  BCP.rectangularTitles $ map snd heatmapData

  BCP.rectangularGrids $ map snd heatmapData

  E.xAxes xAxes

  E.yAxes yAxes

  E.colors colors

  E.visualMap $ E.continuous do
    E.min r.minValue
    E.max r.maxValue
    E.calculable true
    E.orient ET.Horizontal
    E.itemWidth 15.0
    E.leftCenter
    E.bottom $ ET.Percent zero
    E.padding zero
    E.inRange $ E.colors
      if r.isColorSchemeReversed
        then A.reverse $ getColorScheme r.colorScheme
        else getColorScheme r.colorScheme

  E.series series

  where
  heatmapData ∷ Array (Int × HeatmapSeries)
  heatmapData = enumerate heatmapSeries

  xValues ∷ HeatmapSeries → Array String
  xValues serie =
    sortX $ A.fromFoldable $ Set.fromFoldable $ map fst $ M.keys serie.items

  yValues ∷ HeatmapSeries → Array String
  yValues serie =
    sortY $ A.fromFoldable $ Set.fromFoldable $ map snd $ M.keys serie.items

  series ∷ ∀ i. DSL (heatMap ∷ ETP.I|i)
  series = for_ heatmapData \(ix × serie) → E.heatMap do
    for_ serie.name E.name
    E.xAxisIndex ix
    E.yAxisIndex ix

    E.buildItems
      $ for_ (enumerate $ xValues serie) \(xIx × abscissa) →
          for_ (enumerate $ yValues serie) \(yIx × ordinate) →
            for_ (M.lookup (abscissa × ordinate) serie.items) \value → E.addItem do
              BCE.assoc { abscissa, ordinate, value }
              E.buildValues do
                E.addValue $ Int.toNumber xIx
                E.addValue $ Int.toNumber yIx
                E.addValue value

  mkAxis ∷ ∀ i. Int → DSL (ETP.AxisI (gridIndex ∷ ETP.I|i))
  mkAxis ix = do
    E.axisType ET.Category
    E.gridIndex ix
    E.axisLabel do
      E.textStyle do
        E.fontFamily "Ubuntu, sans"
    E.axisLine $ E.lineStyle do
      E.width 1
    E.splitLine $ E.lineStyle do
      E.width 1
    E.splitArea E.hidden

  abscissaAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType <$> (r.abscissa ^? D._value ∘ D._projection) <*> pure axes
  ordinateAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType <$> (r.ordinate ^? D._value ∘ D._projection) <*> pure axes

  abscissaAxisCfg = Ax.axisConfiguration abscissaAxisType
  ordinateAxisCfg = Ax.axisConfiguration ordinateAxisType

  xAxes ∷ ∀ i. DSL (addXAxis ∷ ETP.I|i)
  xAxes = for_ heatmapData \(ix × serie) → E.addXAxis do
    mkAxis ix
    E.items $ map ET.strItem $ xValues serie

  yAxes ∷ ∀ i. DSL (addYAxis ∷ ETP.I|i)
  yAxes = for_ heatmapData \(ix × serie) → E.addYAxis do
    mkAxis ix
    E.items $ map ET.strItem $ yValues serie

  sortX ∷ Array String → Array String
  sortX = A.sortBy $ Ax.compareWithAxisType abscissaAxisType

  sortY ∷ Array String → Array String
  sortY = A.sortBy $ Ax.compareWithAxisType ordinateAxisType

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Setups.Chart.Heatmap.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.Heatmap.Model
  ) where

import SlamData.Prelude

import Color as C

import Control.Monad.State (class MonadState)
import Control.Monad.Throw (class MonadThrow)

import Data.Argonaut (JArray, Json)
import Data.Array as A
import Data.Lens ((^?), _Just)
import Data.Map as M
import Data.Int as Int
import Data.Set as Set

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Workspace.Card.CardType.ChartType (ChartType(Heatmap))
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis as Ax
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors, getColorScheme)
import SlamData.Workspace.Card.Setups.Chart.Common.Positioning (adjustRectangularPositions, rectangularGrids, rectangularTitles)
import SlamData.Workspace.Card.Setups.Chart.Common.Tooltip as CCT
import SlamData.Workspace.Card.Setups.Chart.Heatmap.Model (Model, ModelR)
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics (getMaybeString, getValues)
import SlamData.Workspace.Card.Setups.Transform as T
import SlamData.Workspace.Card.Setups.Transform.Aggregation as Ag

import Utils.Array (enumerate)

eval
  ∷ ∀ m
  . ( MonadState CEM.CardState m
    , MonadThrow CEM.CardError m
    , QuasarDSL m
    )
  ⇒ Model
  → Port.Resource
  → m Port.Port
eval m = BCE.buildChartEval Heatmap buildHeatmap m \axes → m

type HeatmapSeries =
  { x ∷ Maybe Number
  , y ∷ Maybe Number
  , w ∷ Maybe Number
  , h ∷ Maybe Number
  , name ∷ Maybe String
  , fontSize ∷ Maybe Int
  , items ∷ (String × String) >> Number
  }

buildHeatmapData ∷ ModelR → JArray → Array HeatmapSeries
buildHeatmapData r records = series
  where
  -- | maybe series >> pair of abscissa and ordinate >> values
  dataMap ∷ Maybe String >> (String × String) >> Array Number
  dataMap =
    foldl dataMapFoldFn M.empty records

  dataMapFoldFn
    ∷ Maybe String >> (String × String) >> Array Number
    → Json
    → Maybe String >> (String × String) >> Array Number
  dataMapFoldFn acc js =
    let
      getMaybeStringFromJson = getMaybeString js
      getValuesFromJson = getValues js
      mbAbscissa =
        getMaybeStringFromJson =<< r.abscissa ^? D._value ∘ D._projection
      mbOrdinate =
        getMaybeStringFromJson =<< r.ordinate ^? D._value ∘ D._projection
    in case mbAbscissa × mbOrdinate of
      (Just abscissaKey) × (Just ordinateKey) →
        let
          mbSeries =
            getMaybeStringFromJson =<< r.series ^? _Just ∘ D._value ∘ D._projection
          values =
            getValuesFromJson $ r.value ^? D._value ∘ D._projection

          alterSeriesFn
            ∷ Maybe ((String × String) >> Array Number)
            → Maybe ((String × String) >> Array Number)
          alterSeriesFn Nothing =
            Just $ M.singleton (abscissaKey × ordinateKey) values
          alterSeriesFn (Just sers) =
            Just $ M.alter alterCoordFn (abscissaKey × ordinateKey) sers

          alterCoordFn
            ∷ Maybe (Array Number)
            → Maybe (Array Number)
          alterCoordFn Nothing = Just values
          alterCoordFn (Just arr) = Just $ arr ⊕ values
        in
          M.alter alterSeriesFn mbSeries acc
      _ → acc

  rawSeries ∷ Array HeatmapSeries
  rawSeries =
    foldMap mkOneSeries $ M.toList dataMap

  mkOneSeries
    ∷ Maybe String × ((String × String) >> Array Number)
    → Array HeatmapSeries
  mkOneSeries (name × items) =
    [{ name
     , x: Nothing
     , y: Nothing
     , w: Nothing
     , h: Nothing
     , fontSize: Nothing
     , items:
         flip map items
           $ Ag.runAggregation
           $ fromMaybe Ag.Sum
           $ r.value ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation
     }]

  series ∷ Array HeatmapSeries
  series = adjustRectangularPositions rawSeries

buildHeatmap ∷ Ax.Axes → ModelR → JArray → DSL OptionI
buildHeatmap axes r records = do
  E.tooltip do
    E.triggerAxis
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12
    E.axisPointer do
      E.crossAxisPointer
      E.crossStyle do
        E.color $ C.rgba 170 170 170 0.6
        E.widthNum 0.2
        E.solidLine
    E.formatterItem \item →
      CCT.tableRows
        [ D.jcursorLabel r.abscissa × CCT.formatAssocProp "abscissa" item
        , D.jcursorLabel r.ordinate × CCT.formatAssocProp "ordinate" item
        , D.jcursorLabel r.value × CCT.formatAssocProp "value" item
        ]

  E.animationEnabled false

  rectangularTitles $ map snd heatmapData

  rectangularGrids $ map snd heatmapData

  E.xAxes xAxes

  E.yAxes yAxes

  E.colors colors

  E.visualMap $ E.continuous do
    E.min r.minValue
    E.max r.maxValue
    E.calculable true
    E.orient ET.Horizontal
    E.itemWidth 15.0
    E.leftCenter
    E.bottom $ ET.Percent zero
    E.padding zero
    E.inRange $ E.colors
      if r.isColorSchemeReversed
        then A.reverse $ getColorScheme r.colorScheme
        else getColorScheme r.colorScheme

  E.series series

  where
  heatmapData ∷ Array (Int × HeatmapSeries)
  heatmapData = enumerate $ buildHeatmapData r records

  xValues ∷ HeatmapSeries → Array String
  xValues serie =
    sortX $ A.fromFoldable $ Set.fromFoldable $ map fst $ M.keys serie.items

  yValues ∷ HeatmapSeries → Array String
  yValues serie =
    sortY $ A.fromFoldable $ Set.fromFoldable $ map snd $ M.keys serie.items

  series ∷ ∀ i. DSL (heatMap ∷ ETP.I|i)
  series = for_ heatmapData \(ix × serie) → E.heatMap do
    for_ serie.name E.name
    E.xAxisIndex ix
    E.yAxisIndex ix

    E.buildItems
      $ for_ (enumerate $ xValues serie) \(xIx × abscissa) →
          for_ (enumerate $ yValues serie) \(yIx × ordinate) →
            for_ (M.lookup (abscissa × ordinate) serie.items) \value → E.addItem do
              BCE.assoc { abscissa, ordinate, value }
              E.buildValues do
                E.addValue $ Int.toNumber xIx
                E.addValue $ Int.toNumber yIx
                E.addValue value

  mkAxis ∷ ∀ i. Int → DSL (ETP.AxisI (gridIndex ∷ ETP.I|i))
  mkAxis ix = do
    E.axisType ET.Category
    E.gridIndex ix
    E.axisLabel do
      E.textStyle do
        E.fontFamily "Ubuntu, sans"
    E.axisLine $ E.lineStyle do
      E.width 1
    E.splitLine $ E.lineStyle do
      E.width 1
    E.splitArea E.hidden

  abscissaAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType <$> (r.abscissa ^? D._value ∘ D._projection) <*> pure axes
  ordinateAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType <$> (r.ordinate ^? D._value ∘ D._projection) <*> pure axes

  abscissaAxisCfg = Ax.axisConfiguration abscissaAxisType
  ordinateAxisCfg = Ax.axisConfiguration ordinateAxisType

  xAxes ∷ ∀ i. DSL (addXAxis ∷ ETP.I|i)
  xAxes = for_ heatmapData \(ix × serie) → E.addXAxis do
    mkAxis ix
    E.items $ map ET.strItem $ xValues serie

  yAxes ∷ ∀ i. DSL (addYAxis ∷ ETP.I|i)
  yAxes = for_ heatmapData \(ix × serie) → E.addYAxis do
    mkAxis ix
    E.items $ map ET.strItem $ yValues serie

  sortX ∷ Array String → Array String
  sortX = A.sortBy $ Ax.compareWithAxisType abscissaAxisType

  sortY ∷ Array String → Array String
  sortY = A.sortBy $ Ax.compareWithAxisType ordinateAxisType


Arb instance for Functors

Arb instance for Functors

module Test.QuickCheck.Functions where

import Control.Monad.Eff.Random.Extras.Unsafe (choice)
import Test.QuickCheck (Arb, arb)
import qualified Data.String as S

-- |
-- Numbers
--

instance arbNumToNum :: Arb (Number -> Number) where
  arb = choice [ \x -> x
               , \x -> x + 1
               , \x -> x - 1
               , \x -> x * x
               , \x -> -x ]

instance showNumToNum :: Show (Number -> Number) where
  show _ = "<Number -> Number>"

-- |
-- Strings
--

instance arbStrToStr :: Arb (String -> String) where
  arb = choice [id, S.toUpper, S.toLower]

instance showStrToStr :: Show (String -> String) where
  show _ = "<String -> String>"

-- |
-- Booleans
--

instance arbBoolToBool :: Arb (Boolean -> Boolean) where
  arb = choice [id, not]

instance showBoolToBool :: Show (Boolean -> Boolean) where
  show _ = "<Boolean -> Boolean>"

-- |
-- Conversions to String
--

instance arbNumToStr :: Arb (Number -> String) where
  arb = return show

instance showNumToStr :: Show (Number -> String) where
  show _ = "<Number -> String>"

instance arbBoolToStr :: Arb (Boolean -> String) where
  arb = return show

instance showBoolToStr :: Show (Boolean -> String) where
  show _ = "<Boolean -> String>"

-- |
-- Conversions to Boolean
--

instance arbNumToBool :: Arb (Number -> Boolean) where
  arb = return $ \x -> (x % 2) == 0

instance showNumToBool :: Show (Number -> Boolean) where
  show _ = "<Number -> Boolean>"

instance arbStrToBool :: Arb (String -> Boolean) where
  arb = return $ \x -> (S.length x) > 0

instance showStrToBool :: Show (String -> Boolean) where
  show _ = "<String -> Boolean>"

-- |
-- Conversions to Number
--

instance arbStrToNum :: Arb (String -> Number) where
  arb = return S.length

instance showStrToNum :: Show (String -> Number) where
  show _ = "<String -> Number>"

instance arbBoolToNum :: Arb (Boolean -> Number) where
  arb = return $ \x -> if x then 1 else 0

instance showBoolToNum :: Show (Boolean -> Number) where
  show _ = "<Boolean -> Number>"

-- |
-- Functors
--

instance arbFmap :: (Functor f, Arb (a -> b)) => Arb (f a -> f b) where
  arb = do
    f <- arb
    return $ (<$>) f

instance showArbFmap :: (Functor f, Arb (a -> b)) => Show (f a -> f b) where
  show _ = "<f a -> f b>"

module Test.QuickCheck.Functions where

import Control.Monad.Eff.Random.Extras.Unsafe (choice)
import Test.QuickCheck (Arb)
import qualified Data.String as S

-- |
-- Numbers
--

instance arbNumToNum :: Arb (Number -> Number) where
  arb = choice [ \x -> x
               , \x -> x + 1
               , \x -> x - 1
               , \x -> x * x
               , \x -> -x ]

instance showNumToNum :: Show (Number -> Number) where
  show _ = "<Number -> Number>"

-- |
-- Strings
--

instance arbStrToStr :: Arb (String -> String) where
  arb = choice [id, S.toUpper, S.toLower]

instance showStrToStr :: Show (String -> String) where
  show _ = "<String -> String>"

-- |
-- Booleans
--

instance arbBoolToBool :: Arb (Boolean -> Boolean) where
  arb = choice [id, not]

instance showBoolToBool :: Show (Boolean -> Boolean) where
  show _ = "<Boolean -> Boolean>"

-- |
-- Conversions to String
--

instance arbNumToStr :: Arb (Number -> String) where
  arb = return show

instance showNumToStr :: Show (Number -> String) where
  show _ = "<Number -> String>"

instance arbBoolToStr :: Arb (Boolean -> String) where
  arb = return show

instance showBoolToStr :: Show (Boolean -> String) where
  show _ = "<Boolean -> String>"

-- |
-- Conversions to Boolean
--

instance arbNumToBool :: Arb (Number -> Boolean) where
  arb = return $ \x -> (x % 2) == 0

instance showNumToBool :: Show (Number -> Boolean) where
  show _ = "<Number -> Boolean>"

instance arbStrToBool :: Arb (String -> Boolean) where
  arb = return $ \x -> (S.length x) > 0

instance showStrToBool :: Show (String -> Boolean) where
  show _ = "<String -> Boolean>"

-- |
-- Conversions to Number
--

instance arbStrToNum :: Arb (String -> Number) where
  arb = return S.length

instance showStrToNum :: Show (String -> Number) where
  show _ = "<String -> Number>"

instance arbBoolToNum :: Arb (Boolean -> Number) where
  arb = return $ \x -> if x then 1 else 0

instance showBoolToNum :: Show (Boolean -> Number) where
  show _ = "<Boolean -> Number>"


Bad import

Bad 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.Workspace.Card.FormInput.LabeledRenderer.Model where

import SlamData.Prelude

import Data.Argonaut ((:=), (.?), (~>))
import Data.Argonaut as J
import Data.Array as Arr
import Data.Set as Set

import SlamData.Workspace.Card.CardType.FormInputType (FormInputType)
import SlamData.Workspace.Card.Setups.Semantics as Sem

import Test.StrongCheck.Gen as Gen
import Test.StrongCheck.Data.Argonaut (runArbJCursor)
import Test.StrongCheck.Arbitrary (arbitrary)

type Model =
  { formInputType ∷ FormInputType
  , selected ∷ Set.Set Sem.Semantics
  , cursor ∷ J.JCursor
  }

eqModel ∷ Model → Model → Boolean
eqModel r1 r2 =
  r1.formInputType ≡ r2.formInputType
  ∧ r1.selected ≡ r2.selected
  ∧ r1.cursor ≡ r2.cursor

genModel ∷ Gen.Gen Model
genModel = do
  formInputmap runArbJCursor arbitraryrary
  cursor ← J.genJCursor
  selected ← map (Set.fromFoldable) $ Gen.arrayOf arbitrary
  pure { cursor
       , selected
       , formInputType
       }

encode ∷ Model → J.Json
encode r =
  "selected" := foldMap Arr.singleton r.selected
  ~> "formInputType" := r.formInputType
  ~> "cursor" := r.cursor
  ~> J.jsonEmptyObject

decode ∷ J.JObject → String ⊹ Model
decode obj = do
  formInputType ← obj .? "formInputType"
  cursor ← obj .? "cursor"
  (selectedArr ∷ Array Sem.Semantics) ← obj .? "selected"
  let
    selected = Set.fromFoldable selectedArr
  pure { formInputType
       , cursor
       , selected
       }

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.FormInput.LabeledRenderer.Model where

import SlamData.Prelude

import Data.Argonaut ((:=), (.?), (~>))
import Data.Argonaut as J
impo
import Data.Array as Arr
import Data.Set as Set

import SlamData.Workspace.Card.CardType.FormInputType (FormInputType)
import SlamData.Workspace.Card.Setups.Semantics as Sem

import Test.StrongCheck.Gen as Gen
import Test.StrongCheck.Data.Argonaut (runArbJCursor)
import Test.StrongCheck.Arbitrary (arbitrary)

type Model =
  { formInputType ∷ FormInputType
  , selected ∷ Set.Set Sem.Semantics
  , cursor ∷ J.JCursor
  }

eqModel ∷ Model → Model → Boolean
eqModel r1 r2 =
  r1.formInputType ≡ r2.formInputType
  ∧ r1.selected ≡ r2.selected
  ∧ r1.cursor ≡ r2.cursor

genModel ∷ Gen.Gen Model
genModel = do
  formInputmap runArbJCursor arbitraryrary
  cursor ← J.genJCursor
  selected ← map (Set.fromFoldable) $ Gen.arrayOf arbitrary
  pure { cursor
       , selected
       , formInputType
       }

encode ∷ Model → J.Json
encode r =
  "selected" := foldMap Arr.singleton r.selected
  ~> "formInputType" := r.formInputType
  ~> "cursor" := r.cursor
  ~> J.jsonEmptyObject

decode ∷ J.JObject → String ⊹ Model
decode obj = do
  formInputType ← obj .? "formInputType"
  cursor ← obj .? "cursor"
  (selectedArr ∷ Array Sem.Semantics) ← obj .? "selected"
  let
    selected = Set.fromFoldable selectedArr
  pure { formInputType
       , cursor
       , selected
       }


[CSM-219] Add client wallet endpoints (wip)

module Daedalus.ClientApi where

import Prelude
import Daedalus.BackendApi as B
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (getProfileLocale, mkCAddress, mkCCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit, mkCWalletRedeem, mkBackupPhrase, mkCInitialized, mkCPaperVendWalletRedeem, mkCPassPhrase, mkCWalletSetInit)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson, decodeJson)
import Data.String.Base64 as B64
import Data.Base58 as B58
import Data.Array as A
import Data.String (length, stripSuffix, Pattern (..))
import Data.Maybe (isJust, maybe)
import Data.Function.Eff (EffFn1, mkEffFn1, EffFn2, mkEffFn2, EffFn4, mkEffFn4, EffFn5, mkEffFn5, EffFn3, mkEffFn3, EffFn6, mkEffFn6, EffFn7, mkEffFn7)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto

--------------------------------------------------------------------------------
-- TEST ------------------------------------------------------------------------

-- | Resets wallet database (metadata) and wallets/keys
-- This should be used only in testing
-- Arguments:
-- Returns:
-- Example in nodejs:
testReset :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
testReset = fromAff B.testReset

--------------------------------------------------------------------------------
-- Wallet Sets ---------------------------------------------------------------------

-- | Gets specified wallet set
-- Arguments: wallet set id/hash
-- Returns json representation of requested wallet set
-- Example in nodejs:
--
getWalletSet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
getWalletSet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWalletSet <<< mkCAddress

-- | Gets all wallet sets
-- Arguments:
-- Returns json representation of all wallet sets
-- Example in nodejs:
--
getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWalletSets

-- | Creates a new wallet set.
-- Arguments: wallet set name, mnemonics, spending password (set to empty string if you don't want to set password)
-- Returns json representation of created wallet set
-- Example in nodejs:
--
newWalletSet :: forall eff . EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String
  (Promise Json)
newWalletSet = mkEffFn3 \wSetName mnemonic spendingPassword -> fromAff <<< map encodeJson <<<
    either throwError (B.newWalletSet $ mkCPassPhrase spendingPassword) $ mkCWalletSetInit wSetName mnemonic

-- TODO: note that restoreWalletSet and newWalletSet are the same. They will be unified in future

-- | Restores a new wallet set.
-- Arguments: wallet set name, mnemonics, spending password (set to empty string if you don't want to set password
-- Returns json representation of restored wallet set
-- Example in nodejs:
--
restoreWalletSet :: forall eff. EffFn3 (ajax :: AJAX | eff) String String String (Promise Json)
restoreWalletSet = mkEffFn3 \wSetName mnemonic spendingPassword -> fromAff <<< map encodeJson <<< either throwError (B.restoreWalletSet $ mkCPassPhrase spendingPassword) $ mkCWalletSetInit wSetName mnemonic

-- | Rename a wallet set.
-- Arguments: wallet set id/hash, name
-- Returns json representation of renamed wallet set
-- Example in nodejs:
--
renameWalletSet :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Json)
renameWalletSet = mkEffFn2 \wSetId name -> fromAff <<< map encodeJson $ B.renameWalletSet (mkCAddress wSetId) name

-- | Import a wallet set.
-- Arguments: file path to the wallet set on a filesystem, spending password (set to empty string if you don't want to set password)
-- Returns json representation of imported wallet set
-- Example in nodejs:
--
importWalletSet :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Json)
importWalletSet = mkEffFn2 \filePath spendingPassword -> fromAff <<< map encodeJson $ B.importWalletSet (mkCPassPhrase spendingPassword) filePath

-- | Rename a wallet set.
-- Arguments: wallet set id/hash, old spending password (set to empty string if there is no password), new spending password (set to empty string if you want to remove password)
-- Returns json representation of renamed wallet set
-- Example in nodejs:
--
changeWalletSetPass :: forall eff. EffFn3 (ajax :: AJAX | eff) String String String (Promise Json)
changeWalletSetPass = mkEffFn3 \wSetId oldPass newPass -> fromAff <<< map encodeJson $ B.changeWalletSetPass (mkCAddress wSetId) (mkCPassPhrase oldPass) (mkCPassPhrase newPass)

--------------------------------------------------------------------------------
-- Wallets ---------------------------------------------------------------------

getWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) Json (Promise Json)
getWallet = mkEffFn1 $ fromAff <<< map encodeJson <<< either (throwError <<< error) B.getWallet <<< decodeJson

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

--
--
-- getLocale :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- getLocale = fromAff $ map encodeJson (getProfileLocale <$> B.getProfile)
--
-- updateLocale :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
-- updateLocale = mkEffFn1 \locale -> fromAff <<< map encodeJson <<< B.updateProfile $ mkCProfile locale
--
-- getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- getWallets = fromAff $ map encodeJson B.getWallets
--
-- getWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
-- getWallet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress
--
-- getHistory :: forall eff. EffFn3 (ajax :: AJAX | eff) String Int Int (Promise Json)
-- getHistory = mkEffFn3 \addr skip limit -> fromAff <<< map encodeJson $
--     B.getHistory
--         (mkCAddress addr)
--         skip
--         limit
--
-- searchHistory :: forall eff. EffFn4 (ajax :: AJAX | eff) String String Int Int (Promise Json)
-- searchHistory = mkEffFn4 \addr search skip limit -> fromAff <<< map encodeJson $
--     B.searchHistory
--         (mkCAddress addr)
--         search
--         skip
--         limit
--
-- send :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
-- send = mkEffFn4 \addrFrom addrTo amount spendingPassword -> fromAff <<< map encodeJson $
--     B.send
--         (mkCPassPhrase spendingPassword)
--         (mkCAddress addrFrom)
--         (mkCAddress addrTo)
--         (mkCCoin amount)
--
-- sendExtended :: forall eff. EffFn7 (ajax :: AJAX | eff) String String String String String String String (Promise Json)
-- sendExtended = mkEffFn7 \addrFrom addrTo amount curr title desc spendingPassword -> fromAff <<< map encodeJson $
--     B.sendExtended
--         (mkCPassPhrase spendingPassword)
--         (mkCAddress addrFrom)
--         (mkCAddress addrTo)
--         (mkCCoin amount)
--         (mkCCurrency curr)
--         title
--         desc
--
-- generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
-- generateMnemonic = Crypto.generateMnemonic
--
-- -- | bip39.validateMnemonic and has at least len words
-- isValidMnemonic :: forall eff. EffFn2 (crypto :: Crypto.CRYPTO | eff) Int String Boolean
-- isValidMnemonic = mkEffFn2 \len -> pure <<< either (const false) (const true) <<< mkBackupPhrase len
--
-- newWallet :: forall eff . EffFn5 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String String String
--   (Promise Json)
-- newWallet = mkEffFn5 \wType wCurrency wName mnemonic spendingPassword -> fromAff <<< map encodeJson <<<
--     either throwError (B.newWallet $ mkCPassPhrase spendingPassword) $ 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. EffFn6 (ajax :: AJAX | eff) String String String String String Int (Promise Json)
-- updateWallet = mkEffFn6 \addr wType wCurrency wName wAssurance wUnit -> fromAff <<< map encodeJson <<<
--     B.updateWallet
--         (mkCAddress addr)
--         $ mkCWalletMeta wType wCurrency wName wAssurance wUnit
--
-- updateTransaction :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Number (Promise Unit)
-- updateTransaction = mkEffFn6 \addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
--     B.updateTransaction
--         (mkCAddress addr)
--         (mkCTxId ctxId)
--         $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate
--
-- deleteWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Unit)
-- deleteWallet = mkEffFn1 $ fromAff <<< B.deleteWallet <<< mkCAddress
--
-- isValidAddress :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Boolean)
-- isValidAddress = mkEffFn2 \currency -> fromAff <<< B.isValidAddress (mkCCurrency currency)
--
-- notify :: forall eff. EffFn2 (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) (NotifyCb eff) (ErrorCb eff) Unit
-- notify = mkEffFn2 \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
--
-- restoreWallet :: forall eff. EffFn5 (ajax :: AJAX | eff) String String String String String (Promise Json)
-- restoreWallet = mkEffFn5 \wType wCurrency wName spendingPassword -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase spendingPassword) <<< mkCWalletInit wType wCurrency wName
--
--
-- nextUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- nextUpdate = fromAff $ map encodeJson B.nextUpdate
--
-- applyUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
-- applyUpdate = fromAff B.applyUpdate
--
-- systemVersion :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- systemVersion = fromAff $ map encodeJson B.systemVersion
--
-- redeemAda :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String (Promise Json)
-- redeemAda = mkEffFn2 \seed -> fromAff <<< map encodeJson <<< B.redeemAda <<< mkCWalletRedeem seed
--
-- redeemAdaPaperVend :: forall eff. EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String (Promise Json)
-- redeemAdaPaperVend = mkEffFn3 \seed mnemonic -> fromAff <<< map encodeJson <<< either throwError B.redeemAdaPaperVend <<< mkCPaperVendWalletRedeem seed mnemonic
--
-- reportInit :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) Int Int (Promise Unit)
-- reportInit = mkEffFn2 \total -> fromAff <<< B.reportInit <<< mkCInitialized total
--
-- importKey :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
-- importKey = mkEffFn1 $ fromAff <<< map encodeJson <<< B.importKey
--
-- syncProgress :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- syncProgress = fromAff $ map encodeJson B.syncProgress
--
-- -- Valid redeem code is base64 encoded 32byte data
-- -- NOTE: this method handles both base64 and base64url base on rfc4648: see more https://github.com/menelaos/purescript-b64/blob/59e2e9189358a4c8e3eef8662ca281906844e783/src/Data/String/Base64.purs#L182
-- isValidRedemptionKey :: String -> Boolean
-- isValidRedemptionKey code = either (const false) (const $ endsWithEqual && 44 == length code) $ B64.decode code
--   where
--     -- Because it is 32byte base64 encoded
--     endsWithEqual = isJust $ stripSuffix (Pattern "=") code
--
-- -- Valid paper vend key is base58 encoded 32byte data
-- isValidPaperVendRedemptionKey :: String -> Boolean
-- isValidPaperVendRedemptionKey code = maybe false ((==) 32 <<< A.length) $ B58.decode code

module Daedalus.ClientApi where

import Prelude
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (getProfileLocale, mkCAddress, mkCCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit, mkCWalletRedeem, mkBackupPhrase, mkCInitialized, mkCPaperVendWalletRedeem, mkCPassPhrase, mkCWalletSetInit)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.String.Base64 as B64
import Data.Base58 as B58
import Data.Array as A
import Data.String (length, stripSuffix, Pattern (..))
import Data.Maybe (isJust, maybe)
import Data.Function.Eff (EffFn1, mkEffFn1, EffFn2, mkEffFn2, EffFn4, mkEffFn4, EffFn5, mkEffFn5, EffFn3, mkEffFn3, EffFn6, mkEffFn6, EffFn7, mkEffFn7)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto

--------------------------------------------------------------------------------
-- TEST ------------------------------------------------------------------------

-- | Resets wallet database (metadata) and wallets/keys
-- This should be used only in testing
-- Arguments:
-- Returns:
-- Example in nodejs:
testReset :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
testReset = fromAff B.testReset

--------------------------------------------------------------------------------
-- Wallet Sets ---------------------------------------------------------------------

-- | Gets specified wallet set
-- Arguments: wallet set id/hash
-- Returns json representation of requested wallet set
-- Example in nodejs:
--
getWalletSet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
getWalletSet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWalletSet <<< mkCAddress

-- | Gets all wallet sets
-- Arguments:
-- Returns json representation of all wallet sets
-- Example in nodejs:
--
getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWalletSets

-- | Creates a new wallet set.
-- Arguments: wallet set name, mnemonics, spending password (set to empty string if you don't want to set password)
-- Returns json representation of created wallet set
-- Example in nodejs:
--
newWalletSet :: forall eff . EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String
  (Promise Json)
newWalletSet = mkEffFn3 \wSetName mnemonic spendingPassword -> fromAff <<< map encodeJson <<<
    either throwError (B.newWalletSet $ mkCPassPhrase spendingPassword) $ mkCWalletSetInit wSetName mnemonic

-- TODO: note that restoreWalletSet and newWalletSet are the same. They will be unified in future

-- | Restores a new wallet set.
-- Arguments: wallet set name, mnemonics, spending password (set to empty string if you don't want to set password
-- Returns json representation of restored wallet set
-- Example in nodejs:
--
restoreWalletSet :: forall eff. EffFn3 (ajax :: AJAX | eff) String String String (Promise Json)
restoreWalletSet = mkEffFn3 \wSetName mnemonic spendingPassword -> fromAff <<< map encodeJson <<< either throwError (B.restoreWalletSet $ mkCPassPhrase spendingPassword) $ mkCWalletSetInit wSetName mnemonic

-- | Rename a wallet set.
-- Arguments: wallet set id/hash, name
-- Returns json representation of renamed wallet set
-- Example in nodejs:
--
renameWalletSet :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Json)
renameWalletSet = mkEffFn2 \wSetId name -> fromAff <<< map encodeJson $ B.renameWalletSet (mkCAddress wSetId) name

-- | Import a wallet set.
-- Arguments: file path to the wallet set on a filesystem, spending password (set to empty string if you don't want to set password)
-- Returns json representation of imported wallet set
-- Example in nodejs:
--
importWalletSet :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Json)
importWalletSet = mkEffFn2 \filePath spendingPassword -> fromAff <<< map encodeJson $ B.importWalletSet (mkCPassPhrase spendingPassword) filePath

-- | Rename a wallet set.
-- Arguments: wallet set id/hash, old spending password (set to empty string if there is no password), new spending password (set to empty string if you want to remove password)
-- Returns json representation of renamed wallet set
-- Example in nodejs:
--
changeWalletSetPass :: forall eff. EffFn3 (ajax :: AJAX | eff) String String String (Promise Json)
changeWalletSetPass = mkEffFn3 \wSetId oldPass newPass -> fromAff <<< map encodeJson $ B.changeWalletSetPass (mkCAddress wSetId) (mkCPassPhrase oldPass) (mkCPassPhrase newPass)

--------------------------------------------------------------------------------
-- Wallets ---------------------------------------------------------------------
--
--
-- getLocale :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- getLocale = fromAff $ map encodeJson (getProfileLocale <$> B.getProfile)
--
-- updateLocale :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
-- updateLocale = mkEffFn1 \locale -> fromAff <<< map encodeJson <<< B.updateProfile $ mkCProfile locale
--
-- getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- getWallets = fromAff $ map encodeJson B.getWallets
--
-- getWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
-- getWallet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress
--
-- getHistory :: forall eff. EffFn3 (ajax :: AJAX | eff) String Int Int (Promise Json)
-- getHistory = mkEffFn3 \addr skip limit -> fromAff <<< map encodeJson $
--     B.getHistory
--         (mkCAddress addr)
--         skip
--         limit
--
-- searchHistory :: forall eff. EffFn4 (ajax :: AJAX | eff) String String Int Int (Promise Json)
-- searchHistory = mkEffFn4 \addr search skip limit -> fromAff <<< map encodeJson $
--     B.searchHistory
--         (mkCAddress addr)
--         search
--         skip
--         limit
--
-- send :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
-- send = mkEffFn4 \addrFrom addrTo amount spendingPassword -> fromAff <<< map encodeJson $
--     B.send
--         (mkCPassPhrase spendingPassword)
--         (mkCAddress addrFrom)
--         (mkCAddress addrTo)
--         (mkCCoin amount)
--
-- sendExtended :: forall eff. EffFn7 (ajax :: AJAX | eff) String String String String String String String (Promise Json)
-- sendExtended = mkEffFn7 \addrFrom addrTo amount curr title desc spendingPassword -> fromAff <<< map encodeJson $
--     B.sendExtended
--         (mkCPassPhrase spendingPassword)
--         (mkCAddress addrFrom)
--         (mkCAddress addrTo)
--         (mkCCoin amount)
--         (mkCCurrency curr)
--         title
--         desc
--
-- generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
-- generateMnemonic = Crypto.generateMnemonic
--
-- -- | bip39.validateMnemonic and has at least len words
-- isValidMnemonic :: forall eff. EffFn2 (crypto :: Crypto.CRYPTO | eff) Int String Boolean
-- isValidMnemonic = mkEffFn2 \len -> pure <<< either (const false) (const true) <<< mkBackupPhrase len
--
-- newWallet :: forall eff . EffFn5 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String String String
--   (Promise Json)
-- newWallet = mkEffFn5 \wType wCurrency wName mnemonic spendingPassword -> fromAff <<< map encodeJson <<<
--     either throwError (B.newWallet $ mkCPassPhrase spendingPassword) $ 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. EffFn6 (ajax :: AJAX | eff) String String String String String Int (Promise Json)
-- updateWallet = mkEffFn6 \addr wType wCurrency wName wAssurance wUnit -> fromAff <<< map encodeJson <<<
--     B.updateWallet
--         (mkCAddress addr)
--         $ mkCWalletMeta wType wCurrency wName wAssurance wUnit
--
-- updateTransaction :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Number (Promise Unit)
-- updateTransaction = mkEffFn6 \addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
--     B.updateTransaction
--         (mkCAddress addr)
--         (mkCTxId ctxId)
--         $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate
--
-- deleteWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Unit)
-- deleteWallet = mkEffFn1 $ fromAff <<< B.deleteWallet <<< mkCAddress
--
-- isValidAddress :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Boolean)
-- isValidAddress = mkEffFn2 \currency -> fromAff <<< B.isValidAddress (mkCCurrency currency)
--
-- notify :: forall eff. EffFn2 (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) (NotifyCb eff) (ErrorCb eff) Unit
-- notify = mkEffFn2 \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
--
-- restoreWallet :: forall eff. EffFn5 (ajax :: AJAX | eff) String String String String String (Promise Json)
-- restoreWallet = mkEffFn5 \wType wCurrency wName spendingPassword -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase spendingPassword) <<< mkCWalletInit wType wCurrency wName
--
--
-- nextUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- nextUpdate = fromAff $ map encodeJson B.nextUpdate
--
-- applyUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
-- applyUpdate = fromAff B.applyUpdate
--
-- systemVersion :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- systemVersion = fromAff $ map encodeJson B.systemVersion
--
-- redeemAda :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String (Promise Json)
-- redeemAda = mkEffFn2 \seed -> fromAff <<< map encodeJson <<< B.redeemAda <<< mkCWalletRedeem seed
--
-- redeemAdaPaperVend :: forall eff. EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String (Promise Json)
-- redeemAdaPaperVend = mkEffFn3 \seed mnemonic -> fromAff <<< map encodeJson <<< either throwError B.redeemAdaPaperVend <<< mkCPaperVendWalletRedeem seed mnemonic
--
-- reportInit :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) Int Int (Promise Unit)
-- reportInit = mkEffFn2 \total -> fromAff <<< B.reportInit <<< mkCInitialized total
--
-- importKey :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
-- importKey = mkEffFn1 $ fromAff <<< map encodeJson <<< B.importKey
--
-- syncProgress :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- syncProgress = fromAff $ map encodeJson B.syncProgress
--
-- -- Valid redeem code is base64 encoded 32byte data
-- -- NOTE: this method handles both base64 and base64url base on rfc4648: see more https://github.com/menelaos/purescript-b64/blob/59e2e9189358a4c8e3eef8662ca281906844e783/src/Data/String/Base64.purs#L182
-- isValidRedemptionKey :: String -> Boolean
-- isValidRedemptionKey code = either (const false) (const $ endsWithEqual && 44 == length code) $ B64.decode code
--   where
--     -- Because it is 32byte base64 encoded
--     endsWithEqual = isJust $ stripSuffix (Pattern "=") code
--
-- -- Valid paper vend key is base58 encoded 32byte data
-- isValidPaperVendRedemptionKey :: String -> Boolean
-- isValidPaperVendRedemptionKey code = maybe false ((==) 32 <<< A.length) $ B58.decode code


Make use of TestEither

Make use of TestEither

module Test.Data.Either where

import Data.Either
import Debug.Trace
import Control.Monad.Eff
import Test.QuickCheck
import Test.QuickCheck.Either
import Test.Classes

type Ty = Either Number Number

main = do

  trace "test equality"
  check1 $ \n -> Left n  == Left n :: Ty
  check1 $ \n -> Right n == Right n :: Ty

  trace "test inequality"
  check1 $ \n -> Left n  /= Right n :: Ty
  check1 $ \n -> Right n /= Left n :: Ty
  check1 $ \n -> Left n  /= Left (n + 1) :: Ty
  check1 $ \n -> Right n /= Right (n + 1) :: Ty

  trace "test order"
  check2 $ \x y -> compare (Left x :: Ty)  (Left y)  == compare x y
  check2 $ \x y -> compare (Left x :: Ty)  (Right x) == LT
  check2 $ \x y -> compare (Right x :: Ty) (Right y) == compare x y
  check2 $ \x y -> compare (Right x :: Ty) (Left y)  == GT

  trace "either should transform values wrapped in an Either"
  check1 $ \n -> either negate id (Left n :: Ty)  == -n
  check1 $ \n -> either id negate (Right n :: Ty) == -n

  trace "isLeft should return the appropriate value"
  assert $ isLeft (Left {})  == true
  assert $ isLeft (Right {}) == false

  trace "isRight should return the appropriate value"
  assert $ isRight (Right {}) == true
  assert $ isRight (Left {})  == false

  let tty = TestEither (Left 0) :: (TestEither Number Number)

  trace "test functor laws"
  checkFunctor tty

  trace "test applicative laws"
  checkApplicative tty tty tty

  trace "test monad laws"
  checkMonad tty

assert :: Boolean -> QC {}
assert = quickCheck' 1

check1 :: (Number -> Boolean) -> QC {}
check1 = quickCheck

check2 :: (Number -> Number -> Boolean) -> QC {}
check2 = quickCheck

module Test.Data.Either where

import Data.Either
import Debug.Trace
import Control.Monad.Eff
import Test.QuickCheck
import Test.QuickCheck.Either
import Test.Classes

type Ty = Either Number Number

instance arbEither :: (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where
  arbitrary = runTestEither <$> arbitrary

main = do

  let ty = Left 0 :: Ty

  trace "test equality"
  check1 $ \n -> Left n  == Left n :: Ty
  check1 $ \n -> Right n == Right n :: Ty

  trace "test inequality"
  check1 $ \n -> Left n  /= Right n :: Ty
  check1 $ \n -> Right n /= Left n :: Ty
  check1 $ \n -> Left n  /= Left (n + 1) :: Ty
  check1 $ \n -> Right n /= Right (n + 1) :: Ty

  trace "test order"
  check2 $ \x y -> compare (Left x :: Ty)  (Left y)  == compare x y
  check2 $ \x y -> compare (Left x :: Ty)  (Right x) == LT
  check2 $ \x y -> compare (Right x :: Ty) (Right y) == compare x y
  check2 $ \x y -> compare (Right x :: Ty) (Left y)  == GT

  trace "either should transform values wrapped in an Either"
  check1 $ \n -> either negate id (Left n :: Ty)  == -n
  check1 $ \n -> either id negate (Right n :: Ty) == -n

  trace "isLeft should return the appropriate value"
  assert $ isLeft (Left {})  == true
  assert $ isLeft (Right {}) == false

  trace "isRight should return the appropriate value"
  assert $ isRight (Right {}) == true
  assert $ isRight (Left {})  == false

  trace "test functor laws"
  checkFunctor ty

  trace "test applicative laws"
  checkApplicative ty ty ty

  trace "test monad laws"
  checkMonad ty

assert :: Boolean -> QC {}
assert = quickCheck' 1

check1 :: (Number -> Boolean) -> QC {}
check1 = quickCheck

check2 :: (Number -> Number -> Boolean) -> QC {}
check2 = quickCheck

instance arbAToEitherBC :: (Arbitrary (a -> b), Arbitrary (a -> c)) => Arbitrary (a -> Either b c) where
  arbitrary = do
    f <- arbitrary
    g <- arbitrary
    lr <- arbitrary
    return $ \x -> if lr then Left (f x) else Right (g x)


Add usage examples to the documentation (#88)

* Add usage examples to the documentation

* Detailed explanation for 'localeCompare', add results

-- | Wraps the functions of Javascript's `String` object.
-- | A String represents a sequence of characters.
-- | For details of the underlying implementation, see [String Reference at MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String).
module Data.String
  ( Pattern(..)
  , Replacement(..)
  , charAt
  , charCodeAt
  , fromCharArray
  , toChar
  , contains
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , null
  , uncons
  , length
  , singleton
  , localeCompare
  , replace
  , replaceAll
  , take
  , takeWhile
  , drop
  , dropWhile
  , stripPrefix
  , stripSuffix
  , count
  , split
  , splitAt
  , toCharArray
  , toLower
  , toUpper
  , trim
  , joinWith
  ) where

import Prelude

import Data.Maybe (Maybe(..), isJust)
import Data.Newtype (class Newtype)
import Data.String.Unsafe as U

-- | A newtype used in cases where there is a string to be matched.
newtype Pattern = Pattern String

derive instance eqPattern :: Eq Pattern
derive instance ordPattern :: Ord Pattern
derive instance newtypePattern :: Newtype Pattern _

instance showPattern :: Show Pattern where
  show (Pattern s) = "(Pattern " <> show s <> ")"

-- | A newtype used in cases to specify a replacement for a pattern.
newtype Replacement = Replacement String

derive instance eqReplacement :: Eq Replacement
derive instance ordReplacement :: Ord Replacement
derive instance newtypeReplacement :: Newtype Replacement _

instance showReplacement :: Show Replacement where
  show (Replacement s) = "(Replacement " <> show s <> ")"

-- | Returns the character at the given index, if the index is within bounds.
charAt :: Int -> String -> Maybe Char
charAt = _charAt Just Nothing

foreign import _charAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Char

-- | Returns a string of length `1` containing the given character.
foreign import singleton :: Char -> String

-- | Returns the numeric Unicode value of the character at the given index,
-- | if the index is within bounds.
-- | - `charCodeAt 2 "5 €" == Just 0x20AC`
charCodeAt :: Int -> String -> Maybe Int
charCodeAt = _charCodeAt Just Nothing

foreign import _charCodeAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Int

-- | Converts the string to a character, if the length of the string is
-- | exactly `1`.
toChar :: String -> Maybe Char
toChar = _toChar Just Nothing

foreign import _toChar
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> String
  -> Maybe Char

-- | Returns `true` if the given string is empty.
null :: String -> Boolean
null s = s == ""

-- | Returns the first character and the rest of the string,
-- | if the string is not empty.
uncons :: String -> Maybe { head :: Char, tail :: String }
uncons "" = Nothing
uncons s  = Just { head: U.charAt zero s, tail: drop one s }

-- | Returns the longest prefix (possibly empty) of characters that satisfy
-- | the predicate.
-- | * `takeWhile (_ /= ':') "http://purescript.org" == "http"`
takeWhile :: (Char -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Returns the suffix remaining after `takeWhile`.
dropWhile :: (Char -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | If the string starts with the given prefix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripPrefix (Pattern "http:") "http://purescript.org" == Just "//purescript.org"`
-- | * `stripPrefix (Pattern "http:") "https://purescript.org" == Nothing`
stripPrefix :: Pattern -> String -> Maybe String
stripPrefix prefix@(Pattern prefixS) str =
  case indexOf prefix str of
    Just 0 -> Just $ drop (length prefixS) str
    _ -> Nothing

-- | If the string ends with the given suffix, return the portion of the
-- | string left after removing it, as a `Just` value. Otherwise, return
-- | `Nothing`.
-- | * `stripSuffix (Pattern ".exe") "psc.exe" == Just "psc"`
-- | * `stripSuffix (Pattern ".exe") "psc" == Nothing`
stripSuffix :: Pattern -> String -> Maybe String
stripSuffix suffix@(Pattern suffixS) str =
  case lastIndexOf suffix str of
    Just x | x == length str - length suffixS -> Just $ take x str
    _ -> Nothing

-- | Converts an array of characters into a string.
foreign import fromCharArray :: Array Char -> String

-- | Checks whether the pattern appears in the given string.
-- | * `contains (Pattern "needle") "haystack with needle" == true`
-- | * `contains (Pattern "needle") "haystack" == false`
contains :: Pattern -> String -> Boolean
contains pat = isJust <<< indexOf pat

-- | Returns the index of the first occurrence of the pattern in the
-- | given string. Returns `Nothing` if there is no match.
-- | * `indexOf (Pattern "c") "abcde" == Just 2`
indexOf :: Pattern -> String -> Maybe Int
indexOf = _indexOf Just Nothing

foreign import _indexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the first occurrence of the pattern in the
-- | given string, starting at the specified index. Returns `Nothing` if there is
-- | no match.
indexOf' :: Pattern -> Int -> String -> Maybe Int
indexOf' = _indexOf' Just Nothing

foreign import _indexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the pattern in the
-- | given string. Returns `Nothing` if there is no match.
lastIndexOf :: Pattern -> String -> Maybe Int
lastIndexOf = _lastIndexOf Just Nothing

foreign import _lastIndexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the pattern in the
-- | given string, starting at the specified index. Returns `Nothing`
-- | if there is no match.
lastIndexOf' :: Pattern -> Int -> String -> Maybe Int
lastIndexOf' = _lastIndexOf' Just Nothing

foreign import _lastIndexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the number of characters the string is composed of.
foreign import length :: String -> Int

-- | Compare two strings in a locale-aware fashion. This is in contrast to
-- | the `Ord` instance on `String` which treats strings as arrays of code
-- | units:
-- | - `"ä" `localeCompare` "b" == LT`
-- | - `"ä" `compare` "b" == GT`
localeCompare :: String -> String -> Ordering
localeCompare = _localeCompare LT EQ GT

foreign import _localeCompare
  :: Ordering
  -> Ordering
  -> Ordering
  -> String
  -> String
  -> Ordering

-- | Replaces the first occurence of the pattern with the replacement string.
-- | * `replace (Pattern "http") (Replacement "https") "http://purescript.org" == "https://purescript.org"`
foreign import replace :: Pattern -> Replacement -> String -> String

-- | Replaces all occurences of the pattern with the replacement string.
foreign import replaceAll :: Pattern -> Replacement -> String -> String

-- | Returns the first `n` characters of the string.
foreign import take :: Int -> String -> String

-- | Returns the string without the first `n` characters.
foreign import drop :: Int -> String -> String

-- | Returns the number of contiguous characters at the beginning
-- | of the string for which the predicate holds.
foreign import count :: (Char -> Boolean) -> String -> Int

-- | Returns the substrings of the second string separated along occurences
-- | of the first string.
-- | * `split (Pattern " ") "hello world" == ["hello", "world"]`
foreign import split :: Pattern -> String -> Array String

-- | Returns the substrings of a split at the given index, if the index is within bounds.
splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt = _splitAt Just Nothing

foreign import _splitAt :: (forall a. a -> Maybe a)
                        -> (forall a. Maybe a)
                        -> Int
                        -> String
                        -> Maybe { before :: String, after :: String }

-- | Converts the string into an array of characters.
foreign import toCharArray :: String -> Array Char

-- | Returns the argument converted to lowercase.
foreign import toLower :: String -> String

-- | Returns the argument converted to uppercase.
foreign import toUpper :: String -> String

-- | Removes whitespace from the beginning and end of a string, including
-- | [whitespace characters](http://www.ecma-international.org/ecma-262/5.1/#sec-7.2)
-- | and [line terminators](http://www.ecma-international.org/ecma-262/5.1/#sec-7.3).
foreign import trim :: String -> String

-- | Joins the strings in the array together, inserting the first argument
-- | as separator between them.
-- | * `joinWith ", " ["apple", "banana", "orange"] == "apple, banana, orange"`
foreign import joinWith :: String -> Array String -> String

-- | Wraps the functions of Javascript's `String` object.
-- | A String represents a sequence of characters.
-- | For details of the underlying implementation, see [String Reference at MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String).
module Data.String
  ( Pattern(..)
  , Replacement(..)
  , charAt
  , charCodeAt
  , fromCharArray
  , toChar
  , contains
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , null
  , uncons
  , length
  , singleton
  , localeCompare
  , replace
  , replaceAll
  , take
  , takeWhile
  , drop
  , dropWhile
  , stripPrefix
  , stripSuffix
  , count
  , split
  , splitAt
  , toCharArray
  , toLower
  , toUpper
  , trim
  , joinWith
  ) where

import Prelude

import Data.Maybe (Maybe(..), isJust)
import Data.Newtype (class Newtype)
import Data.String.Unsafe as U

-- | A newtype used in cases where there is a string to be matched.
newtype Pattern = Pattern String

derive instance eqPattern :: Eq Pattern
derive instance ordPattern :: Ord Pattern
derive instance newtypePattern :: Newtype Pattern _

instance showPattern :: Show Pattern where
  show (Pattern s) = "(Pattern " <> show s <> ")"

-- | A newtype used in cases to specify a replacement for a pattern.
newtype Replacement = Replacement String

derive instance eqReplacement :: Eq Replacement
derive instance ordReplacement :: Ord Replacement
derive instance newtypeReplacement :: Newtype Replacement _

instance showReplacement :: Show Replacement where
  show (Replacement s) = "(Replacement " <> show s <> ")"

-- | Returns the character at the given index, if the index is within bounds.
charAt :: Int -> String -> Maybe Char
charAt = _charAt Just Nothing

foreign import _charAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Char

-- | Returns a string of length `1` containing the given character.
foreign import singleton :: Char -> String

-- | Returns the numeric Unicode value of the character at the given index,
-- | if the index is within bounds.
charCodeAt :: Int -> String -> Maybe Int
charCodeAt = _charCodeAt Just Nothing

foreign import _charCodeAt
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Int
  -> String
  -> Maybe Int

toChar :: String -> Maybe Char
toChar = _toChar Just Nothing

foreign import _toChar
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> String
  -> Maybe Char

-- | Returns `true` if the given string is empty.
null :: String -> Boolean
null s = s == ""

-- | Returns the first character and the rest of the string,
-- | if the string is not empty.
uncons :: String -> Maybe { head :: Char, tail :: String }
uncons "" = Nothing
uncons s  = Just { head: U.charAt zero s, tail: drop one s }

-- | Returns the longest prefix (possibly empty) of characters that satisfy
-- | the predicate.
takeWhile :: (Char -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Returns the suffix remaining after `takeWhile`.
dropWhile :: (Char -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | If the string starts with the given prefix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripPrefix (Pattern "http:") "http://purescript.org" == Just "//purescript.org"`
-- | * `stripPrefix (Pattern "http:") "https://purescript.org" == Nothing`
stripPrefix :: Pattern -> String -> Maybe String
stripPrefix prefix@(Pattern prefixS) str =
  case indexOf prefix str of
    Just 0 -> Just $ drop (length prefixS) str
    _ -> Nothing

-- | If the string ends with the given suffix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripSuffix (Pattern ".exe") "psc.exe" == Just "psc"`
-- | * `stripSuffix (Pattern ".exe") "psc" == Nothing`
stripSuffix :: Pattern -> String -> Maybe String
stripSuffix suffix@(Pattern suffixS) str =
  case lastIndexOf suffix str of
    Just x | x == length str - length suffixS -> Just $ take x str
    _ -> Nothing

-- | Converts an array of characters into a string.
foreign import fromCharArray :: Array Char -> String

-- | Checks whether the first string exists in the second string.
contains :: Pattern -> String -> Boolean
contains pat = isJust <<< indexOf pat

-- | Returns the index of the first occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
indexOf :: Pattern -> String -> Maybe Int
indexOf = _indexOf Just Nothing

foreign import _indexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the first occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
indexOf' :: Pattern -> Int -> String -> Maybe Int
indexOf' = _indexOf' Just Nothing

foreign import _indexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
lastIndexOf :: Pattern -> String -> Maybe Int
lastIndexOf = _lastIndexOf Just Nothing

foreign import _lastIndexOf
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> String
  -> Maybe Int

-- | Returns the index of the last occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
lastIndexOf' :: Pattern -> Int -> String -> Maybe Int
lastIndexOf' = _lastIndexOf' Just Nothing

foreign import _lastIndexOf'
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Pattern
  -> Int
  -> String
  -> Maybe Int

-- | Returns the number of characters the string is composed of.
foreign import length :: String -> Int

-- | Locale-aware sort order comparison.
localeCompare :: String -> String -> Ordering
localeCompare = _localeCompare LT EQ GT

foreign import _localeCompare
  :: Ordering
  -> Ordering
  -> Ordering
  -> String
  -> String
  -> Ordering

-- | Replaces the first occurence of the first argument with the second argument.
foreign import replace :: Pattern -> Replacement -> String -> String

-- | Replaces all occurences of the first argument with the second argument.
foreign import replaceAll :: Pattern -> Replacement -> String -> String

-- | Returns the first `n` characters of the string.
foreign import take :: Int -> String -> String

-- | Returns the string without the first `n` characters.
foreign import drop :: Int -> String -> String

-- | Returns the number of contiguous characters at the beginning
-- | of the string for which the predicate holds.
foreign import count :: (Char -> Boolean) -> String -> Int

-- | Returns the substrings of the second string separated along occurences
-- | of the first string.
-- | * `split (Pattern " ") "hello world" == ["hello", "world"]`
foreign import split :: Pattern -> String -> Array String

-- | Returns the substrings of split at the given index, if the index is within bounds.
splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt = _splitAt Just Nothing

foreign import _splitAt :: (forall a. a -> Maybe a)
                        -> (forall a. Maybe a)
                        -> Int
                        -> String
                        -> Maybe { before :: String, after :: String }

-- | Converts the string into an array of characters.
foreign import toCharArray :: String -> Array Char

-- | Returns the argument converted to lowercase.
foreign import toLower :: String -> String

-- | Returns the argument converted to uppercase.
foreign import toUpper :: String -> String

-- | Removes whitespace from the beginning and end of a string, including
-- | [whitespace characters](http://www.ecma-international.org/ecma-262/5.1/#sec-7.2)
-- | and [line terminators](http://www.ecma-international.org/ecma-262/5.1/#sec-7.3).
foreign import trim :: String -> String

-- | Joins the strings in the array together, inserting the first argument
-- | as separator between them.
foreign import joinWith :: String -> Array String -> String


not needed

not needed

module Shared (
  TodoEffects (..),
  baseURL
) where

import Prelude
import Halogen
import Control.Monad.Aff (Aff())
import Control.Monad.Eff.Console (CONSOLE())
import Network.HTTP.Affjax (AJAX())

type TodoEffects = Aff (HalogenEffects (ajax :: AJAX, console :: CONSOLE))

baseURL :: String
baseURL = "/todos/"

module Shared (
  TodoEffects (..),
  baseURL
) where

import Prelude
import DOM (DOM())
import Halogen
import Control.Monad.Aff (Aff())
import Control.Monad.Eff.Console (CONSOLE())
import Network.HTTP.Affjax (AJAX())

type TodoEffects = Aff (HalogenEffects (ajax :: AJAX, console :: CONSOLE))

baseURL :: String
baseURL = "/todos/"