Some log updates

Some log updates

module IdePurescript.VSCode.Main where

import Prelude
import IdePurescript.Completion as C
import PscIde.Command as Command
import VSCode.Notifications as Notify
import Control.Monad.Aff (Aff, attempt, delay, runAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log, warn, error, info)
import Control.Monad.Eff.Ref (REF, Ref, readRef, newRef, writeRef)
import Control.Monad.Eff.Uncurried (EffFn4, EffFn3, EffFn2, EffFn1, runEffFn4, mkEffFn3, mkEffFn2, mkEffFn1)
import Control.Monad.Except (runExcept)
import Control.Promise (Promise, fromAff)
import Data.Array (filter, notElem, uncons)
import Data.Either (Either(..), either)
import Data.Foreign (Foreign, readArray, readBoolean, readInt, readString)
import Data.Maybe (Maybe(Just, Nothing), fromMaybe, maybe)
import Data.Nullable (toNullable, Nullable)
import Data.String (trim, null)
import Data.String.Regex (Regex, regex, split)
import Data.String.Regex.Flags (noFlags)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (traverse)
import IdePurescript.Build (Command(Command), build, rebuild)
import IdePurescript.Completion (SuggestionResult(..), SuggestionType(..))
import IdePurescript.Modules (ImportResult(FailedImport, AmbiguousImport, UpdatedImports), State, addExplicitImport, getModulesForFile, getQualModule, getUnqualActiveModules, initialModulesState)
import IdePurescript.PscErrors (PscError(PscError))
import IdePurescript.PscIde (getLoadedModules, getType)
import IdePurescript.PscIdeServer (Notify, ErrorLevel(Error, Warning, Info, Success))
import IdePurescript.PscIdeServer (startServer', QuitCallback, ServerEff) as P
import IdePurescript.Tokens (identifierAtPoint)
import IdePurescript.VSCode.Assist (addClause, caseSplit)
import IdePurescript.VSCode.Editor (GetText)
import IdePurescript.VSCode.Imports (addModuleImportCmd, addIdentImportCmd)
import IdePurescript.VSCode.Pursuit (searchPursuit)
import IdePurescript.VSCode.Symbols (SymbolInfo, SymbolQuery(..), getDefinition, getSymbols)
import IdePurescript.VSCode.Types (MainEff)
import PscIde (load) as P
import PscIde.Command (TypeInfo(..))
import Unsafe.Coerce (unsafeCoerce)
import VSCode.Command (register)
import VSCode.Diagnostic (Diagnostic, mkDiagnostic)
import VSCode.Location (Location)
import VSCode.Notifications (appendOutputLine, createOutputChannel)
import VSCode.Position (mkPosition)
import VSCode.Range (mkRange, Range)
import VSCode.TextDocument (TextDocument, getPath, getText)
import VSCode.TextEditor (setTextViaDiff, getDocument)
import VSCode.Window (getActiveTextEditor, setStatusBarMessage, WINDOW)
import VSCode.Workspace (rootPath, getValue, getConfiguration, WORKSPACE)

useEditor :: forall eff.  Notify (MainEff eff) -> Int -> (Ref State) -> String -> String -> Eff (MainEff eff) Unit
useEditor logError port modulesStateRef path text = do
  void $ runAff (logError Info <<< show) (const $ pure unit) $ do
    state <- getModulesForFile port path text
    liftEff $ writeRef modulesStateRef state

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

getCompletions :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Array { suggestType :: String, typeInfo :: Command.TypeInfo, prefix :: String }))
getCompletions port state line' char getTextInRange = do
  line <- getTextInRange line' 0 line' char
  let getQualifiedModule = (flip getQualModule) state
  config <- getConfiguration "purescript"
  autoCompleteAllModules <- either (const true) id <<< runExcept <<< readBoolean <$> getValue config "autocompleteAllModules"
  fromAff $ do
    modules <- if autoCompleteAllModules then getLoadedModules port else pure $ getUnqualActiveModules state Nothing
    suggestions <- C.getSuggestions port { line, moduleInfo: { modules, getQualifiedModule, mainModule: state.main } }
    pure $ convert <$> suggestions
  where
    -- TODO change the types here and pull in suggestion handling into PS
    convert (ModuleSuggestion { text, suggestType, prefix }) =
      { suggestType: convertSuggest suggestType, typeInfo: TypeInfo { type': text, identifier: text, module': text, expandedType: Just text, definedAt: Nothing, documentation: Nothing }, prefix }
    convert (IdentSuggestion { mod, identifier, qualifier, suggestType, prefix, valueType }) =
      { suggestType: convertSuggest suggestType, typeInfo: TypeInfo { type': valueType, identifier, module': mod, expandedType: Just valueType, definedAt: Nothing, documentation: Nothing }, prefix }

    convertSuggest = case _ of
      Module -> "Module"
      Value -> "Value"
      Function -> "Function"
      Type -> "Type"

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
    text <- getTextInRange line 0 line (char + 100)
    case identifierAtPoint text char of
      Just { word, qualifier } -> fromAff do
        ty <- getType port word state.main qualifier (getUnqualActiveModules state $ Just word) (flip getQualModule $ state)
        let marked = if null ty then Nothing else Just $ markedString $ word <> " :: " <> ty
        pure $ toNullable marked
      Nothing -> fromAff $ pure $ toNullable Nothing

startServer' :: forall eff eff'. String -> String -> Int -> String -> Notify (P.ServerEff (workspace :: WORKSPACE | eff)) -> Notify (P.ServerEff (workspace :: WORKSPACE | eff)) -> Aff (P.ServerEff (workspace :: WORKSPACE | eff)) { port:: Maybe Int, quit:: P.QuitCallback eff' }
startServer' server purs _port root cb logCb = do
  config <- liftEff $ getConfiguration "purescript"
  useNpmPath <- liftEff $ either (const false) id <<< runExcept <<< readBoolean <$> getValue config "addNpmPath"
  usePurs <- liftEff $ either (const false) id <<< runExcept <<< readBoolean <$> getValue config "useCombinedExe"
  packagePath <- liftEff $ either (const "bower_components") id <<< runExcept <<< readString <$> getValue config "packagePath"
  P.startServer' root (if usePurs then purs else server) useNpmPath usePurs ["src/**/*.purs", packagePath <> "/**/*.purs"] cb logCb

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)

  conv (Just { replacement, replaceRange }) = { suggest: true, replacement, range: range replaceRange }
  conv _ = { suggest: false, replacement: "", range: range Nothing }

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

data Status = Building | BuildFailure | BuildErrors | BuildSuccess

showStatus :: forall eff. Status -> Eff (window :: WINDOW | eff) Unit
showStatus status = do
  let icon = case status of
              Building -> "$(beaker)"
              BuildFailure -> "$(bug)"
              BuildErrors -> "$(check)"
              BuildSuccess -> "$(check)"
  setStatusBarMessage $ icon <> " PureScript"

quickBuild :: forall eff. Int -> String -> Eff (MainEff eff) (Promise VSBuildResult)
quickBuild port filename = fromAff $ do
  liftEff $ showStatus Building
  { errors, success } <- rebuild port filename
  liftEff $ showStatus BuildSuccess
  errors' <- liftEff $ censorWarnings errors
  pure $ { success, diagnostics: toDiagnostic' errors', quickBuild: true, file: filename }

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

type ErrorResult = { warnings :: Array PscError, errors :: Array PscError }

censorWarnings :: forall eff. ErrorResult -> Eff (MainEff eff) ErrorResult
censorWarnings { warnings, errors } = do
  config <- liftEff $ getConfiguration "purescript"
  censorCodes <- getValue config "censorWarnings"
  let codes = either (const []) id $ runExcept $ readArray censorCodes >>= traverse readString
  let getCode (PscError { errorCode }) = errorCode
  pure $ { warnings: filter (flip notElem codes <<< getCode) warnings, errors }

emptyBuildResult :: forall t280.
  { success :: Boolean
  , diagnostics :: Array t280
  , quickBuild :: Boolean
  , file :: String
  }
emptyBuildResult = { success: false, diagnostics: [], quickBuild: false, file: "" }

build' :: forall eff. Notify (MainEff eff) -> Notify (MainEff eff) -> String -> String -> Eff (MainEff eff) (Promise VSBuildResult)
build' notify logCb command directory = fromAff $ do
  liftEff $ logCb Info "Building"
  let buildCommand = either (const []) (\reg -> (split reg <<< trim) command) (regex "\\s+" noFlags)
  case uncons buildCommand of
    Just { head: cmd, tail: args } -> do
      liftEff $ logCb Info $ "Parsed build command, base command is: " <> cmd
      liftEff $ showStatus Building
      config <- liftEff $ getConfiguration "purescript"
      useNpmDir <- liftEff $ either (const false) id <<< runExcept <<< readBoolean <$> getValue config "addNpmPath"
      res <- build { command: Command cmd args, directory, useNpmDir }
      errors <- liftEff $ censorWarnings res.errors
      liftEff $ if res.success then showStatus BuildSuccess
                else showStatus BuildErrors
      pure $ { success: true, diagnostics: toDiagnostic' errors, quickBuild: false, file: "" }
    Nothing -> do
      liftEff $ notify Error "Error parsing PureScript build command"
      liftEff $ showStatus BuildFailure
      pure { success: false, diagnostics: [], quickBuild: false, file: "" }

addCompletionImport :: forall eff.  Notify (MainEff eff) -> (Ref State) -> Int -> Array Foreign -> Aff (MainEff eff) Unit
addCompletionImport logCb stateRef port args = case args of
  [ line, char, item ] -> case runExcept $ readInt line, runExcept $ readInt char of
    Right line', Right char' -> do
      let item' = (unsafeCoerce item) :: Command.TypeInfo
      Command.TypeInfo { identifier, module' } <- pure item'
      ed <- liftEff $ getActiveTextEditor
      case ed of
        Just ed' -> do
          let doc = getDocument ed'
          text <- liftEff $ getText doc
          path <- liftEff $ getPath doc
          state <- liftEff $ readRef stateRef
          { state: newState, result: output} <- addExplicitImport state port path text (Just module') identifier
          liftEff $ writeRef stateRef newState
          case output of
            UpdatedImports out -> void $ setTextViaDiff ed' out
            AmbiguousImport opts -> liftEff $ logCb Warning "Found ambiguous imports"
            FailedImport -> liftEff $ logCb Error "Failed to import"
          pure unit
        Nothing -> pure unit
      pure unit
    _, _ -> liftEff $ logCb Error "Wrong argument type"
  _ -> liftEff $ logCb Error "Wrong command arguments"

main :: forall eff. Eff (MainEff eff)
  { activate :: Eff (MainEff eff) (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 { suggestType :: String, typeInfo :: Command.TypeInfo, prefix :: String }))
  , getSymbols :: EffFn1 (MainEff eff) String (Promise (Array SymbolInfo))
  , getSymbolsForDoc :: EffFn1 (MainEff eff) TextDocument (Promise (Array SymbolInfo))
  , 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 Nothing
  output <- createOutputChannel "PureScript"

  let cmd s f = register ("purescript." <> s) (\_ -> f)
      cmdWithArgs s f = register ("purescript." <> s) f

  let deactivate :: Eff (MainEff eff) Unit
      deactivate = do
        join (readRef deactivateRef)
        writeRef deactivateRef (pure unit)
        writeRef portRef Nothing

  let logError :: Notify (MainEff eff)
      logError level str = do
        appendOutputLine output str
        case level of
          Success -> log str
          Info -> info str
          Warning -> warn str
          Error -> error str
  let showError :: Notify (MainEff eff)
      showError level str = do
        appendOutputLine output str
        logError level str
        case level of
          Success -> Notify.showInfo str
          Info -> Notify.showInfo str
          Warning -> Notify.showWarning str
          Error -> Notify.showError str

  let startPscIdeServer =
        do
          config <- liftEff $ getConfiguration "purescript"
          server <- liftEff $ either (const "psc-ide-server") id <<< runExcept <<< readString <$> getValue config "pscIdeServerExe"
          purs <- liftEff $ either (const "purs") id <<< runExcept <<< readString <$> getValue config "pursExe"
          port' <- liftEff $ either (const 4242) id <<< runExcept <<< readInt <$> getValue config "pscIdePort"
          rootPath <- liftEff rootPath
          -- TODO pass in port just when explicitly defined
          startRes <- startServer' server purs port' rootPath showError logError
          retry 6 case startRes of
            { port: Just port, quit } -> do
              _<- P.load port [] []
              liftEff do
                writeRef deactivateRef quit
                writeRef portRef $ Just port
            _ -> pure unit
        where
          retry :: Int -> Aff (MainEff eff) Unit -> Aff (MainEff eff) Unit
          retry n a | n > 0 = do
            res <- attempt a
            case res of
              Right r -> pure r
              Left err -> do
                liftEff $ logError Info $ "Retrying starting server after 500ms: " <> show err
                delay (Milliseconds 500.0)
                retry (n - 1) a
          retry _ a = a

      start :: Eff (MainEff eff) Unit
      start = void $ runAff (logError Error <<< show) (const $ pure unit) $ startPscIdeServer

      restart :: Eff (MainEff eff) Unit
      restart = do
        deactivate
        start

  let withPortDef :: forall eff' a. Eff (ref :: REF | eff') a -> (Int -> Eff (ref :: REF | eff') a) -> Eff (ref :: REF | eff') a
      withPortDef def f = readRef portRef >>= maybe def f
  let withPort :: forall eff'. (Int -> Eff (ref :: REF | eff') Unit) -> Eff (ref :: REF | eff') Unit
      withPort = withPortDef (pure unit)

  let initialise = fromAff $ do
        config <- liftEff $ getConfiguration "purescript"
        auto <- liftEff $ either (const true) id <<< runExcept <<< readBoolean <$> getValue config "autoStartPscIde"
        when auto startPscIdeServer
        liftEff do
          cmd "addImport" $ withPort $ addModuleImportCmd modulesState
          cmd "addExplicitImport" $ withPort $ addIdentImportCmd modulesState
          cmd "caseSplit" $ withPort caseSplit
          cmd "addClause" $ withPort addClause
          cmd "restartPscIde" restart
          cmd "startPscIde" start
          cmd "stopPscIde" deactivate
          cmd "searchPursuit" $ withPort searchPursuit
          cmdWithArgs "addCompletionImport" $ \args -> withPort \port -> do
            autocompleteAddImport <- either (const true) id <<< runExcept <<< readBoolean <$> getValue config "autocompleteAddImport"
            when autocompleteAddImport $
              void $ runAff (logError Info <<< show) (const $ pure unit) $ addCompletionImport logError modulesState port args

  pure $ {
      activate: initialise
    , deactivate: deactivate
    , build: mkEffFn2 $ build' showError logError
    , quickBuild: mkEffFn1 $ \fname ->
        withPortDef (fromAff $ pure emptyBuildResult) \port -> do
          quickBuild port fname
    , updateFile: mkEffFn2 $ \fname text -> withPort \port -> useEditor logError port modulesState fname text
    , getTooltips: mkEffFn3 $ \line char getText ->
        withPortDef (fromAff $ pure $ toNullable Nothing) \port -> do
          state <- readRef modulesState
          getTooltips port state line char (runEffFn4 getText)
    , getCompletions: mkEffFn3 $ \line char getText ->
        withPortDef (fromAff $ pure []) \port -> do
          state <- readRef modulesState
          getCompletions port state line char (runEffFn4 getText)
    , getSymbols: mkEffFn1 $ \query -> withPortDef (fromAff $ pure []) \port ->
        getSymbols modulesState port $ WorkspaceSymbolQuery query
    , getSymbolsForDoc: mkEffFn1 $ \document ->
        withPortDef (fromAff $ pure []) \port ->
          getSymbols modulesState port $ FileSymbolQuery document
    , provideDefinition: mkEffFn3 $ \line char getText ->
        withPortDef (fromAff $ pure $ toNullable Nothing) \port -> do
          state <- readRef modulesState
          getDefinition port state line char (runEffFn4 getText)
    }

module IdePurescript.VSCode.Main where

import Prelude
import IdePurescript.Completion as C
import PscIde.Command as Command
import VSCode.Notifications as Notify
import Control.Monad.Aff (Aff, attempt, delay, runAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log, warn, error, info)
import Control.Monad.Eff.Ref (REF, Ref, readRef, newRef, writeRef)
import Control.Monad.Eff.Uncurried (EffFn4, EffFn3, EffFn2, EffFn1, runEffFn4, mkEffFn3, mkEffFn2, mkEffFn1)
import Control.Monad.Except (runExcept)
import Control.Promise (Promise, fromAff)
import Data.Array (filter, notElem, uncons)
import Data.Either (Either(..), either)
import Data.Foreign (Foreign, readArray, readBoolean, readInt, readString)
import Data.Maybe (Maybe(Just, Nothing), fromMaybe, maybe)
import Data.Nullable (toNullable, Nullable)
import Data.String (trim, null)
import Data.String.Regex (Regex, regex, split)
import Data.String.Regex.Flags (noFlags)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (traverse)
import IdePurescript.Build (Command(Command), build, rebuild)
import IdePurescript.Completion (SuggestionResult(..), SuggestionType(..))
import IdePurescript.Modules (ImportResult(FailedImport, AmbiguousImport, UpdatedImports), State, addExplicitImport, getModulesForFile, getQualModule, getUnqualActiveModules, initialModulesState)
import IdePurescript.PscErrors (PscError(PscError))
import IdePurescript.PscIde (getLoadedModules, getType)
import IdePurescript.PscIdeServer (Notify, ErrorLevel(Error, Warning, Info, Success))
import IdePurescript.PscIdeServer (startServer', QuitCallback, ServerEff) as P
import IdePurescript.Tokens (identifierAtPoint)
import IdePurescript.VSCode.Assist (addClause, caseSplit)
import IdePurescript.VSCode.Editor (GetText)
import IdePurescript.VSCode.Imports (addModuleImportCmd, addIdentImportCmd)
import IdePurescript.VSCode.Pursuit (searchPursuit)
import IdePurescript.VSCode.Symbols (SymbolInfo, SymbolQuery(..), getDefinition, getSymbols)
import IdePurescript.VSCode.Types (MainEff)
import PscIde (load) as P
import PscIde.Command (TypeInfo(..))
import Unsafe.Coerce (unsafeCoerce)
import VSCode.Command (register)
import VSCode.Diagnostic (Diagnostic, mkDiagnostic)
import VSCode.Location (Location)
import VSCode.Notifications (appendOutputLine, createOutputChannel)
import VSCode.Position (mkPosition)
import VSCode.Range (mkRange, Range)
import VSCode.TextDocument (TextDocument, getPath, getText)
import VSCode.TextEditor (setTextViaDiff, getDocument)
import VSCode.Window (getActiveTextEditor, setStatusBarMessage, WINDOW)
import VSCode.Workspace (rootPath, getValue, getConfiguration, WORKSPACE)

useEditor :: forall eff.  Notify (MainEff eff) -> Int -> (Ref State) -> String -> String -> Eff (MainEff eff) Unit
useEditor logError port modulesStateRef path text = do
  void $ runAff (logError Info <<< show) (const $ pure unit) $ do
    state <- getModulesForFile port path text
    liftEff $ writeRef modulesStateRef state

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

getCompletions :: forall eff. Int -> State -> Int -> Int -> GetText (MainEff eff)
  -> Eff (MainEff eff) (Promise (Array { suggestType :: String, typeInfo :: Command.TypeInfo, prefix :: String }))
getCompletions port state line' char getTextInRange = do
  line <- getTextInRange line' 0 line' char
  let getQualifiedModule = (flip getQualModule) state
  config <- getConfiguration "purescript"
  autoCompleteAllModules <- either (const true) id <<< runExcept <<< readBoolean <$> getValue config "autocompleteAllModules"
  fromAff $ do
    modules <- if autoCompleteAllModules then getLoadedModules port else pure $ getUnqualActiveModules state Nothing
    suggestions <- C.getSuggestions port { line, moduleInfo: { modules, getQualifiedModule, mainModule: state.main } }
    pure $ convert <$> suggestions
  where
    -- TODO change the types here and pull in suggestion handling into PS
    convert (ModuleSuggestion { text, suggestType, prefix }) =
      { suggestType: convertSuggest suggestType, typeInfo: TypeInfo { type': text, identifier: text, module': text, expandedType: Just text, definedAt: Nothing, documentation: Nothing }, prefix }
    convert (IdentSuggestion { mod, identifier, qualifier, suggestType, prefix, valueType }) =
      { suggestType: convertSuggest suggestType, typeInfo: TypeInfo { type': valueType, identifier, module': mod, expandedType: Just valueType, definedAt: Nothing, documentation: Nothing }, prefix }

    convertSuggest = case _ of
      Module -> "Module"
      Value -> "Value"
      Function -> "Function"
      Type -> "Type"

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
    text <- getTextInRange line 0 line (char + 100)
    case identifierAtPoint text char of
      Just { word, qualifier } -> fromAff do
        ty <- getType port word state.main qualifier (getUnqualActiveModules state $ Just word) (flip getQualModule $ state)
        let marked = if null ty then Nothing else Just $ markedString $ word <> " :: " <> ty
        pure $ toNullable marked
      Nothing -> fromAff $ pure $ toNullable Nothing

startServer' :: forall eff eff'. String -> String -> Int -> String -> Notify (P.ServerEff (workspace :: WORKSPACE | eff)) -> Notify (P.ServerEff (workspace :: WORKSPACE | eff)) -> Aff (P.ServerEff (workspace :: WORKSPACE | eff)) { port:: Maybe Int, quit:: P.QuitCallback eff' }
startServer' server purs _port root cb logCb = do
  config <- liftEff $ getConfiguration "purescript"
  useNpmPath <- liftEff $ either (const false) id <<< runExcept <<< readBoolean <$> getValue config "addNpmPath"
  usePurs <- liftEff $ either (const false) id <<< runExcept <<< readBoolean <$> getValue config "useCombinedExe"
  packagePath <- liftEff $ either (const "bower_components") id <<< runExcept <<< readString <$> getValue config "packagePath"
  P.startServer' root (if usePurs then purs else server) useNpmPath usePurs ["src/**/*.purs", packagePath <> "/**/*.purs"] cb logCb

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)

  conv (Just { replacement, replaceRange }) = { suggest: true, replacement, range: range replaceRange }
  conv _ = { suggest: false, replacement: "", range: range Nothing }

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

data Status = Building | BuildFailure | BuildErrors | BuildSuccess

showStatus :: forall eff. Status -> Eff (window :: WINDOW | eff) Unit
showStatus status = do
  let icon = case status of
              Building -> "$(beaker)"
              BuildFailure -> "$(bug)"
              BuildErrors -> "$(check)"
              BuildSuccess -> "$(check)"
  setStatusBarMessage $ icon <> " PureScript"

quickBuild :: forall eff. Int -> String -> Eff (MainEff eff) (Promise VSBuildResult)
quickBuild port filename = fromAff $ do
  liftEff $ showStatus Building
  { errors, success } <- rebuild port filename
  liftEff $ showStatus BuildSuccess
  errors' <- liftEff $ censorWarnings errors
  pure $ { success, diagnostics: toDiagnostic' errors', quickBuild: true, file: filename }

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

type ErrorResult = { warnings :: Array PscError, errors :: Array PscError }

censorWarnings :: forall eff. ErrorResult -> Eff (MainEff eff) ErrorResult
censorWarnings { warnings, errors } = do
  config <- liftEff $ getConfiguration "purescript"
  censorCodes <- getValue config "censorWarnings"
  let codes = either (const []) id $ runExcept $ readArray censorCodes >>= traverse readString
  let getCode (PscError { errorCode }) = errorCode
  pure $ { warnings: filter (flip notElem codes <<< getCode) warnings, errors }

emptyBuildResult :: forall t280.
  { success :: Boolean
  , diagnostics :: Array t280
  , quickBuild :: Boolean
  , file :: String
  }
emptyBuildResult = { success: false, diagnostics: [], quickBuild: false, file: "" }

build' :: forall eff. Notify (MainEff 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 $ showStatus Building
      config <- liftEff $ getConfiguration "purescript"
      useNpmDir <- liftEff $ either (const false) id <<< runExcept <<< readBoolean <$> getValue config "addNpmPath"
      res <- build { command: Command cmd args, directory, useNpmDir }
      errors <- liftEff $ censorWarnings res.errors
      liftEff $ if res.success then showStatus BuildSuccess
                else showStatus BuildErrors
      pure $ { success: true, diagnostics: toDiagnostic' errors, quickBuild: false, file: "" }
    Nothing -> do
      liftEff $ notify Error "Error parsing PureScript build command"
      liftEff $ showStatus BuildFailure
      pure { success: false, diagnostics: [], quickBuild: false, file: "" }

addCompletionImport :: forall eff. (Ref State) -> Int -> Array Foreign -> Aff (MainEff eff) Unit
addCompletionImport stateRef port args = case args of
  [ line, char, item ] -> case runExcept $ readInt line, runExcept $ readInt char of
    Right line', Right char' -> do
      let item' = (unsafeCoerce item) :: Command.TypeInfo
      Command.TypeInfo { identifier, module' } <- pure item'
      ed <- liftEff $ getActiveTextEditor
      case ed of
        Just ed' -> do
          let doc = getDocument ed'
          text <- liftEff $ getText doc
          path <- liftEff $ getPath doc
          state <- liftEff $ readRef stateRef
          { state: newState, result: output} <- addExplicitImport state port path text (Just module') identifier
          liftEff $ writeRef stateRef newState
          case output of
            UpdatedImports out -> void $ setTextViaDiff ed' out
            AmbiguousImport opts -> liftEff $ log "Found ambiguous imports"
            FailedImport -> liftEff $ log "Failed to import"
          pure unit
        Nothing -> pure unit
      pure unit
    _, _ -> liftEff $ log "Wrong argument type"
  _ -> liftEff $ log "Wrong command arguments"

main :: forall eff. Eff (MainEff eff)
  { activate :: Eff (MainEff eff) (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 { suggestType :: String, typeInfo :: Command.TypeInfo, prefix :: String }))
  , getSymbols :: EffFn1 (MainEff eff) String (Promise (Array SymbolInfo))
  , getSymbolsForDoc :: EffFn1 (MainEff eff) TextDocument (Promise (Array SymbolInfo))
  , 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 Nothing
  output <- createOutputChannel "PureScript"

  let cmd s f = register ("purescript." <> s) (\_ -> f)
      cmdWithArgs s f = register ("purescript." <> s) f

  let deactivate :: Eff (MainEff eff) Unit
      deactivate = do
        join (readRef deactivateRef)
        writeRef deactivateRef (pure unit)
        writeRef portRef Nothing

  let logError :: Notify (MainEff eff)
      logError level str = do
        appendOutputLine output str
        case level of
          Success -> log str
          Info -> info str
          Warning -> warn str
          Error -> error str
  let showError :: Notify (MainEff eff)
      showError level str = do
        appendOutputLine output str
        logError level str
        case level of
          Success -> Notify.showInfo str
          Info -> Notify.showInfo str
          Warning -> Notify.showWarning str
          Error -> Notify.showError str

  let startPscIdeServer =
        do
          config <- liftEff $ getConfiguration "purescript"
          server <- liftEff $ either (const "psc-ide-server") id <<< runExcept <<< readString <$> getValue config "pscIdeServerExe"
          purs <- liftEff $ either (const "purs") id <<< runExcept <<< readString <$> getValue config "pursExe"
          port' <- liftEff $ either (const 4242) id <<< runExcept <<< readInt <$> getValue config "pscIdePort"
          rootPath <- liftEff rootPath
          -- TODO pass in port just when explicitly defined
          startRes <- startServer' server purs port' rootPath showError logError
          retry 6 case startRes of
            { port: Just port, quit } -> do
              _<- P.load port [] []
              liftEff do
                writeRef deactivateRef quit
                writeRef portRef $ Just port
            _ -> pure unit
        where
          retry :: Int -> Aff (MainEff eff) Unit -> Aff (MainEff eff) Unit
          retry n a | n > 0 = do
            res <- attempt a
            case res of
              Right r -> pure r
              Left err -> do
                liftEff $ log $ "Retrying starting server after 500ms: " <> show err
                delay (Milliseconds 500.0)
                retry (n - 1) a
          retry _ a = a

      start :: Eff (MainEff eff) Unit
      start = void $ runAff (logError Info <<< show) (const $ pure unit) $ startPscIdeServer

      restart :: Eff (MainEff eff) Unit
      restart = do
        deactivate
        start

  let withPortDef :: forall eff' a. Eff (ref :: REF | eff') a -> (Int -> Eff (ref :: REF | eff') a) -> Eff (ref :: REF | eff') a
      withPortDef def f = readRef portRef >>= maybe def f
  let withPort :: forall eff'. (Int -> Eff (ref :: REF | eff') Unit) -> Eff (ref :: REF | eff') Unit
      withPort = withPortDef (pure unit)

  let initialise = fromAff $ do
        config <- liftEff $ getConfiguration "purescript"
        auto <- liftEff $ either (const true) id <<< runExcept <<< readBoolean <$> getValue config "autoStartPscIde"
        when auto startPscIdeServer
        liftEff do
          cmd "addImport" $ withPort $ addModuleImportCmd modulesState
          cmd "addExplicitImport" $ withPort $ addIdentImportCmd modulesState
          cmd "caseSplit" $ withPort caseSplit
          cmd "addClause" $ withPort addClause
          cmd "restartPscIde" restart
          cmd "startPscIde" start
          cmd "stopPscIde" deactivate
          cmd "searchPursuit" $ withPort searchPursuit
          cmdWithArgs "addCompletionImport" $ \args -> withPort \port -> do
            autocompleteAddImport <- either (const true) id <<< runExcept <<< readBoolean <$> getValue config "autocompleteAddImport"
            when autocompleteAddImport $
              void $ runAff (logError Info <<< show) (const $ pure unit) $ addCompletionImport modulesState port args

  pure $ {
      activate: initialise
    , deactivate: deactivate
    , build: mkEffFn2 $ build' showError
    , quickBuild: mkEffFn1 $ \fname ->
        withPortDef (fromAff $ pure emptyBuildResult) \port -> do
          quickBuild port fname
    , updateFile: mkEffFn2 $ \fname text -> withPort \port -> useEditor logError port modulesState fname text
    , getTooltips: mkEffFn3 $ \line char getText ->
        withPortDef (fromAff $ pure $ toNullable Nothing) \port -> do
          state <- readRef modulesState
          getTooltips port state line char (runEffFn4 getText)
    , getCompletions: mkEffFn3 $ \line char getText ->
        withPortDef (fromAff $ pure []) \port -> do
          state <- readRef modulesState
          getCompletions port state line char (runEffFn4 getText)
    , getSymbols: mkEffFn1 $ \query -> withPortDef (fromAff $ pure []) \port ->
        getSymbols modulesState port $ WorkspaceSymbolQuery query
    , getSymbolsForDoc: mkEffFn1 $ \document ->
        withPortDef (fromAff $ pure []) \port ->
          getSymbols modulesState port $ FileSymbolQuery document
    , provideDefinition: mkEffFn3 $ \line char getText ->
        withPortDef (fromAff $ pure $ toNullable Nothing) \port -> do
          state <- readRef modulesState
          getDefinition port state line char (runEffFn4 getText)
    }


Amend test with path in error message

Amend test with path in error message

module Test.Authorization where

import Prelude (Unit, bind, ($), pure)

import Control.Monad.Aff (forkAff,later', launchAff, attempt)
import Control.Monad.Aff.Par (Par(..), runPar)
import Control.Monad.Aff.AVar (AVAR(), makeVar, takeVar, putVar)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION(), message)
import Control.Alt ((<|>))
import Data.Either (either)
import Data.Maybe (Maybe(Just))
import Data.Foreign (toForeign)
import Web.Firebase.Types as FBT
import Web.Firebase (EventType(..),once, pushE, push)
import Test.Spec                  (describe, it, Spec())
import Test.Spec.Assertions       (shouldEqual)
import Test.Spec.Assertions.Aff (expectError)
import Web.Firebase.Monad.Aff (onceValue, on, firebaseErrToString)

authorizationSpec :: forall eff. FBT.Firebase -> Spec (firebase :: FBT.FirebaseEff, err :: EXCEPTION, avar :: AVAR | eff ) Unit
authorizationSpec forbiddenRef = do
    describe "Understanding AVar and Par" do
      it "can write to a var" do
        respVar <- makeVar
        handle <- forkAff (later' 100 $ putVar respVar true)
        actual <- takeVar respVar
        actual `shouldEqual` true
      it "can race two vars manually" do
        respVar <- makeVar
        handle <- forkAff (later' 100 $ putVar respVar "fast")
        handleSlow <- forkAff (later' 200 $ putVar respVar "slow")
        actual <- takeVar respVar
        actual `shouldEqual` "fast"
      it "can race two vars with an alternative" do
        let fast = (later' 100 $ pure "fast")
            slow = (later' 200 $ pure "slow")
        actual <- runPar (Par fast <|> Par slow)
        actual `shouldEqual` "fast"
    describe "Authorization" do
      describe "Writing" do
        it "pushE() on forbidden location calls error callback" do
          respVar <- makeVar
          handle  <- liftEff $ pushE (toForeign {some: "object"}) (\(Just err) -> launchAff $ putVar respVar (firebaseErrToString err)) forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "PERMISSION_DENIED: Permission denied\n | firebase code: | \n PERMISSION_DENIED"
        it "push() on forbidden location calls error callback" do
          respVar <- makeVar
          handle  <- liftEff $ push (toForeign {some: "object"}) (Just (Just (\err -> launchAff $ putVar respVar (firebaseErrToString err)))) forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "PERMISSION_DENIED: Permission denied\n | firebase code: | \n PERMISSION_DENIED"
      describe "once() on forbidden location" do
        it "with Eff calls an error callback" do
          respVar <- makeVar
          handle  <- liftEff $ once ChildAdded (\snap -> launchAff $ putVar respVar "unexpected sucess") (\_ -> launchAff $ putVar respVar "child forbidden") forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "child forbidden"
        it "with Aff throws an error" do
           e <- attempt $ onceValue forbiddenRef  -- catch error thrown and assert
           either (\err -> (message err) `shouldEqual` "permission_denied at /forbidden: Client doesn't have permission to access the desired data.\n | firebase code: | \n PERMISSION_DENIED") (\_ -> "expected an error to be thrown" `shouldEqual` "but was not") e
      describe "on() at forbidden location" do
        it "ChildAdded with Aff throws an error" do
          expectError $ on ChildAdded forbiddenRef
        it "ChildRemoved with Aff throws an error" do
          expectError $ on ChildRemoved forbiddenRef
        it "ChildChanged with Aff throws an error" do
          expectError $ on ChildChanged forbiddenRef
        it "ChildMoved with Aff throws an error" do
          expectError $ on ChildMoved forbiddenRef

{-   describe "Firebase API breaks its documentation" do
       it "once() throws an exeption when no error callback provided and an error occurs" do
          -- I prefer handling errors, but this is the firebase api...
          handle <- liftEff $ once ChildAdded (\_ -> pure unit) Nothing forbiddenRef
          "shoul get here" `shouldEqual` "should get here"
-}

module Test.Authorization where

import Prelude (Unit, bind, ($), pure)

import Control.Monad.Aff (forkAff,later', launchAff, attempt)
import Control.Monad.Aff.Par (Par(..), runPar)
import Control.Monad.Aff.AVar (AVAR(), makeVar, takeVar, putVar)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION(), message)
import Control.Alt ((<|>))
import Data.Either (either)
import Data.Maybe (Maybe(Just))
import Data.Foreign (toForeign)
import Web.Firebase.Types as FBT
import Web.Firebase (EventType(..),once, pushE, push)
import Test.Spec                  (describe, it, Spec())
import Test.Spec.Assertions       (shouldEqual)
import Test.Spec.Assertions.Aff (expectError)
import Web.Firebase.Monad.Aff (onceValue, on, firebaseErrToString)

authorizationSpec :: forall eff. FBT.Firebase -> Spec (firebase :: FBT.FirebaseEff, err :: EXCEPTION, avar :: AVAR | eff ) Unit
authorizationSpec forbiddenRef = do
    describe "Understanding AVar and Par" do
      it "can write to a var" do
        respVar <- makeVar
        handle <- forkAff (later' 100 $ putVar respVar true)
        actual <- takeVar respVar
        actual `shouldEqual` true
      it "can race two vars manually" do
        respVar <- makeVar
        handle <- forkAff (later' 100 $ putVar respVar "fast")
        handleSlow <- forkAff (later' 200 $ putVar respVar "slow")
        actual <- takeVar respVar
        actual `shouldEqual` "fast"
      it "can race two vars with an alternative" do
        let fast = (later' 100 $ pure "fast")
            slow = (later' 200 $ pure "slow")
        actual <- runPar (Par fast <|> Par slow)
        actual `shouldEqual` "fast"
    describe "Authorization" do
      describe "Writing" do
        it "pushE() on forbidden location calls error callback" do
          respVar <- makeVar
          handle  <- liftEff $ pushE (toForeign {some: "object"}) (\(Just err) -> launchAff $ putVar respVar (firebaseErrToString err)) forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "PERMISSION_DENIED: Permission denied\n | firebase code: | \n PERMISSION_DENIED"
        it "push() on forbidden location calls error callback" do
          respVar <- makeVar
          handle  <- liftEff $ push (toForeign {some: "object"}) (Just (Just (\err -> launchAff $ putVar respVar (firebaseErrToString err)))) forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "PERMISSION_DENIED: Permission denied\n | firebase code: | \n PERMISSION_DENIED"
      describe "once() on forbidden location" do
        it "with Eff calls an error callback" do
          respVar <- makeVar
          handle  <- liftEff $ once ChildAdded (\snap -> launchAff $ putVar respVar "unexpected sucess") (\_ -> launchAff $ putVar respVar "child forbidden") forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "child forbidden"
        it "with Aff throws an error" do
           e <- attempt $ onceValue forbiddenRef  -- catch error thrown and assert
           either (\err -> (message err) `shouldEqual` "permission_denied: Client doesn't have permission to access the desired data.\n | firebase code: | \n PERMISSION_DENIED") (\_ -> "expected an error to be thrown" `shouldEqual` "but was not") e
      describe "on() at forbidden location" do
        it "ChildAdded with Aff throws an error" do
          expectError $ on ChildAdded forbiddenRef
        it "ChildRemoved with Aff throws an error" do
          expectError $ on ChildRemoved forbiddenRef
        it "ChildChanged with Aff throws an error" do
          expectError $ on ChildChanged forbiddenRef
        it "ChildMoved with Aff throws an error" do
          expectError $ on ChildMoved forbiddenRef

{-   describe "Firebase API breaks its documentation" do
       it "once() throws an exeption when no error callback provided and an error occurs" do
          -- I prefer handling errors, but this is the firebase api...
          handle <- liftEff $ once ChildAdded (\_ -> pure unit) Nothing forbiddenRef
          "shoul get here" `shouldEqual` "should get here"
-}


Add another example of `(<>)`: list concatenation

module Data.Semigroup
  ( class Semigroup, append, (<>)
  , class SemigroupRecord, appendRecord
  ) where

import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Unit (Unit, unit)
import Data.Void (Void, absurd)
import Prim.Row as Row
import Prim.RowList as RL
import Record.Unsafe (unsafeGet, unsafeSet)
import Type.Data.RowList (RLProxy(..))

-- | The `Semigroup` type class identifies an associative operation on a type.
-- |
-- | Instances are required to satisfy the following law:
-- |
-- | - Associativity: `(x <> y) <> z = x <> (y <> z)`
-- |
-- | One example of a `Semigroup` is `String`, with `(<>)` defined as string
-- | concatenation. Another example is `List a`, with `(<>)` defined as
-- | list concatenation.
class Semigroup a where
  append :: a -> a -> a

infixr 5 append as <>

instance semigroupString :: Semigroup String where
  append = concatString

instance semigroupUnit :: Semigroup Unit where
  append _ _ = unit

instance semigroupVoid :: Semigroup Void where
  append _ = absurd

instance semigroupFn :: Semigroup s' => Semigroup (s -> s') where
  append f g x = f x <> g x

instance semigroupArray :: Semigroup (Array a) where
  append = concatArray

instance semigroupRecord :: (RL.RowToList row list, SemigroupRecord list row row) => Semigroup (Record row) where
  append = appendRecord (RLProxy :: RLProxy list)

foreign import concatString :: String -> String -> String
foreign import concatArray :: forall a. Array a -> Array a -> Array a

-- | A class for records where all fields have `Semigroup` instances, used to
-- | implement the `Semigroup` instance for records.
class SemigroupRecord rowlist row subrow | rowlist -> subrow where
  appendRecord :: RLProxy rowlist -> Record row -> Record row -> Record subrow

instance semigroupRecordNil :: SemigroupRecord RL.Nil row () where
  appendRecord _ _ _ = {}

instance semigroupRecordCons
    :: ( IsSymbol key
       , Row.Cons key focus subrowTail subrow
       , SemigroupRecord rowlistTail row subrowTail
       , Semigroup focus
       )
    => SemigroupRecord (RL.Cons key focus rowlistTail) row subrow where
  appendRecord _ ra rb = insert (get ra <> get rb) tail
    where
      key = reflectSymbol (SProxy :: SProxy key)
      get = unsafeGet key :: Record row -> focus
      insert = unsafeSet key :: focus -> Record subrowTail -> Record subrow
      tail = appendRecord (RLProxy :: RLProxy rowlistTail) ra rb

module Data.Semigroup
  ( class Semigroup, append, (<>)
  , class SemigroupRecord, appendRecord
  ) where

import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Unit (Unit, unit)
import Data.Void (Void, absurd)
import Prim.Row as Row
import Prim.RowList as RL
import Record.Unsafe (unsafeGet, unsafeSet)
import Type.Data.RowList (RLProxy(..))

-- | The `Semigroup` type class identifies an associative operation on a type.
-- |
-- | Instances are required to satisfy the following law:
-- |
-- | - Associativity: `(x <> y) <> z = x <> (y <> z)`
-- |
-- | One example of a `Semigroup` is `String`, with `(<>)` defined as string
-- | concatenation.
class Semigroup a where
  append :: a -> a -> a

infixr 5 append as <>

instance semigroupString :: Semigroup String where
  append = concatString

instance semigroupUnit :: Semigroup Unit where
  append _ _ = unit

instance semigroupVoid :: Semigroup Void where
  append _ = absurd

instance semigroupFn :: Semigroup s' => Semigroup (s -> s') where
  append f g x = f x <> g x

instance semigroupArray :: Semigroup (Array a) where
  append = concatArray

instance semigroupRecord :: (RL.RowToList row list, SemigroupRecord list row row) => Semigroup (Record row) where
  append = appendRecord (RLProxy :: RLProxy list)

foreign import concatString :: String -> String -> String
foreign import concatArray :: forall a. Array a -> Array a -> Array a

-- | A class for records where all fields have `Semigroup` instances, used to
-- | implement the `Semigroup` instance for records.
class SemigroupRecord rowlist row subrow | rowlist -> subrow where
  appendRecord :: RLProxy rowlist -> Record row -> Record row -> Record subrow

instance semigroupRecordNil :: SemigroupRecord RL.Nil row () where
  appendRecord _ _ _ = {}

instance semigroupRecordCons
    :: ( IsSymbol key
       , Row.Cons key focus subrowTail subrow
       , SemigroupRecord rowlistTail row subrowTail
       , Semigroup focus
       )
    => SemigroupRecord (RL.Cons key focus rowlistTail) row subrow where
  appendRecord _ ra rb = insert (get ra <> get rb) tail
    where
      key = reflectSymbol (SProxy :: SProxy key)
      get = unsafeGet key :: Record row -> focus
      insert = unsafeSet key :: focus -> Record subrowTail -> Record subrow
      tail = appendRecord (RLProxy :: RLProxy rowlistTail) ra rb


Quasar.Aff: add coroutine to get transitive children

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Quasar.Aff where

import Prelude

import Config as Config
import Config.Paths as Config

import Control.Bind ((>=>))
import Control.Coroutine as CR
import Control.Coroutine.Aff as ACR
import Control.Monad.Aff (Aff(), attempt, runAff)
import Control.Monad.Aff.AVar (AVAR())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Class (liftEff, MonadEff)
import Control.Monad.Eff.Exception (EXCEPTION(), error, throwException)
import Control.Monad.Eff.Ref (REF())
import Control.Monad.Eff.Ref (REF())
import Control.Monad.Error.Class (throwError)

import Data.Argonaut
  ( Json(), jsonEmptyObject, jsonParser, decodeJson, (~>), (:=))
import Data.Array (head, tail, (:), findIndex, filter, mapMaybe)
import Data.Bifunctor (bimap)
import Data.Date (nowEpochMilliseconds, Now())
import Data.Either (Either(..), either)
import Data.Foldable (foldl, traverse_)
import Data.Foreign (Foreign(), F(), parseJSON)
import Data.Foreign.Class (readProp, read, IsForeign)
import Data.Foreign.Index (prop)
import Data.Lens ((.~), (^.))
import Data.Maybe (Maybe(..), isJust, fromMaybe, maybe)
import Data.Path.Pathy
  ( Path(), Abs(), Sandboxed(), rootDir, relativeTo, (</>)
  , printPath, dir, file, peel, DirName(..), FileName(..))
import Data.String as S
import Data.Time (Milliseconds(..))
import Data.Tuple (Tuple(..))

import Model.Resource as R
import Model.Notebook as N

import Network.HTTP.Affjax
  ( Affjax(), AJAX(), AffjaxRequest(), AffjaxResponse(), RetryPolicy()
  , defaultRequest, affjax, retry, defaultRetryPolicy)
import Network.HTTP.Affjax.Request (Requestable)
import Network.HTTP.Affjax.Response (Respondable, ResponseType(JSONResponse))
import Network.HTTP.Method (Method(..))
import Network.HTTP.MimeType (MimeType(..), mimeTypeToString)
import Network.HTTP.MimeType.Common (applicationJSON)
import Network.HTTP.RequestHeader (RequestHeader(..))
import Network.HTTP.StatusCode (StatusCode(..))

import Unsafe.Coerce (unsafeCoerce)

import Utils.Path
  (DirPath(), FilePath(), AnyPath(), rootify, rootifyFile, (<./>), encodeURIPath)

newtype Listing = Listing (Array R.Resource)

runListing :: Listing -> Array R.Resource
runListing (Listing rs) = rs

instance listingIsForeign :: IsForeign Listing where
  read f = Listing <$> readProp "children" f

instance listingRespondable :: Respondable Listing where
  responseType = JSONResponse
  fromResponse = read

children :: forall e.
            DirPath -> Aff (RetryEffects (ajax :: AJAX | e)) (Array R.Resource)
children dir = do
  cs <- children' dir
  pure $ (R._root .~ dir) <$> cs

children' :: forall e.
             DirPath -> Aff (RetryEffects (ajax :: AJAX | e)) (Array R.Resource)
children' dir = runListing <$> (getResponse msg $ listing dir)
  where
  msg = "Error: can not get children of resource"

listing :: forall e. DirPath -> Affjax (RetryEffects e) Listing
listing p = maybe (throwError $ error "incorrect path")
            (\p -> retryGet $ (Config.metadataUrl </> p))
            $ relativeTo p rootDir

makeFile :: forall e. FilePath -> MimeType -> String
            -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
makeFile path mime content =
  getResponse msg go
  where
  msg :: String
  msg = "error while creating file"

  firstLine :: Maybe String
  firstLine = head $ S.split "\n" content

  isJson :: Either String Json
  isJson = maybe (Left "empty file") Right firstLine >>= jsonParser

  go :: Aff (RetryEffects (ajax :: AJAX | e)) (AffjaxResponse Unit)
  go = slamjax $ defaultRequest
   { method = PUT
   , headers = [ ContentType mime ]
   , content = Just content
   , url = fromMaybe ""
           $ (\x -> printPath
                    $ Config.dataUrl
                    </> x)
           <$> (relativeTo path rootDir)
   }

successStatus :: StatusCode
successStatus = StatusCode 200

succeeded :: StatusCode -> Boolean
succeeded (StatusCode int) =
  200 <= code && code < 300
  where code = int

type RetryEffects e = (avar :: AVAR, ref :: REF, now :: Now | e)

-- | A version of `affjax` with our retry policy.
slamjax :: forall e a b. (Requestable a, Respondable b) =>
           AffjaxRequest a -> Affjax (RetryEffects e) b
slamjax = retry defaultRetryPolicy affjax

retryGet :: forall e a fd. (Respondable a) =>
            Path Abs fd Sandboxed -> Affjax (RetryEffects e) a
retryGet =
  getWithPolicy { shouldRetryWithStatusCode: not <<< succeeded
                , delayCurve: const 1000
                , timeout: Just 30000
                }
getOnce :: forall e a fd. (Respondable a) =>
           Path Abs fd Sandboxed -> Affjax (RetryEffects e) a
getOnce = getWithPolicy defaultRetryPolicy

getWithPolicy :: forall e a fd. (Respondable a) =>
                 RetryPolicy -> Path Abs fd Sandboxed
                 -> Affjax (RetryEffects e) a
getWithPolicy policy u = do
  nocache <- liftEff $ nowEpochMilliseconds
  retry policy affjax defaultRequest { url = url' nocache }
  where
  url' nocache = url ++ symbol ++ "nocache=" ++ pretty nocache
  url = printPath u
  symbol = if S.contains "?" url then "&" else "?"
  pretty (Milliseconds ms) =
    let s = show ms
    in fromMaybe s (S.stripSuffix ".0" s)

retryDelete :: forall e a fd. (Respondable a) =>
               Path Abs fd Sandboxed -> Affjax (RetryEffects e) a
retryDelete u =
  slamjax $ defaultRequest { url = printPath u, method = DELETE }

retryPost :: forall e a b fd. (Requestable a, Respondable b) =>
             Path Abs fd Sandboxed -> a -> Affjax (RetryEffects e) b
retryPost u c =
  slamjax $ defaultRequest { method = POST, url = printPath u, content = Just c }

retryPut :: forall e a b fd. (Requestable a, Respondable b)
            => Path Abs fd Sandboxed -> a -> MimeType -> Affjax (RetryEffects e) b
retryPut u c mime =
  slamjax $ defaultRequest { method = PUT
                           , url = printPath u
                           , content = Just c
                           , headers = [ContentType mime] }

getResponse :: forall a e. String -> Affjax e a -> Aff (ajax :: AJAX | e) a
getResponse msg affjax = do
  res <- attempt affjax
  case res of
    Left e -> throwError $ error msg
    Right r -> do
      if not $ succeeded r.status
        then throwError $ error msg
        else pure r.response

reqHeadersToJSON :: Array RequestHeader -> Json
reqHeadersToJSON = foldl go jsonEmptyObject
  where
  go obj (Accept mime) = "Accept" := mimeTypeToString mime ~> obj
  go obj (ContentType mime) = "Content-Type" := mimeTypeToString mime ~> obj
  go obj (RequestHeader k v) = k := v ~> obj

mountInfo :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) String
mountInfo res = do

  let mountPath = (Config.mountUrl </> rootify (R.resourceDir res)) #
                  if R.resourceName res == ""
                  then id
                  else \x -> x </> dir (R.resourceName res)
  result <- getOnce mountPath
  if succeeded result.status
     then case parse result.response of
       Left err ->
         throwError $ error (show err)
       Right uri ->
         pure uri
     else throwError (error result.response)

  where
  parse :: String -> F String
  parse = parseJSON >=> prop "mongodb" >=> readProp "connectionUri"

getNewName :: forall e. DirPath -> String -> Aff (RetryEffects (ajax :: AJAX |e)) String
getNewName parent name = do
  items <- children' parent
  pure if exists' name items then getNewName' items 1 else name
  where
  getNewName' items i =
    let arr = S.split "." name
    in fromMaybe "" do
      body <- head arr
      suffixes <- tail arr
      let newName = S.joinWith "." $ (body <> " " <> show i):suffixes
      pure if exists' newName items
           then getNewName' items (i + one)
           else newName

exists' :: String -> Array R.Resource -> Boolean
exists' name items = isJust $ findIndex (\r -> r ^. R._name == name) items

-- Make dummy file in notebook specific folder.
-- It must be interpreted as empty notebook by notebook
-- component. Similar approach used in opening of data files, this
-- will help us decouple file and notebook subapps.
makeNotebook :: forall e. DirPath -> Aff (RetryEffects (ajax :: AJAX |e)) String
makeNotebook path = do
  name <- getNewName path (Config.newNotebookName <> "." <> Config.notebookExtension)
  result <- retryPut (notebookPath name) N.emptyNotebook ldJSON
  if succeeded result.status
    then pure $ Config.notebookUrl
         <> "#" <> (encodeURIPath $ printPath (path </> file name))
         <> "/edit"
    else throwError (error result.response)
  where
  notebookPath name = Config.dataUrl
                      </> rootify path
                      </> dir name
                      <./> Config.notebookExtension
                      </> file "index"

move :: forall e. R.Resource -> AnyPath -> Aff (RetryEffects (ajax :: AJAX |e)) AnyPath
move src tgt = do
  let url = if R.isDatabase src
            then Config.mountUrl
            else Config.dataUrl
  result <- slamjax $ defaultRequest
    { method = MOVE
    , headers = [RequestHeader "Destination" $ either printPath printPath tgt]
    , url = either
            (printPath <<< (url </>) <<< rootifyFile)
            (printPath <<< (url </>) <<< rootify)
            $ R.getPath src
    }
  if succeeded result.status
    then pure tgt
    else throwError (error result.response)

saveMount :: forall e. R.Resource -> String
             -> Aff (RetryEffects (ajax :: AJAX |e)) Unit
saveMount res uri = do
  result <- slamjax $ defaultRequest
            { method = PUT
            , headers = [ ContentType applicationJSON ]
            , content = Just $ stringify { mongodb: {connectionUri: uri } }
            , url = printPath
                    $ Config.mountUrl
                    </> rootify (R.resourceDir res)
                    </> dir (R.resourceName res)
            }
  if succeeded result.status
    then pure unit
    else throwError (error result.response)

foreign import stringify :: forall r. {|r} -> String

delete :: forall e. R.Resource
          -> Aff (RetryEffects (ajax :: AJAX |e)) (Maybe R.Resource)
delete resource =
  if not (R.isDatabase resource || alreadyInTrash resource)
  then
    moveToTrash resource
  else do
    forceDelete resource
    pure Nothing
  where
  msg :: String
  msg = "cannot delete"

  moveToTrash :: R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) (Maybe R.Resource)
  moveToTrash res = do
    let d = (res ^. R._root) </> dir Config.trashFolder
        path = (res # R._root .~ d) ^. R._path
    name <- getNewName d (res ^. R._name)
    move res (path # R._nameAnyPath .~ name)
    pure (Just $ R.Directory d)

  alreadyInTrash :: R.Resource -> Boolean
  alreadyInTrash res =
    case res ^. R._path of
      Left _ -> alreadyInTrash' (res ^. R._root)
      Right path -> alreadyInTrash' path

  alreadyInTrash' :: DirPath -> Boolean
  alreadyInTrash' d =
    if d == rootDir
    then false
    else maybe false go $ peel d

  go :: Tuple DirPath (Either DirName FileName) -> Boolean
  go (Tuple d name) =
    case name of
      Right _ -> false
      Left n -> if n == DirName Config.trashFolder
                then true
                else alreadyInTrash' d

forceDelete :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX |e)) Unit
forceDelete =
  getResponse "cannot delete"
  <<< either retryDelete retryDelete
  <<< pathFromResource

  where
  pathFromResource :: R.Resource -> AnyPath
  pathFromResource r = transplant (rootForResource r) (R.getPath r)

  transplant :: DirPath -> AnyPath -> AnyPath
  transplant newRoot =
    bimap
    (\p -> newRoot </> rootifyFile p)
    (\p -> newRoot </> rootify p)

  rootForResource :: R.Resource -> DirPath
  rootForResource r =
    if R.isDatabase r
    then Config.mountUrl
    else Config.dataUrl

getVersion :: forall e. Aff (RetryEffects (ajax :: AJAX |e)) (Maybe String)
getVersion = do
  serverInfo <- retryGet Config.Paths.serverInfoUrl
  return $ either (const Nothing) Just (readProp "version" serverInfo.response)

ldJSON :: MimeType
ldJSON = MimeType "application/ldjson"

loadNotebook
  :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX |e)) N.Notebook
loadNotebook res = do
  val <- getResponse "error loading notebook" $ retryGet
         $ Config.dataUrl
         </> rootify (R.resourceDir res)
         </> dir (R.resourceName res)
         </> file "index"
  case decodeJson (foreignToJson val) of
    Left err -> throwError $ error err
    Right nb -> pure nb
  where
-- TODO: Not this. either add to Argonaut, or make a Respondable Json instance
-- (requires "argonaut core" - https://github.com/slamdata/purescript-affjax/issues/16#issuecomment-93565447)
  foreignToJson :: Foreign -> Json
  foreignToJson = unsafeCoerce

-- | Produces a stream of the transitive children of a path
transitiveChildrenProducer
  :: forall e
   . (R.Resource -> Boolean)
  -> DirPath
  -> CR.Producer
      (Array R.Resource)
      (Aff (RetryEffects (ajax :: AJAX, err :: EXCEPTION | e)))
      Unit
transitiveChildrenProducer pred start = do
  ACR.produce \emit -> do
    runAff throwException (const (pure unit)) $ do
      let
        go start = do
          ei <- attempt $ children start
          case ei of
            Right items -> do
              let filteredItems = filter pred items
              liftEff $ emit (Left filteredItems)
              let parents = mapMaybe (either (const Nothing) Just <<< R.getPath) items
              traverse_ go parents
            Left _ ->
              liftEff $ emit (Right unit)
      go start

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Quasar.Aff where

import Prelude

import Config as Config
import Config.Paths as Config
import Control.Bind ((>=>))
import Control.Monad.Aff (Aff(), attempt)
import Control.Monad.Aff.AVar (AVAR())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Ref (REF())
import Control.Monad.Error.Class (throwError)
import Data.Argonaut
  ( Json(), jsonEmptyObject, jsonParser, decodeJson, (~>), (:=))
import Data.Array (head, tail, (:), findIndex)
import Data.Bifunctor (bimap)
import Data.Date (nowEpochMilliseconds, Now())
import Data.Either (Either(..), either)
import Data.Foldable (foldl)
import Data.Foreign (Foreign(), F(), parseJSON)
import Data.Foreign.Class (readProp, read, IsForeign)
import Data.Foreign.Index (prop)
import Data.Lens ((.~), (^.))
import Data.Maybe (Maybe(..), isJust, fromMaybe, maybe)
import Data.Path.Pathy
  ( Path(), Abs(), Sandboxed(), rootDir, relativeTo, (</>)
  , printPath, dir, file, peel, DirName(..), FileName(..))
import Data.String as S
import Data.Time (Milliseconds(..))
import Data.Tuple (Tuple(..))
import Model.Resource as R
import Model.Notebook as N
import Network.HTTP.Affjax
  ( Affjax(), AJAX(), AffjaxRequest(), AffjaxResponse(), RetryPolicy()
  , defaultRequest, affjax, retry, defaultRetryPolicy)
import Network.HTTP.Affjax.Request (Requestable)
import Network.HTTP.Affjax.Response (Respondable, ResponseType(JSONResponse))
import Network.HTTP.Method (Method(..))
import Network.HTTP.MimeType (MimeType(..), mimeTypeToString)
import Network.HTTP.MimeType.Common (applicationJSON)
import Network.HTTP.RequestHeader (RequestHeader(..))
import Network.HTTP.StatusCode (StatusCode(..))
import Unsafe.Coerce (unsafeCoerce)
import Utils.Path
  (DirPath(), FilePath(), AnyPath(), rootify, rootifyFile, (<./>), encodeURIPath)

newtype Listing = Listing (Array R.Resource)

runListing :: Listing -> Array R.Resource
runListing (Listing rs) = rs

instance listingIsForeign :: IsForeign Listing where
  read f = Listing <$> readProp "children" f

instance listingRespondable :: Respondable Listing where
  responseType = JSONResponse
  fromResponse = read

children :: forall e.
            DirPath -> Aff (RetryEffects (ajax :: AJAX | e)) (Array R.Resource)
children dir = do
  cs <- children' dir
  pure $ (R._root .~ dir) <$> cs

children' :: forall e.
             DirPath -> Aff (RetryEffects (ajax :: AJAX | e)) (Array R.Resource)
children' dir = runListing <$> (getResponse msg $ listing dir)
  where
  msg = "Error: can not get children of resource"

listing :: forall e. DirPath -> Affjax (RetryEffects e) Listing
listing p = maybe (throwError $ error "incorrect path")
            (\p -> retryGet $ (Config.metadataUrl </> p))
            $ relativeTo p rootDir

makeFile :: forall e. FilePath -> MimeType -> String
            -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
makeFile path mime content =
  getResponse msg go
  where
  msg :: String
  msg = "error while creating file"

  firstLine :: Maybe String
  firstLine = head $ S.split "\n" content

  isJson :: Either String Json
  isJson = maybe (Left "empty file") Right firstLine >>= jsonParser

  go :: Aff (RetryEffects (ajax :: AJAX | e)) (AffjaxResponse Unit)
  go = slamjax $ defaultRequest
   { method = PUT
   , headers = [ ContentType mime ]
   , content = Just content
   , url = fromMaybe ""
           $ (\x -> printPath
                    $ Config.dataUrl
                    </> x)
           <$> (relativeTo path rootDir)
   }

successStatus :: StatusCode
successStatus = StatusCode 200

succeeded :: StatusCode -> Boolean
succeeded (StatusCode int) =
  200 <= code && code < 300
  where code = int

type RetryEffects e = (avar :: AVAR, ref :: REF, now :: Now | e)

-- | A version of `affjax` with our retry policy.
slamjax :: forall e a b. (Requestable a, Respondable b) =>
           AffjaxRequest a -> Affjax (RetryEffects e) b
slamjax = retry defaultRetryPolicy affjax

retryGet :: forall e a fd. (Respondable a) =>
            Path Abs fd Sandboxed -> Affjax (RetryEffects e) a
retryGet =
  getWithPolicy { shouldRetryWithStatusCode: not <<< succeeded
                , delayCurve: const 1000
                , timeout: Just 30000
                }
getOnce :: forall e a fd. (Respondable a) =>
           Path Abs fd Sandboxed -> Affjax (RetryEffects e) a
getOnce = getWithPolicy defaultRetryPolicy

getWithPolicy :: forall e a fd. (Respondable a) =>
                 RetryPolicy -> Path Abs fd Sandboxed
                 -> Affjax (RetryEffects e) a
getWithPolicy policy u = do
  nocache <- liftEff $ nowEpochMilliseconds
  retry policy affjax defaultRequest { url = url' nocache }
  where
  url' nocache = url ++ symbol ++ "nocache=" ++ pretty nocache
  url = printPath u
  symbol = if S.contains "?" url then "&" else "?"
  pretty (Milliseconds ms) =
    let s = show ms
    in fromMaybe s (S.stripSuffix ".0" s)

retryDelete :: forall e a fd. (Respondable a) =>
               Path Abs fd Sandboxed -> Affjax (RetryEffects e) a
retryDelete u =
  slamjax $ defaultRequest { url = printPath u, method = DELETE }

retryPost :: forall e a b fd. (Requestable a, Respondable b) =>
             Path Abs fd Sandboxed -> a -> Affjax (RetryEffects e) b
retryPost u c =
  slamjax $ defaultRequest { method = POST, url = printPath u, content = Just c }

retryPut :: forall e a b fd. (Requestable a, Respondable b)
            => Path Abs fd Sandboxed -> a -> MimeType -> Affjax (RetryEffects e) b
retryPut u c mime =
  slamjax $ defaultRequest { method = PUT
                           , url = printPath u
                           , content = Just c
                           , headers = [ContentType mime] }

getResponse :: forall a e. String -> Affjax e a -> Aff (ajax :: AJAX | e) a
getResponse msg affjax = do
  res <- attempt affjax
  case res of
    Left e -> throwError $ error msg
    Right r -> do
      if not $ succeeded r.status
        then throwError $ error msg
        else pure r.response

reqHeadersToJSON :: Array RequestHeader -> Json
reqHeadersToJSON = foldl go jsonEmptyObject
  where
  go obj (Accept mime) = "Accept" := mimeTypeToString mime ~> obj
  go obj (ContentType mime) = "Content-Type" := mimeTypeToString mime ~> obj
  go obj (RequestHeader k v) = k := v ~> obj

mountInfo :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) String
mountInfo res = do

  let mountPath = (Config.mountUrl </> rootify (R.resourceDir res)) #
                  if R.resourceName res == ""
                  then id
                  else \x -> x </> dir (R.resourceName res)
  result <- getOnce mountPath
  if succeeded result.status
     then case parse result.response of
       Left err ->
         throwError $ error (show err)
       Right uri ->
         pure uri
     else throwError (error result.response)

  where
  parse :: String -> F String
  parse = parseJSON >=> prop "mongodb" >=> readProp "connectionUri"

getNewName :: forall e. DirPath -> String -> Aff (RetryEffects (ajax :: AJAX |e)) String
getNewName parent name = do
  items <- children' parent
  pure if exists' name items then getNewName' items 1 else name
  where
  getNewName' items i =
    let arr = S.split "." name
    in fromMaybe "" do
      body <- head arr
      suffixes <- tail arr
      let newName = S.joinWith "." $ (body <> " " <> show i):suffixes
      pure if exists' newName items
           then getNewName' items (i + one)
           else newName

exists' :: String -> Array R.Resource -> Boolean
exists' name items = isJust $ findIndex (\r -> r ^. R._name == name) items

-- Make dummy file in notebook specific folder.
-- It must be interpreted as empty notebook by notebook
-- component. Similar approach used in opening of data files, this
-- will help us decouple file and notebook subapps.
makeNotebook :: forall e. DirPath -> Aff (RetryEffects (ajax :: AJAX |e)) String
makeNotebook path = do
  name <- getNewName path (Config.newNotebookName <> "." <> Config.notebookExtension)
  result <- retryPut (notebookPath name) N.emptyNotebook ldJSON
  if succeeded result.status
    then pure $ Config.notebookUrl
         <> "#" <> (encodeURIPath $ printPath (path </> file name))
         <> "/edit"
    else throwError (error result.response)
  where
  notebookPath name = Config.dataUrl
                      </> rootify path
                      </> dir name
                      <./> Config.notebookExtension
                      </> file "index"

move :: forall e. R.Resource -> AnyPath -> Aff (RetryEffects (ajax :: AJAX |e)) AnyPath
move src tgt = do
  let url = if R.isDatabase src
            then Config.mountUrl
            else Config.dataUrl
  result <- slamjax $ defaultRequest
    { method = MOVE
    , headers = [RequestHeader "Destination" $ either printPath printPath tgt]
    , url = either
            (printPath <<< (url </>) <<< rootifyFile)
            (printPath <<< (url </>) <<< rootify)
            $ R.getPath src
    }
  if succeeded result.status
    then pure tgt
    else throwError (error result.response)

saveMount :: forall e. R.Resource -> String
             -> Aff (RetryEffects (ajax :: AJAX |e)) Unit
saveMount res uri = do
  result <- slamjax $ defaultRequest
            { method = PUT
            , headers = [ ContentType applicationJSON ]
            , content = Just $ stringify { mongodb: {connectionUri: uri } }
            , url = printPath
                    $ Config.mountUrl
                    </> rootify (R.resourceDir res)
                    </> dir (R.resourceName res)
            }
  if succeeded result.status
    then pure unit
    else throwError (error result.response)

foreign import stringify :: forall r. {|r} -> String

delete :: forall e. R.Resource
          -> Aff (RetryEffects (ajax :: AJAX |e)) (Maybe R.Resource)
delete resource =
  if not (R.isDatabase resource || alreadyInTrash resource)
  then
    moveToTrash resource
  else do
    forceDelete resource
    pure Nothing
  where
  msg :: String
  msg = "cannot delete"

  moveToTrash :: R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) (Maybe R.Resource)
  moveToTrash res = do
    let d = (res ^. R._root) </> dir Config.trashFolder
        path = (res # R._root .~ d) ^. R._path
    name <- getNewName d (res ^. R._name)
    move res (path # R._nameAnyPath .~ name)
    pure (Just $ R.Directory d)

  alreadyInTrash :: R.Resource -> Boolean
  alreadyInTrash res =
    case res ^. R._path of
      Left _ -> alreadyInTrash' (res ^. R._root)
      Right path -> alreadyInTrash' path

  alreadyInTrash' :: DirPath -> Boolean
  alreadyInTrash' d =
    if d == rootDir
    then false
    else maybe false go $ peel d

  go :: Tuple DirPath (Either DirName FileName) -> Boolean
  go (Tuple d name) =
    case name of
      Right _ -> false
      Left n -> if n == DirName Config.trashFolder
                then true
                else alreadyInTrash' d

forceDelete :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX |e)) Unit
forceDelete =
  getResponse "cannot delete"
  <<< either retryDelete retryDelete
  <<< pathFromResource

  where
  pathFromResource :: R.Resource -> AnyPath
  pathFromResource r = transplant (rootForResource r) (R.getPath r)

  transplant :: DirPath -> AnyPath -> AnyPath
  transplant newRoot =
    bimap
    (\p -> newRoot </> rootifyFile p)
    (\p -> newRoot </> rootify p)

  rootForResource :: R.Resource -> DirPath
  rootForResource r =
    if R.isDatabase r
    then Config.mountUrl
    else Config.dataUrl

getVersion :: forall e. Aff (RetryEffects (ajax :: AJAX |e)) (Maybe String)
getVersion = do
  serverInfo <- retryGet Config.Paths.serverInfoUrl
  return $ either (const Nothing) Just (readProp "version" serverInfo.response)

ldJSON :: MimeType
ldJSON = MimeType "application/ldjson"

loadNotebook
  :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX |e)) N.Notebook
loadNotebook res = do
  val <- getResponse "error loading notebook" $ retryGet
         $ Config.dataUrl
         </> rootify (R.resourceDir res)
         </> dir (R.resourceName res)
         </> file "index"
  case decodeJson (foreignToJson val) of
    Left err -> throwError $ error err
    Right nb -> pure nb
  where
-- TODO: Not this. either add to Argonaut, or make a Respondable Json instance
-- (requires "argonaut core" - https://github.com/slamdata/purescript-affjax/issues/16#issuecomment-93565447)
  foreignToJson :: Foreign -> Json
  foreignToJson = unsafeCoerce


Add more EXCEPT combinators

Add more EXCEPT combinators

module Run.Except
  ( Except(..)
  , EXCEPT
  , FAIL
  , _except
  , liftExcept
  , runExcept
  , runFail
  , throw
  , fail
  , rethrow
  , note
  , fromJust
  , catch
  ) where

import Prelude

import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), maybe')
import Run (Run, SProxy(..), FProxy)
import Run as Run

newtype Except e a = Except e

derive instance functorExcept ∷ Functor (Except e)

type EXCEPT e = FProxy (Except e)

type FAIL = EXCEPT Unit

_except ∷ SProxy "except"
_except = SProxy

liftExcept ∷ ∀ e a r. Except e a → Run (except ∷ EXCEPT e | r) a
liftExcept = Run.lift _except

throw ∷ ∀ e a r. e → Run (except ∷ EXCEPT e | r) a
throw = liftExcept <<< Except

fail ∷ ∀ a r. Run (except ∷ FAIL | r) a
fail = throw unit

rethrow ∷ ∀ e a r. Either e a → Run (except ∷ EXCEPT e | r) a
rethrow = either throw pure

note ∷ ∀ e a r. e → Maybe a → Run (except ∷ EXCEPT e | r) a
note e = maybe' (\_ → throw e) pure

fromJust ∷ ∀ a r. Maybe a → Run (except ∷ FAIL | r) a
fromJust = note unit

catch ∷ ∀ e a r. (e → Run r a) → Run (except ∷ EXCEPT e | r) a → Run r a
catch = loop
  where
  handle = Run.on _except Left Right
  loop k r = case Run.peel r of
    Left a → case handle a of
      Left (Except e) →
        k e
      Right a' →
        Run.send a' >>= catch k
    Right a →
      pure a

runExcept ∷ ∀ e a r. Run (except ∷ EXCEPT e | r) a → Run r (Either e a)
runExcept = loop
  where
  handle = Run.on _except Left Right
  loop r = case Run.peel r of
    Left a → case handle a of
      Left (Except e) →
        pure (Left e)
      Right a' →
        Run.send a' >>= runExcept
    Right a →
      pure (Right a)

runFail ∷ ∀ a r. Run (except ∷ FAIL | r) a → Run r (Maybe a)
runFail = map (either (const Nothing) Just) <<< runExcept

module Run.Except
  ( Except(..)
  , EXCEPT
  , FAIL
  , _except
  , liftExcept
  , runExcept
  , runFail
  , throw
  , fail
  , catch
  ) where

import Prelude
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..))
import Run (Run, SProxy(..), FProxy)
import Run as Run

newtype Except e a = Except e

derive instance functorExcept ∷ Functor (Except e)

type EXCEPT e = FProxy (Except e)

type FAIL = EXCEPT Unit

_except ∷ SProxy "except"
_except = SProxy

liftExcept ∷ ∀ e a r. Except e a → Run (except ∷ EXCEPT e | r) a
liftExcept = Run.lift _except

throw ∷ ∀ e a r. e → Run (except ∷ EXCEPT e | r) a
throw = liftExcept <<< Except

fail ∷ ∀ a r. Run (except ∷ FAIL | r) a
fail = throw unit

catch ∷ ∀ e a r. (e → Run r a) → Run (except ∷ EXCEPT e | r) a → Run r a
catch = loop
  where
  handle = Run.on _except Left Right
  loop k r = case Run.peel r of
    Left a → case handle a of
      Left (Except e) →
        k e
      Right a' →
        Run.send a' >>= catch k
    Right a →
      pure a

runExcept ∷ ∀ e a r. Run (except ∷ EXCEPT e | r) a → Run r (Either e a)
runExcept = loop
  where
  handle = Run.on _except Left Right
  loop r = case Run.peel r of
    Left a → case handle a of
      Left (Except e) →
        pure (Left e)
      Right a' →
        Run.send a' >>= runExcept
    Right a →
      pure (Right a)

runFail ∷ ∀ a r. Run (except ∷ FAIL | r) a → Run r (Maybe a)
runFail = map (either (const Nothing) Just) <<< runExcept


Generalize StrMap.unions to Foldable

Generalize StrMap.unions to Foldable

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

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

import Prelude

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

import Prelude

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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