also add in import after inserting the fix

module IdePurescript.Atom.Main where

import Prelude
import Control.Promise as Promise
import IdePurescript.Atom.Completion as C
import IdePurescript.Atom.Psci as Psci
import PscIde as P
import Atom.Atom (getAtom)
import Atom.CommandRegistry (COMMAND, addCommand)
import Atom.Config (CONFIG, getConfig)
import Atom.Editor (EDITOR, TextEditor, toEditor, onDidSave, getText, getPath, getTextInRange, setTextInBufferRange, setText, getBuffer, getCursorBufferPosition)
import Atom.NotificationManager (NOTIFY, addError)
import Atom.Point (Point, getRow, getColumn, mkPoint)
import Atom.Project (PROJECT)
import Atom.Range (mkRange, Range, getStart, getEnd)
import Atom.TextBuffer (setTextViaDiff)
import Atom.Workspace (WORKSPACE, onDidChangeActivePaneItem, observeTextEditors, getActiveTextEditor)
import Control.Bind (join)
import Control.Monad (when)
import Control.Monad.Aff (runAff, Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log, error)
import Control.Monad.Eff.Exception (Error, EXCEPTION)
import Control.Monad.Eff.Ref (REF, Ref, readRef, writeRef, newRef)
import Control.Monad.Error.Class (catchError)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT, lift)
import Control.Promise (Promise)
import DOM (DOM)
import DOM.Node.Types (Element)
import Data.Array (length)
import Data.Either (either, Either(..))
import Data.Foldable (intercalate)
import Data.Foreign (readBoolean)
import Data.Function.Eff (mkEffFn1)
import Data.Maybe (Maybe(Just, Nothing), maybe)
import IdePurescript.Atom.Build (AtomLintMessage)
import IdePurescript.Atom.BuildStatus (getBuildStatus)
import IdePurescript.Atom.Config (config)
import IdePurescript.Atom.Hooks.Dependencies (installDependencies)
import IdePurescript.Atom.Hooks.Linter (LinterInternal, LinterIndie, LINTER, register)
import IdePurescript.Atom.Hooks.StatusBar (addLeftTile)
import IdePurescript.Atom.LinterBuild (lint, getProjectRoot)
import IdePurescript.Atom.PromptPanel (addPromptPanel)
import IdePurescript.Atom.PscIdeServer (startServer)
import IdePurescript.Atom.QuickFixes (showQuickFixes)
import IdePurescript.Atom.SelectView (selectListViewStatic, selectListViewDynamic)
import IdePurescript.Atom.Tooltips (registerTooltips, getToken)
import IdePurescript.Modules (State, ImportResult(AmbiguousImport, UpdatedImports), getQualModule, addModuleImport, addExplicitImport, initialModulesState, getModulesForFile, getMainModule)
import IdePurescript.PscIde (getPursuitModuleCompletion, getPursuitCompletion, loadDeps, getAvailableModules, getCompletion, eitherToErr, getLoadedModules)
import Node.ChildProcess (CHILD_PROCESS)
import Node.FS (FS)
import PscIde (NET)
import PscIde.Command (Completion(..))

getSuggestions :: forall eff. State -> { editor :: TextEditor, bufferPosition :: Point }
  -> Eff (editor :: EDITOR, net :: NET, note :: NOTIFY | eff) (Promise (Array C.AtomSuggestion))
getSuggestions state ({editor, bufferPosition}) = Promise.fromAff $ flip catchError (raiseError' []) $ do
  let range = mkRange (mkPoint (getRow bufferPosition) 0) bufferPosition
  line <- liftEff $ getTextInRange editor range
  modules <- getLoadedModules -- getUnqualActiveModules state
  let getQualifiedModule = (flip getQualModule) state
  C.getSuggestions { line, moduleInfo: { modules, getQualifiedModule }}
  where
  raiseError' :: (Array C.AtomSuggestion) -> Error -> Aff (editor :: EDITOR, net :: NET, note :: NOTIFY | eff) (Array C.AtomSuggestion)
  raiseError' x e = do
    liftEff $ raiseError e
    pure x

useEditor :: forall eff. (Ref State) -> TextEditor -> Eff (editor ::EDITOR, net :: NET, ref :: REF, console :: CONSOLE | eff) Unit
useEditor modulesStateRef editor = do
  path <- getPath editor
  text <- getText editor
  let mainModule = getMainModule text
  case mainModule of
    Just m -> runAff logError ignoreError $ do
      loadDeps m
      state <- getModulesForFile path text
      liftEff $ writeRef modulesStateRef state
      pure unit
    Nothing -> pure unit

type MainEff =
  ( command :: COMMAND
  , note :: NOTIFY
  , project :: PROJECT
  , fs :: FS
  , ref :: REF
  , cp :: CHILD_PROCESS
  , console :: CONSOLE
  , config :: CONFIG
  , linter :: LINTER
  , editor :: EDITOR
  , net :: NET
  , workspace :: WORKSPACE
  , avar :: AVAR
  , err :: EXCEPTION
  , dom :: DOM
  )

main :: _
main = do
  atom <- getAtom
  linterIndieRef <- newRef (Nothing :: Maybe LinterIndie)
  modulesState <- newRef (initialModulesState)
  messagesRef <- newRef ([] :: Array AtomLintMessage)
  linterInternalRef <- newRef (Nothing :: Maybe LinterInternal)
  deactivateRef <- newRef (pure unit :: Eff MainEff Unit)
  buildStatusRef <- newRef (Nothing :: Maybe Element)

  let
    doLint :: Eff MainEff Unit
    doLint = do
      root <- getProjectRoot
      linterIndie <- readRef linterIndieRef
      statusElt <- readRef buildStatusRef
      case { root, linterIndie, statusElt } of
        { root: Just root', linterIndie: Just linterIndie', statusElt: Just statusElt' } -> runAff raiseError ignoreError $ do
          messages <- lint atom.config root' linterIndie' statusElt'
          liftEff $ maybe (pure unit) (writeRef messagesRef) messages
          editor <- liftEff $ getActiveTextEditor atom.workspace
          liftEff $ maybe (pure unit) (useEditor modulesState) editor
          pure unit
        _ -> pure unit

    quickFix :: Eff MainEff Unit
    quickFix = do
      messages <- readRef messagesRef
      editor <- getActiveTextEditor atom.workspace
      linter <- readRef linterInternalRef
      case { editor, linter, n: length messages } of
        { editor: Just e, linter: Just l, n } | n > 0 -> showQuickFixes e l messages
        _ -> pure unit

    pursuitSearch :: Eff MainEff Unit
    pursuitSearch = selectListViewDynamic view (\x -> log x.identifier) Nothing (const "") getPursuitCompletion 1000
      where
      view {identifier, "type": ty, "module": mod, package} =
         "
"
         ++ "
" ++ identifier ++ ": " ++ ty ++ "
"
         ++ "
" ++ mod ++ " (" ++ package ++ ")
"
         ++ "
"

    pursuitSearchModule :: Eff MainEff Unit
    pursuitSearchModule = selectListViewDynamic view importDialog (Just "module") id getPursuitModuleCompletion 1000
      where
      view {"module": mod, package} =
         "
"
         ++ "
" ++ mod ++ "
"
         ++ "
" ++ package ++ "
"
         ++ "
"
      importDialog :: forall a. {"module" :: String | a} -> Eff MainEff Unit
      importDialog {"module": mod} = selectListViewStatic textView (doImport mod) Nothing ["Import module", "Cancel"]
        where
        textView x = "
" ++ x ++ "
"
        doImport mod x = when (x == "Import module") $ addImport mod

    addModuleImportCmd :: Eff MainEff Unit
    addModuleImportCmd = runAff raiseError ignoreError do
      modules <- getAvailableModules
      liftEff $ selectListViewStatic view addImport Nothing modules
      where
        view x = "
" ++ x ++ "
"

    addExplicitImportCmd :: Eff MainEff Unit
    addExplicitImportCmd = runAff raiseError ignoreError do
      editor <- liftEff $ getActiveTextEditor atom.workspace
      case editor of
        Just ed -> do
          { line, col, pos, range } <- liftEff $ getLinePosition ed
          promptText <- liftEff $ maybe "" _.word <$> getToken ed pos
          res <- addPromptPanel "Identifier" promptText
          maybe (pure unit) (addIdentImport Nothing) res
        Nothing -> pure unit

    addIdentImport :: Maybe String -> String -> Aff MainEff Unit
    addIdentImport moduleName ident = do
      editor <- liftEff $ getActiveTextEditor atom.workspace
      maybe (pure unit) (addIdentImport' moduleName ident) editor

    addIdentImport' :: Maybe String -> String -> TextEditor -> Aff MainEff Unit
    addIdentImport' moduleName ident editor = do
      text <- liftEff $ getText editor
      path <- liftEff $ getPath editor
      state <- liftEff $ readRef modulesState
      { state: newState, result: output} <- addExplicitImport state path text moduleName ident
      liftEff $ writeRef modulesState newState
      liftEff $ case output of
        UpdatedImports out -> do
          buf <- getBuffer editor
          void $ setTextViaDiff buf out
        AmbiguousImport opts -> do
          selectListViewStatic view addImp Nothing (runCompletion <$> opts)
        _ -> pure unit
      where
      runCompletion (Completion obj) = obj
      -- TODO nicer if we can make select view aff-ish
      addImp { identifier, "module'": m } = runAff raiseError ignoreError $ addIdentImport (Just m) identifier
      view {identifier, "module'": m} = "
" ++ m ++ "." ++ identifier ++ "
"

    addSuggestionImport :: { editor :: TextEditor, suggestion :: C.AtomSuggestion } -> Aff MainEff Unit
    addSuggestionImport { editor, suggestion: { addImport: Just { mod, identifier, qualifier: Nothing } } } =
      addIdentImport' (Just mod) identifier editor
    addSuggestionImport _ = pure unit

    addImport :: String -> Eff MainEff Unit
    addImport moduleName = do
      maybeEditor <- getActiveTextEditor atom.workspace
      state <- liftEff $ readRef modulesState
      case maybeEditor of
        Nothing -> pure unit
        Just editor -> do
          text <- getText editor
          path <- getPath editor
          runAff raiseError ignoreError $ do
            output <- addModuleImport state path text moduleName
            liftEff $ maybe (pure unit) (void <<< setText editor <<< _.result) output

    localSearch :: Eff MainEff Unit
    localSearch = selectListViewDynamic view (\x -> log x.identifier) Nothing (const "") search 50
      where
      search text = do
        state <- liftEff $ readRef modulesState
        modules <- getLoadedModules
        let getQualifiedModule = (flip getQualModule) state
        getCompletion text "" false modules getQualifiedModule

      view {identifier, "type": ty, "module": mod} =
         "
"
         ++ "
" ++ identifier ++ ": " ++ ty ++ "
"
         ++ "
" ++ mod ++ "
"
         ++ "
"

    getLinePosition :: TextEditor -> Eff MainEff { line :: String, col :: Int, pos :: Point, range :: Range }
    getLinePosition ed = do
      pos <- getCursorBufferPosition ed
      let range = mkRange (mkPoint (getRow pos) 0) (mkPoint (getRow pos) 1000)
          col = getColumn pos
      line <- getTextInRange ed range
      pure { line, pos, col, range }

    caseSplit :: Eff MainEff Unit
    caseSplit = do
      runAff raiseError ignoreError $ runMaybeT body
      where
      body :: MaybeT (Aff MainEff) Unit
      body = do
        ed :: TextEditor <- MaybeT $ liftEff $ getActiveTextEditor atom.workspace
        { line, col, pos, range } <- lift $ liftEff $ getLinePosition ed
        { range: wordRange } <- MaybeT $ liftEff $ getToken ed pos
        ty <- MaybeT $ addPromptPanel "Parameter type" ""
        lines <- lift $ eitherToErr $ P.caseSplit line (getColumn $ getStart wordRange) (getColumn $ getEnd wordRange) true ty
        lift $ void $ liftEff $ setTextInBufferRange ed range $ intercalate "\n" lines

    addClause :: Eff MainEff Unit
    addClause = do
      editor <- getActiveTextEditor atom.workspace
      case editor of
        Just ed ->
          runAff raiseError ignoreError $ do
            { line, col, range } <- liftEff $ getLinePosition ed
            lines <- eitherToErr $ P.addClause line true
            liftEff $ setTextInBufferRange ed range $ intercalate "\n" lines
        Nothing -> pure unit

    fixTypo :: Eff MainEff Unit
    fixTypo = do
      runAff raiseError ignoreError $ runMaybeT body
      where
      body :: MaybeT (Aff MainEff) Unit
      body = do
        ed :: TextEditor <- MaybeT $ liftEff $ getActiveTextEditor atom.workspace
        { line, col, pos, range } <- lift $ liftEff $ getLinePosition ed
        { word, range: wordRange } <- MaybeT $ liftEff $ getToken ed pos
        corrections <- lift $ eitherToErr (P.suggestTypos word 2)
        liftEff $ selectListViewStatic view (replaceTypo ed wordRange) Nothing (runCompletion <$> corrections)
        where
          runCompletion (Completion obj) = obj
          replaceTypo ed wordRange { identifier, "module'": module' } =
            runAff raiseError ignoreError do
             liftEff $ setTextInBufferRange ed wordRange identifier
             addIdentImport (Just module') identifier
          view {identifier, "module'": m} = "
" ++ m ++ "." ++ identifier ++ "
"
          getIdentFromCompletion (Completion c) = c.identifier

    activate :: Eff MainEff Unit
    activate = do
      let cmd name action = addCommand atom.commands "atom-workspace" ("purescript:"++name) (const action)
      cmd "build" doLint
      cmd "show-quick-fixes" quickFix
      cmd "pursuit-search" pursuitSearch
      cmd "pursuit-search-modules" pursuitSearchModule
      cmd "add-module-import" addModuleImportCmd
      cmd "add-explicit-import" addExplicitImportCmd
      cmd "search" localSearch
      cmd "case-split" caseSplit
      cmd "add-clause" addClause
      cmd "fix-typo" fixTypo

      installDependencies

      observeTextEditors atom.workspace (\editor -> do -- TODO: Check if file is .purs
        useEditor modulesState editor
        onDidSave editor (\_ -> do
          buildOnSave <- getConfig atom.config "ide-purescript.buildOnSave"
          when (either (const false) id $ readBoolean buildOnSave) doLint -- TODO: Check if file is in project
        )
      )

      onDidChangeActivePaneItem atom.workspace (\item ->
        maybe (pure unit) (useEditor modulesState) (toEditor item)
      )

      registerTooltips modulesState
      runAff
        (\_ -> log "Error starting server")
        (\deact -> do
            writeRef deactivateRef deact
            editor <- getActiveTextEditor atom.workspace
            maybe (pure unit) (useEditor modulesState) editor)
        startServer
      Psci.init

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

  pure
    { config
    , activate: mkEffFn1 \_ -> activate
    , deactivate: mkEffFn1 \_ -> deactivate
    , consumeLinterIndie: mkEffFn1 \registry -> do
        linterIndie <- register registry {name: "PureScript"}
        writeRef linterIndieRef $ Just linterIndie
    , consumeLinterInternal: mkEffFn1 \linter ->
        writeRef linterInternalRef $ Just linter
    , consumeStatusBar: mkEffFn1 \statusBar -> do
        item <- getBuildStatus
        writeRef buildStatusRef $ Just item
        addLeftTile statusBar { item, priority: -50 }
    , provideAutocomplete: \_ ->
        { selector: ".source.purescript"
        , disableForSelector: ".source.purescript .comment, .source.purescript .string"
        , inclusionPriority: 1
        , excludeLowerPriority: true
        , getSuggestions: mkEffFn1 $ \x -> do
            state <- readRef modulesState
            getSuggestions state x
        , onDidInsertSuggestion: mkEffFn1 \x -> do
            shouldAddImport <- getConfig atom.config "ide-purescript.importOnAutocomplete"
            when (readBoolean shouldAddImport == Right true)
              (runAff raiseError ignoreError $ addSuggestionImport x)
        }
    }

raiseError :: forall eff. Error -> Eff (note :: NOTIFY | eff) Unit
raiseError e = do
  atom <- getAtom
  addError atom.notifications (show e)

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

logError :: forall eff. Error -> Eff (console :: CONSOLE | eff) Unit
logError e = error $ show e

module IdePurescript.Atom.Main where

import Prelude
import Control.Promise as Promise
import IdePurescript.Atom.Completion as C
import IdePurescript.Atom.Psci as Psci
import PscIde as P
import Atom.Atom (getAtom)
import Atom.CommandRegistry (COMMAND, addCommand)
import Atom.Config (CONFIG, getConfig)
import Atom.Editor (EDITOR, TextEditor, toEditor, onDidSave, getText, getPath, getTextInRange, setTextInBufferRange, setText, getBuffer, getCursorBufferPosition)
import Atom.NotificationManager (NOTIFY, addError)
import Atom.Point (Point, getRow, getColumn, mkPoint)
import Atom.Project (PROJECT)
import Atom.Range (mkRange, Range, getStart, getEnd)
import Atom.TextBuffer (setTextViaDiff)
import Atom.Workspace (WORKSPACE, onDidChangeActivePaneItem, observeTextEditors, getActiveTextEditor)
import Control.Bind (join)
import Control.Monad (when)
import Control.Monad.Aff (runAff, Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log, error)
import Control.Monad.Eff.Exception (Error, EXCEPTION)
import Control.Monad.Eff.Ref (REF, Ref, readRef, writeRef, newRef)
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)
import Control.Monad.Error.Class (catchError)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT, lift)
import Control.Promise (Promise)
import DOM (DOM)
import DOM.Node.Types (Element)
import Data.Array (length)
import Data.Either (either, Either(..))
import Data.Foldable (intercalate)
import Data.Foreign (readBoolean)
import Data.Function.Eff (mkEffFn1)
import Data.Maybe (Maybe(Just, Nothing), maybe)
import IdePurescript.Atom.Build (AtomLintMessage)
import IdePurescript.Atom.BuildStatus (getBuildStatus)
import IdePurescript.Atom.Config (config)
import IdePurescript.Atom.Hooks.Dependencies (installDependencies)
import IdePurescript.Atom.Hooks.Linter (LinterInternal, LinterIndie, LINTER, register)
import IdePurescript.Atom.Hooks.StatusBar (addLeftTile)
import IdePurescript.Atom.LinterBuild (lint, getProjectRoot)
import IdePurescript.Atom.PromptPanel (addPromptPanel)
import IdePurescript.Atom.PscIdeServer (startServer)
import IdePurescript.Atom.QuickFixes (showQuickFixes)
import IdePurescript.Atom.SelectView (selectListViewStatic, selectListViewDynamic)
import IdePurescript.Atom.Tooltips (registerTooltips, getToken)
import IdePurescript.Modules (State, ImportResult(AmbiguousImport, UpdatedImports), getQualModule, addModuleImport, addExplicitImport, initialModulesState, getModulesForFile, getMainModule)
import IdePurescript.PscIde (getPursuitModuleCompletion, getPursuitCompletion, loadDeps, getAvailableModules, getCompletion, eitherToErr, getLoadedModules)
import Node.ChildProcess (CHILD_PROCESS)
import Node.FS (FS)
import PscIde (NET)
import PscIde.Command (Completion(..))

getSuggestions :: forall eff. State -> { editor :: TextEditor, bufferPosition :: Point }
  -> Eff (editor :: EDITOR, net :: NET, note :: NOTIFY | eff) (Promise (Array C.AtomSuggestion))
getSuggestions state ({editor, bufferPosition}) = Promise.fromAff $ flip catchError (raiseError' []) $ do
  let range = mkRange (mkPoint (getRow bufferPosition) 0) bufferPosition
  line <- liftEff $ getTextInRange editor range
  modules <- getLoadedModules -- getUnqualActiveModules state
  let getQualifiedModule = (flip getQualModule) state
  C.getSuggestions { line, moduleInfo: { modules, getQualifiedModule }}
  where
  raiseError' :: (Array C.AtomSuggestion) -> Error -> Aff (editor :: EDITOR, net :: NET, note :: NOTIFY | eff) (Array C.AtomSuggestion)
  raiseError' x e = do
    liftEff $ raiseError e
    pure x

useEditor :: forall eff. (Ref State) -> TextEditor -> Eff (editor ::EDITOR, net :: NET, ref :: REF, console :: CONSOLE | eff) Unit
useEditor modulesStateRef editor = do
  path <- getPath editor
  text <- getText editor
  let mainModule = getMainModule text
  case mainModule of
    Just m -> runAff logError ignoreError $ do
      loadDeps m
      state <- getModulesForFile path text
      liftEff $ writeRef modulesStateRef state
      pure unit
    Nothing -> pure unit

type MainEff =
  ( command :: COMMAND
  , note :: NOTIFY
  , project :: PROJECT
  , fs :: FS
  , ref :: REF
  , cp :: CHILD_PROCESS
  , console :: CONSOLE
  , config :: CONFIG
  , linter :: LINTER
  , editor :: EDITOR
  , net :: NET
  , workspace :: WORKSPACE
  , avar :: AVAR
  , err :: EXCEPTION
  , dom :: DOM
  )

main :: _
main = do
  atom <- getAtom
  linterIndieRef <- newRef (Nothing :: Maybe LinterIndie)
  modulesState <- newRef (initialModulesState)
  messagesRef <- newRef ([] :: Array AtomLintMessage)
  linterInternalRef <- newRef (Nothing :: Maybe LinterInternal)
  deactivateRef <- newRef (pure unit :: Eff MainEff Unit)
  buildStatusRef <- newRef (Nothing :: Maybe Element)

  let
    doLint :: Eff MainEff Unit
    doLint = do
      root <- getProjectRoot
      linterIndie <- readRef linterIndieRef
      statusElt <- readRef buildStatusRef
      case { root, linterIndie, statusElt } of
        { root: Just root', linterIndie: Just linterIndie', statusElt: Just statusElt' } -> runAff raiseError ignoreError $ do
          messages <- lint atom.config root' linterIndie' statusElt'
          liftEff $ maybe (pure unit) (writeRef messagesRef) messages
          editor <- liftEff $ getActiveTextEditor atom.workspace
          liftEff $ maybe (pure unit) (useEditor modulesState) editor
          pure unit
        _ -> pure unit

    quickFix :: Eff MainEff Unit
    quickFix = do
      messages <- readRef messagesRef
      editor <- getActiveTextEditor atom.workspace
      linter <- readRef linterInternalRef
      case { editor, linter, n: length messages } of
        { editor: Just e, linter: Just l, n } | n > 0 -> showQuickFixes e l messages
        _ -> pure unit

    pursuitSearch :: Eff MainEff Unit
    pursuitSearch = selectListViewDynamic view (\x -> log x.identifier) Nothing (const "") getPursuitCompletion 1000
      where
      view {identifier, "type": ty, "module": mod, package} =
         "
"
         ++ "
" ++ identifier ++ ": " ++ ty ++ "
"
         ++ "
" ++ mod ++ " (" ++ package ++ ")
"
         ++ "
"

    pursuitSearchModule :: Eff MainEff Unit
    pursuitSearchModule = selectListViewDynamic view importDialog (Just "module") id getPursuitModuleCompletion 1000
      where
      view {"module": mod, package} =
         "
"
         ++ "
" ++ mod ++ "
"
         ++ "
" ++ package ++ "
"
         ++ "
"
      importDialog :: forall a. {"module" :: String | a} -> Eff MainEff Unit
      importDialog {"module": mod} = selectListViewStatic textView (doImport mod) Nothing ["Import module", "Cancel"]
        where
        textView x = "
" ++ x ++ "
"
        doImport mod x = when (x == "Import module") $ addImport mod

    addModuleImportCmd :: Eff MainEff Unit
    addModuleImportCmd = runAff raiseError ignoreError do
      modules <- getAvailableModules
      liftEff $ selectListViewStatic view addImport Nothing modules
      where
        view x = "
" ++ x ++ "
"

    addExplicitImportCmd :: Eff MainEff Unit
    addExplicitImportCmd = runAff raiseError ignoreError do
      editor <- liftEff $ getActiveTextEditor atom.workspace
      case editor of
        Just ed -> do
          { line, col, pos, range } <- liftEff $ getLinePosition ed
          promptText <- liftEff $ maybe "" _.word <$> getToken ed pos
          res <- addPromptPanel "Identifier" promptText
          maybe (pure unit) (addIdentImport Nothing) res
        Nothing -> pure unit

    addIdentImport :: Maybe String -> String -> Aff MainEff Unit
    addIdentImport moduleName ident = do
      editor <- liftEff $ getActiveTextEditor atom.workspace
      maybe (pure unit) (addIdentImport' moduleName ident) editor

    addIdentImport' :: Maybe String -> String -> TextEditor -> Aff MainEff Unit
    addIdentImport' moduleName ident editor = do
      text <- liftEff $ getText editor
      path <- liftEff $ getPath editor
      state <- liftEff $ readRef modulesState
      { state: newState, result: output} <- addExplicitImport state path text moduleName ident
      liftEff $ writeRef modulesState newState
      liftEff $ case output of
        UpdatedImports out -> do
          buf <- getBuffer editor
          void $ setTextViaDiff buf out
        AmbiguousImport opts -> do
          selectListViewStatic view addImp Nothing (runCompletion <$> opts)
        _ -> pure unit
      where
      runCompletion (Completion obj) = obj
      -- TODO nicer if we can make select view aff-ish
      addImp { identifier, "module'": m } = runAff raiseError ignoreError $ addIdentImport (Just m) identifier
      view {identifier, "module'": m} = "
" ++ m ++ "." ++ identifier ++ "
"

    addSuggestionImport :: { editor :: TextEditor, suggestion :: C.AtomSuggestion } -> Aff MainEff Unit
    addSuggestionImport { editor, suggestion: { addImport: Just { mod, identifier, qualifier: Nothing } } } =
      addIdentImport' (Just mod) identifier editor
    addSuggestionImport _ = pure unit

    addImport :: String -> Eff MainEff Unit
    addImport moduleName = do
      maybeEditor <- getActiveTextEditor atom.workspace
      state <- liftEff $ readRef modulesState
      case maybeEditor of
        Nothing -> pure unit
        Just editor -> do
          text <- getText editor
          path <- getPath editor
          runAff raiseError ignoreError $ do
            output <- addModuleImport state path text moduleName
            liftEff $ maybe (pure unit) (void <<< setText editor <<< _.result) output

    localSearch :: Eff MainEff Unit
    localSearch = selectListViewDynamic view (\x -> log x.identifier) Nothing (const "") search 50
      where
      search text = do
        state <- liftEff $ readRef modulesState
        modules <- getLoadedModules
        let getQualifiedModule = (flip getQualModule) state
        getCompletion text "" false modules getQualifiedModule

      view {identifier, "type": ty, "module": mod} =
         "
"
         ++ "
" ++ identifier ++ ": " ++ ty ++ "
"
         ++ "
" ++ mod ++ "
"
         ++ "
"

    getLinePosition :: TextEditor -> Eff MainEff { line :: String, col :: Int, pos :: Point, range :: Range }
    getLinePosition ed = do
      pos <- getCursorBufferPosition ed
      let range = mkRange (mkPoint (getRow pos) 0) (mkPoint (getRow pos) 1000)
          col = getColumn pos
      line <- getTextInRange ed range
      pure { line, pos, col, range }

    caseSplit :: Eff MainEff Unit
    caseSplit = do
      runAff raiseError ignoreError $ runMaybeT body
      where
      body :: MaybeT (Aff MainEff) Unit
      body = do
        ed :: TextEditor <- MaybeT $ liftEff $ getActiveTextEditor atom.workspace
        { line, col, pos, range } <- lift $ liftEff $ getLinePosition ed
        { range: wordRange } <- MaybeT $ liftEff $ getToken ed pos
        ty <- MaybeT $ addPromptPanel "Parameter type" ""
        lines <- lift $ eitherToErr $ P.caseSplit line (getColumn $ getStart wordRange) (getColumn $ getEnd wordRange) true ty
        lift $ void $ liftEff $ setTextInBufferRange ed range $ intercalate "\n" lines

    addClause :: Eff MainEff Unit
    addClause = do
      editor <- getActiveTextEditor atom.workspace
      case editor of
        Just ed ->
          runAff raiseError ignoreError $ do
            { line, col, range } <- liftEff $ getLinePosition ed
            lines <- eitherToErr $ P.addClause line true
            liftEff $ setTextInBufferRange ed range $ intercalate "\n" lines
        Nothing -> pure unit

    fixTypo :: Eff MainEff Unit
    fixTypo = do
      runAff raiseError ignoreError $ runMaybeT body
      where
      body :: MaybeT (Aff MainEff) Unit
      body = do
        ed :: TextEditor <- MaybeT $ liftEff $ getActiveTextEditor atom.workspace
        { line, col, pos, range } <- lift $ liftEff $ getLinePosition ed
        { word, range: wordRange } <- MaybeT $ liftEff $ getToken ed pos
        corrections <- lift $ eitherToErr (P.suggestTypos word 2)
        liftEff $ selectListViewStatic view (replaceTypo ed wordRange) Nothing (runCompletion <$> corrections)
        where
          runCompletion (Completion obj) = obj
          replaceTypo ed wordRange { identifier } = void $ unsafeInterleaveEff (setTextInBufferRange ed wordRange identifier)
          view {identifier, "module'": m} = "
" ++ m ++ "." ++ identifier ++ "
"
          getIdentFromCompletion (Completion c) = c.identifier

    activate :: Eff MainEff Unit
    activate = do
      let cmd name action = addCommand atom.commands "atom-workspace" ("purescript:"++name) (const action)
      cmd "build" doLint
      cmd "show-quick-fixes" quickFix
      cmd "pursuit-search" pursuitSearch
      cmd "pursuit-search-modules" pursuitSearchModule
      cmd "add-module-import" addModuleImportCmd
      cmd "add-explicit-import" addExplicitImportCmd
      cmd "search" localSearch
      cmd "case-split" caseSplit
      cmd "add-clause" addClause
      cmd "fix-typo" fixTypo

      installDependencies

      observeTextEditors atom.workspace (\editor -> do -- TODO: Check if file is .purs
        useEditor modulesState editor
        onDidSave editor (\_ -> do
          buildOnSave <- getConfig atom.config "ide-purescript.buildOnSave"
          when (either (const false) id $ readBoolean buildOnSave) doLint -- TODO: Check if file is in project
        )
      )

      onDidChangeActivePaneItem atom.workspace (\item ->
        maybe (pure unit) (useEditor modulesState) (toEditor item)
      )

      registerTooltips modulesState
      runAff
        (\_ -> log "Error starting server")
        (\deact -> do
            writeRef deactivateRef deact
            editor <- getActiveTextEditor atom.workspace
            maybe (pure unit) (useEditor modulesState) editor)
        startServer
      Psci.init

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

  pure
    { config
    , activate: mkEffFn1 \_ -> activate
    , deactivate: mkEffFn1 \_ -> deactivate
    , consumeLinterIndie: mkEffFn1 \registry -> do
        linterIndie <- register registry {name: "PureScript"}
        writeRef linterIndieRef $ Just linterIndie
    , consumeLinterInternal: mkEffFn1 \linter ->
        writeRef linterInternalRef $ Just linter
    , consumeStatusBar: mkEffFn1 \statusBar -> do
        item <- getBuildStatus
        writeRef buildStatusRef $ Just item
        addLeftTile statusBar { item, priority: -50 }
    , provideAutocomplete: \_ ->
        { selector: ".source.purescript"
        , disableForSelector: ".source.purescript .comment, .source.purescript .string"
        , inclusionPriority: 1
        , excludeLowerPriority: true
        , getSuggestions: mkEffFn1 $ \x -> do
            state <- readRef modulesState
            getSuggestions state x
        , onDidInsertSuggestion: mkEffFn1 \x -> do
            shouldAddImport <- getConfig atom.config "ide-purescript.importOnAutocomplete"
            when (readBoolean shouldAddImport == Right true)
              (runAff raiseError ignoreError $ addSuggestionImport x)
        }
    }

raiseError :: forall eff. Error -> Eff (note :: NOTIFY | eff) Unit
raiseError e = do
  atom <- getAtom
  addError atom.notifications (show e)

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

logError :: forall eff. Error -> Eff (console :: CONSOLE | eff) Unit
logError e = error $ show e


Avoid adding unqualified import for qualified completion #72

module LanguageServer.IdePurescript.Completion where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Class (liftEff)
import Data.Array as Arr
import Data.Maybe (Maybe(..))
import Data.Newtype (over, un, unwrap)
import Data.Nullable (toNullable)
import Data.String (length)
import IdePurescript.Completion (SuggestionResult(..), SuggestionType(..), getSuggestions)
import IdePurescript.Modules (getAllActiveModules, getQualModule, getUnqualActiveModules)
import IdePurescript.PscIde (getLoadedModules)
import LanguageServer.DocumentStore (getDocument)
import LanguageServer.Handlers (TextDocumentPositionParams)
import LanguageServer.IdePurescript.Commands (addCompletionImport)
import LanguageServer.IdePurescript.Config as Config
import LanguageServer.IdePurescript.Types (MainEff, ServerState)
import LanguageServer.TextDocument (getTextAtRange)
import LanguageServer.Types (CompletionItem(..), DocumentStore, Position(..), Range(..), Settings, TextDocumentIdentifier(..), TextEdit(..), completionItem, CompletionItemList(..))
import LanguageServer.Types as LS

getCompletions :: forall eff. DocumentStore -> Settings -> ServerState (MainEff eff) -> TextDocumentPositionParams -> Aff (MainEff eff) CompletionItemList
getCompletions docs settings state ({ textDocument, position }) = do
    let uri = _.uri $ un TextDocumentIdentifier textDocument
    doc <- liftEff $ getDocument docs uri
    line <- liftEff $ getTextAtRange doc (mkRange position)
    let autoCompleteAllModules = Config.autoCompleteAllModules settings
        { port, modules } = unwrap state
        getQualifiedModule = (flip getQualModule) modules

    case port of
        Just port' ->  do
            usedModules <- if autoCompleteAllModules
                then getLoadedModules port'
                else pure $ getUnqualActiveModules modules Nothing
            suggestions <- getSuggestions port'
                { line
                , moduleInfo: { modules: usedModules, getQualifiedModule, mainModule: modules.main, importedModules: getAllActiveModules modules }
                , maxResults: Config.autocompleteLimit settings
                , groupCompletions: Config.autocompleteGrouped settings
                , preferredModules: Config.importsPreferredModules settings
                }
            pure $ result $ convert uri <$> suggestions
        _ -> pure $ result []

    where
    result arr = CompletionItemList
        { items: arr
        , isIncomplete: Config.autocompleteLimit settings == Just (Arr.length arr)
        }
    mkRange (pos@ Position { line, character }) = Range
        { start: pos # over Position (_ { character = 0 })
        , end: pos
        }

    convertSuggest = case _ of
      Module -> LS.Module
      Value -> LS.Value
      Function -> LS.Function
      Type -> LS.Class

    convert _ (ModuleSuggestion { text, suggestType, prefix }) = completionItem text (convertSuggest suggestType)
    convert uri (IdentSuggestion { origMod, exportMod, identifier, qualifier, suggestType, prefix, valueType, exportedFrom }) =
        completionItem identifier (convertSuggest suggestType)
        # over CompletionItem (_
          { detail = toNullable $ Just valueType
          , documentation = toNullable $ Just exportText
          , command = toNullable $ case qualifier of
                Nothing -> Just $ addCompletionImport identifier (Just exportMod) uri
                Just _ -> Nothing
        --   , textEdit = toNullable $ Just edit
          })
        where
        exportText = if exportMod == origMod then origMod else exportMod <> " (re-exported from " <> origMod <> ")"

        edit = TextEdit
            { range: Range
                { start: position # over Position (\pos -> pos { character = pos.character - length prefix })
                , end: position
                }
            , newText: identifier
            }

module LanguageServer.IdePurescript.Completion where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Class (liftEff)
import Data.Array as Arr
import Data.Maybe (Maybe(..))
import Data.Newtype (over, un, unwrap)
import Data.Nullable (toNullable)
import Data.String (length)
import IdePurescript.Completion (SuggestionResult(..), SuggestionType(..), getSuggestions)
import IdePurescript.Modules (getAllActiveModules, getQualModule, getUnqualActiveModules)
import IdePurescript.PscIde (getLoadedModules)
import LanguageServer.DocumentStore (getDocument)
import LanguageServer.Handlers (TextDocumentPositionParams)
import LanguageServer.IdePurescript.Commands (addCompletionImport)
import LanguageServer.IdePurescript.Config as Config
import LanguageServer.IdePurescript.Types (MainEff, ServerState)
import LanguageServer.TextDocument (getTextAtRange)
import LanguageServer.Types (CompletionItem(..), DocumentStore, Position(..), Range(..), Settings, TextDocumentIdentifier(..), TextEdit(..), completionItem, CompletionItemList(..))
import LanguageServer.Types as LS

getCompletions :: forall eff. DocumentStore -> Settings -> ServerState (MainEff eff) -> TextDocumentPositionParams -> Aff (MainEff eff) CompletionItemList
getCompletions docs settings state ({ textDocument, position }) = do
    let uri = _.uri $ un TextDocumentIdentifier textDocument
    doc <- liftEff $ getDocument docs uri
    line <- liftEff $ getTextAtRange doc (mkRange position)
    let autoCompleteAllModules = Config.autoCompleteAllModules settings
        { port, modules } = unwrap state
        getQualifiedModule = (flip getQualModule) modules

    case port of
        Just port' ->  do
            usedModules <- if autoCompleteAllModules
                then getLoadedModules port'
                else pure $ getUnqualActiveModules modules Nothing
            suggestions <- getSuggestions port'
                { line
                , moduleInfo: { modules: usedModules, getQualifiedModule, mainModule: modules.main, importedModules: getAllActiveModules modules }
                , maxResults: Config.autocompleteLimit settings
                , groupCompletions: Config.autocompleteGrouped settings
                , preferredModules: Config.importsPreferredModules settings
                }
            pure $ result $ convert uri <$> suggestions
        _ -> pure $ result []

    where
    result arr = CompletionItemList
        { items: arr
        , isIncomplete: Config.autocompleteLimit settings == Just (Arr.length arr)
        }
    mkRange (pos@ Position { line, character }) = Range
        { start: pos # over Position (_ { character = 0 })
        , end: pos
        }

    convertSuggest = case _ of
      Module -> LS.Module
      Value -> LS.Value
      Function -> LS.Function
      Type -> LS.Class

    convert _ (ModuleSuggestion { text, suggestType, prefix }) = completionItem text (convertSuggest suggestType)
    convert uri (IdentSuggestion { origMod, exportMod, identifier, qualifier, suggestType, prefix, valueType, exportedFrom }) =
        completionItem identifier (convertSuggest suggestType)
        # over CompletionItem (_
          { detail = toNullable $ Just valueType
          , documentation = toNullable $ Just exportText
          , command = toNullable $ Just $ addCompletionImport identifier (Just exportMod) uri
        --   , textEdit = toNullable $ Just edit
          })
        where
        exportText = if exportMod == origMod then origMod else exportMod <> " (re-exported from " <> origMod <> ")"

        edit = TextEdit
            { range: Range
                { start: position # over Position (\pos -> pos { character = pos.character - length prefix })
                , end: position
                }
            , newText: identifier
            }


Add complete set of mouse events

Add complete set of mouse events

module Data.DOM.Simple.Events where

import Control.Monad.Eff
import Control.Monad

import Data.DOM.Simple.Types
import Data.DOM.Simple.Window(document, globalWindow)
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Unsafe.Events
import DOM

-- XXX Should this be in the Prelude?
class Read s where
  read :: String -> s

{- Generic properties and methods available on all events. -}

class Event e where
  eventTarget     :: forall eff a. e -> (Eff (dom :: DOM | eff) a)
  stopPropagation :: forall eff. e -> (Eff (dom :: DOM | eff) Unit)
  preventDefault  :: forall eff. e -> (Eff (dom :: DOM | eff) Unit)

instance eventDOMEvent :: Event DOMEvent where
  eventTarget     = unsafeEventTarget
  stopPropagation = unsafeStopPropagation
  preventDefault  = unsafePreventDefault

{- Mouse Events -}

data MouseEventType = MouseMoveEvent | MouseOverEvent | MouseEnterEvent
                    | MouseOutEvent | MouseLeaveEvent | MouseClickEvent
                    | MouseDblClickEvent | MouseUpEvent | MouseDownEvent

instance mouseEventTypeShow :: Show MouseEventType where
  show MouseMoveEvent     = "mousemove"
  show MouseOverEvent     = "mouseover"
  show MouseEnterEvent    = "mouseenter"
  show MouseOutEvent      = "mouseout"
  show MouseLeaveEvent    = "mouseleave"
  show MouseClickEvent    = "click"
  show MouseDblClickEvent = "dblclick"
  show MouseUpEvent       = "mouseup"
  show MouseDownEvent     = "mousedown"

instance mouseEventTypeRead :: Read MouseEventType where
  read "mousemove"  = MouseMoveEvent
  read "mouseover"  = MouseOverEvent
  read "mouseenter" = MouseEnterEvent
  read "mouseout"   = MouseOutEvent
  read "mouseleave" = MouseLeaveEvent
  read "click"      = MouseClickEvent
  read "dblclick"   = MouseDblClickEvent
  read "mouseup"    = MouseUpEvent
  read "mousedown"  = MouseDownEvent

class (Event e) <= MouseEvent e where
  mouseEventType :: forall eff. e -> (Eff (dom :: DOM | eff) MouseEventType)
  screenX :: forall eff. e -> (Eff (dom :: DOM | eff) Number)
  screenY :: forall eff. e -> (Eff (dom :: DOM | eff) Number)

instance mouseEventDOMEvent :: MouseEvent DOMEvent where
  mouseEventType ev = read <$> unsafeEventStringProp "type" ev
  screenX = unsafeEventNumberProp "screenX"
  screenY = unsafeEventNumberProp "screenY"

class MouseEventTarget b where
  addMouseEventListener :: forall e t ta. (MouseEvent e) =>
                           MouseEventType
                               -> (e -> Eff (dom :: DOM | t) Unit)
                               -> b
                               -> (Eff (dom :: DOM | ta) Unit)

  removeMouseEventListener :: forall e t ta. (MouseEvent e) =>
                              MouseEventType
                                  -> (e -> Eff (dom :: DOM | t) Unit)
                                  -> b
                                  -> (Eff (dom :: DOM | ta) Unit)

instance mouseEventTargetHTMLWindow :: MouseEventTarget HTMLWindow where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

instance mouseEventTargetHTMLDocument :: MouseEventTarget HTMLDocument where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

instance mouseEventTargetHTMLElement :: MouseEventTarget HTMLElement where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

{- Keyboard Events -}

data KeyboardEventType = KeydownEvent | KeypressEvent | KeyupEvent

instance keyboardEventTypeShow :: Show KeyboardEventType where
  show KeydownEvent     = "keydown"
  show KeypressEvent       = "keypress"
  show KeyupEvent       = "keyup"

instance keyboardEventTypeRead :: Read KeyboardEventType where
  read "keydown"  = KeydownEvent
  read "keypress" = KeypressEvent
  read "keyup"    = KeyupEvent

data KeyLocation = KeyLocationStandard | KeyLocationLeft | KeyLocationRight | KeyLocationNumpad

toKeyLocation :: Number -> KeyLocation
toKeyLocation 0 = KeyLocationStandard
toKeyLocation 1 = KeyLocationLeft
toKeyLocation 2 = KeyLocationRight
toKeyLocation 3 = KeyLocationNumpad

class (Event e) <= KeyboardEvent e where
  keyboardEventType :: forall eff. e -> (Eff (dom :: DOM | eff) KeyboardEventType)
  key         :: forall eff. e -> (Eff (dom :: DOM | eff) String)
  keyCode     :: forall eff. e -> (Eff (dom :: DOM | eff) Number)
  keyLocation :: forall eff. e -> (Eff (dom :: DOM | eff) KeyLocation)
  altKey      :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  ctrlKey     :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  metaKey     :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  shiftKey    :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)

instance keyboardEventDOMEvent :: KeyboardEvent DOMEvent where
  keyboardEventType ev = read <$> unsafeEventStringProp "type" ev

  key = unsafeEventKey
  keyCode = unsafeEventKeyCode

  keyLocation ev = toKeyLocation <$> unsafeEventNumberProp "keyLocation" ev

  altKey   = unsafeEventBooleanProp "altKey"
  ctrlKey  = unsafeEventBooleanProp "ctrlKey"
  metaKey  = unsafeEventBooleanProp "metaKey"
  shiftKey = unsafeEventBooleanProp "shiftKey"

class KeyboardEventTarget b where
  addKeyboardEventListener :: forall e t ta. (KeyboardEvent e) =>
                              KeyboardEventType
                                  -> (e -> Eff (dom :: DOM | t) Unit)
                                  -> b
                                  -> (Eff (dom :: DOM | ta) Unit)

  removeKeyboardEventListener :: forall e t ta. (KeyboardEvent e) =>
                                 KeyboardEventType
                                     -> (e -> Eff (dom :: DOM | t) Unit)
                                     -> b
                                     -> (Eff (dom :: DOM | ta) Unit)

instance keyboardEventTargetHTMLWindow :: KeyboardEventTarget HTMLWindow where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

instance keyboardEventTargetHTMLDocument :: KeyboardEventTarget HTMLDocument where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

instance keyboardEventTargetHTMLElement :: KeyboardEventTarget HTMLElement where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

{- UI Events -}

-- XXX this is slightly ham-handed, since
-- <http://www.w3.org/TR/DOM-Level-3-Events/#interface-UIEvent>
-- specifies that only some kinds of elements are valid targets for
-- each of these events.  Might make to refactor more carefully based
-- on what targets can accept what handlers.

data UIEventType = LoadEvent | UnloadEvent | AbortEvent
                 | ErrorEvent | SelectEvent | ResizeEvent
                 | ScrollEvent

instance uiEventTypeShow :: Show UIEventType where
  show LoadEvent    = "load"
  show UnloadEvent  = "unload"
  show AbortEvent   = "abort"
  show ErrorEvent   = "error"
  show SelectEvent  = "select"
  show ResizeEvent  = "resize"
  show ScrollEvent  = "scroll"

instance uiEventTypeRead :: Read UIEventType where
  read "load"     = LoadEvent
  read "unload"   = UnloadEvent
  read "abort"    = AbortEvent
  read "error"    = ErrorEvent
  read "select"   = SelectEvent
  read "resize"   = ResizeEvent
  read "scroll"   = ScrollEvent

class (Event e) <= UIEvent e where
  -- XXX this should really be returning an HTMLAbstractView...
  view   :: forall eff. e -> (Eff (dom :: DOM | eff) HTMLWindow)
  detail :: forall eff. e -> (Eff (dom :: DOM | eff) Number)

instance uiEventDOMEvent :: UIEvent DOMEvent where
  view   = unsafeEventView
  detail = unsafeEventNumberProp "detail"

class UIEventTarget b where
  addUIEventListener :: forall e t ta. (UIEvent e) =>
                        UIEventType
                            -> (e -> Eff (dom :: DOM | t) Unit)
                            -> b
                            -> (Eff (dom :: DOM | ta) Unit)

  removeUIEventListener :: forall e t ta. (UIEvent e) =>
                           UIEventType
                               -> (e -> Eff (dom :: DOM | t) Unit)
                               -> b
                               -> (Eff (dom :: DOM | ta) Unit)

instance uiEventTargetHTMLWindow :: UIEventTarget HTMLWindow where
  addUIEventListener typ    = unsafeAddEventListener (show typ)
  removeUIEventListener typ = unsafeRemoveEventListener (show typ)

{-
instance eventTargetXMLHttpRequest :: EventTarget XMLHttpRequest where
  addEventListener = unsafeAddEventListener
  removeEventListener = unsafeRemoveEventListener
-}

{-
ready :: forall t ta. (Eff (dom :: DOM | t) Unit) -> (Eff (dom :: DOM | ta) Unit)
ready cb = document globalWindow >>= (addEventListener "DOMContentLoaded" $ \_ -> cb)
-}

module Data.DOM.Simple.Events where

import Control.Monad.Eff
import Control.Monad

import Data.DOM.Simple.Types
import Data.DOM.Simple.Window(document, globalWindow)
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Unsafe.Events
import DOM

-- XXX Should this be in the Prelude?
class Read s where
  read :: String -> s

{- Generic properties and methods available on all events. -}

class Event e where
  eventTarget     :: forall eff a. e -> (Eff (dom :: DOM | eff) a)
  stopPropagation :: forall eff. e -> (Eff (dom :: DOM | eff) Unit)
  preventDefault  :: forall eff. e -> (Eff (dom :: DOM | eff) Unit)

instance eventDOMEvent :: Event DOMEvent where
  eventTarget     = unsafeEventTarget
  stopPropagation = unsafeStopPropagation
  preventDefault  = unsafePreventDefault

{- Mouse Events -}

data MouseEventType = MouseMoveEvent | MouseOverEvent | MouseEnterEvent
                    | MouseOutEvent | MouseLeaveEvent

instance mouseEventTypeShow :: Show MouseEventType where
  show MouseMoveEvent   = "mousemove"
  show MouseOverEvent   = "mouseover"
  show MouseEnterEvent  = "mouseenter"
  show MouseOutEvent    = "mouseout"
  show MouseLeaveEvent  = "mouseleave"

instance mouseEventTypeRead :: Read MouseEventType where
  read "mousemove"   = MouseMoveEvent
  read "mouseover"   = MouseOverEvent
  read "mouseenter"  = MouseEnterEvent
  read "mouseout"    = MouseOutEvent
  read "mouseleave"  = MouseLeaveEvent

class (Event e) <= MouseEvent e where
  mouseEventType :: forall eff. e -> (Eff (dom :: DOM | eff) MouseEventType)
  screenX :: forall eff. e -> (Eff (dom :: DOM | eff) Number)
  screenY :: forall eff. e -> (Eff (dom :: DOM | eff) Number)

instance mouseEventDOMEvent :: MouseEvent DOMEvent where
  mouseEventType ev = read <$> unsafeEventStringProp "type" ev
  screenX = unsafeEventNumberProp "screenX"
  screenY = unsafeEventNumberProp "screenY"

class MouseEventTarget b where
  addMouseEventListener :: forall e t ta. (MouseEvent e) =>
                           MouseEventType
                               -> (e -> Eff (dom :: DOM | t) Unit)
                               -> b
                               -> (Eff (dom :: DOM | ta) Unit)

  removeMouseEventListener :: forall e t ta. (MouseEvent e) =>
                              MouseEventType
                                  -> (e -> Eff (dom :: DOM | t) Unit)
                                  -> b
                                  -> (Eff (dom :: DOM | ta) Unit)

instance mouseEventTargetHTMLWindow :: MouseEventTarget HTMLWindow where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

instance mouseEventTargetHTMLDocument :: MouseEventTarget HTMLDocument where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

instance mouseEventTargetHTMLElement :: MouseEventTarget HTMLElement where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

{- Keyboard Events -}

data KeyboardEventType = KeydownEvent | KeypressEvent | KeyupEvent

instance keyboardEventTypeShow :: Show KeyboardEventType where
  show KeydownEvent     = "keydown"
  show KeypressEvent       = "keypress"
  show KeyupEvent       = "keyup"

instance keyboardEventTypeRead :: Read KeyboardEventType where
  read "keydown"  = KeydownEvent
  read "keypress" = KeypressEvent
  read "keyup"    = KeyupEvent

data KeyLocation = KeyLocationStandard | KeyLocationLeft | KeyLocationRight | KeyLocationNumpad

toKeyLocation :: Number -> KeyLocation
toKeyLocation 0 = KeyLocationStandard
toKeyLocation 1 = KeyLocationLeft
toKeyLocation 2 = KeyLocationRight
toKeyLocation 3 = KeyLocationNumpad

class (Event e) <= KeyboardEvent e where
  keyboardEventType :: forall eff. e -> (Eff (dom :: DOM | eff) KeyboardEventType)
  key         :: forall eff. e -> (Eff (dom :: DOM | eff) String)
  keyCode     :: forall eff. e -> (Eff (dom :: DOM | eff) Number)
  keyLocation :: forall eff. e -> (Eff (dom :: DOM | eff) KeyLocation)
  altKey      :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  ctrlKey     :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  metaKey     :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  shiftKey    :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)

instance keyboardEventDOMEvent :: KeyboardEvent DOMEvent where
  keyboardEventType ev = read <$> unsafeEventStringProp "type" ev

  key = unsafeEventKey
  keyCode = unsafeEventKeyCode

  keyLocation ev = toKeyLocation <$> unsafeEventNumberProp "keyLocation" ev

  altKey   = unsafeEventBooleanProp "altKey"
  ctrlKey  = unsafeEventBooleanProp "ctrlKey"
  metaKey  = unsafeEventBooleanProp "metaKey"
  shiftKey = unsafeEventBooleanProp "shiftKey"

class KeyboardEventTarget b where
  addKeyboardEventListener :: forall e t ta. (KeyboardEvent e) =>
                              KeyboardEventType
                                  -> (e -> Eff (dom :: DOM | t) Unit)
                                  -> b
                                  -> (Eff (dom :: DOM | ta) Unit)

  removeKeyboardEventListener :: forall e t ta. (KeyboardEvent e) =>
                                 KeyboardEventType
                                     -> (e -> Eff (dom :: DOM | t) Unit)
                                     -> b
                                     -> (Eff (dom :: DOM | ta) Unit)

instance keyboardEventTargetHTMLWindow :: KeyboardEventTarget HTMLWindow where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

instance keyboardEventTargetHTMLDocument :: KeyboardEventTarget HTMLDocument where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

instance keyboardEventTargetHTMLElement :: KeyboardEventTarget HTMLElement where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

{- UI Events -}

-- XXX this is slightly ham-handed, since
-- <http://www.w3.org/TR/DOM-Level-3-Events/#interface-UIEvent>
-- specifies that only some kinds of elements are valid targets for
-- each of these events.  Might make to refactor more carefully based
-- on what targets can accept what handlers.

data UIEventType = LoadEvent | UnloadEvent | AbortEvent
                 | ErrorEvent | SelectEvent | ResizeEvent
                 | ScrollEvent

instance uiEventTypeShow :: Show UIEventType where
  show LoadEvent    = "load"
  show UnloadEvent  = "unload"
  show AbortEvent   = "abort"
  show ErrorEvent   = "error"
  show SelectEvent  = "select"
  show ResizeEvent  = "resize"
  show ScrollEvent  = "scroll"

instance uiEventTypeRead :: Read UIEventType where
  read "load"     = LoadEvent
  read "unload"   = UnloadEvent
  read "abort"    = AbortEvent
  read "error"    = ErrorEvent
  read "select"   = SelectEvent
  read "resize"   = ResizeEvent
  read "scroll"   = ScrollEvent

class (Event e) <= UIEvent e where
  -- XXX this should really be returning an HTMLAbstractView...
  view   :: forall eff. e -> (Eff (dom :: DOM | eff) HTMLWindow)
  detail :: forall eff. e -> (Eff (dom :: DOM | eff) Number)

instance uiEventDOMEvent :: UIEvent DOMEvent where
  view   = unsafeEventView
  detail = unsafeEventNumberProp "detail"

class UIEventTarget b where
  addUIEventListener :: forall e t ta. (UIEvent e) =>
                        UIEventType
                            -> (e -> Eff (dom :: DOM | t) Unit)
                            -> b
                            -> (Eff (dom :: DOM | ta) Unit)

  removeUIEventListener :: forall e t ta. (UIEvent e) =>
                           UIEventType
                               -> (e -> Eff (dom :: DOM | t) Unit)
                               -> b
                               -> (Eff (dom :: DOM | ta) Unit)

instance uiEventTargetHTMLWindow :: UIEventTarget HTMLWindow where
  addUIEventListener typ    = unsafeAddEventListener (show typ)
  removeUIEventListener typ = unsafeRemoveEventListener (show typ)

{-
instance eventTargetXMLHttpRequest :: EventTarget XMLHttpRequest where
  addEventListener = unsafeAddEventListener
  removeEventListener = unsafeRemoveEventListener
-}

{-
ready :: forall t ta. (Eff (dom :: DOM | t) Unit) -> (Eff (dom :: DOM | ta) Unit)
ready cb = document globalWindow >>= (addEventListener "DOMContentLoaded" $ \_ -> cb)
-}


indexOf and lastIndexOf

indexOf and lastIndexOf

module CodePoints
  ( module StringReExports
  , CodePoint()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  , count
  , drop
  , dropWhile
  , fromCodePointArray
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , length
  , singleton
  , splitAt
  , take
  , takeWhile
  , toCodePointArray
  , uncons
  ) where

import Data.Array as Array
import Data.Char (toCharCode)
import Data.List (List(Cons, Nil), fromFoldable)
import Data.Maybe (Maybe(Just, Nothing))
import Data.String as String
import Data.String hiding (count, drop, dropWhile, indexOf, indexOf', lastIndexOf, lastIndexOf', length, singleton, splitAt, take, takeWhile, uncons) as StringReExports
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (unfoldr)
import Prelude ((&&), (||), (*), (+), (-), (<$>), (<), (<=), (<<<))

newtype CodePoint = CodePoint Int

codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

codePointFromSurrogatePair :: Int -> Int -> Maybe CodePoint
codePointFromSurrogatePair lead trail | isLead lead && isTrail trail
  = Just (unsurrogate lead trail)
codePointFromSurrogatePair _ _ = Nothing

unsurrogate :: Int -> Int -> CodePoint
unsurrogate h l = CodePoint ((h - 0xD800) * 0x400 + (l - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

codePointAt :: Int -> String -> Maybe CodePoint
codePointAt = _codePointAt codePointAtFallback Just Nothing

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

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = Array.index (toCodePointArray s) n

count :: (CodePoint -> Boolean) -> String -> Int
count = _count isLead isTrail unsurrogate

foreign import _count
  :: (Int -> Boolean)
  -> (Int -> Boolean)
  -> (Int -> Int -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

drop :: Int -> String -> String
drop n s = fromCodePointArray (Array.drop n (toCodePointArray s))

dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

foreign import fromCodePointArray :: Array CodePoint -> String

indexOf :: String.Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (String.take i s)) <$> String.indexOf p s

indexOf' :: String.Pattern -> Int -> String -> Maybe Int
indexOf' p i s = (\k -> length (String.take k s)) <$> String.indexOf' p i s

lastIndexOf :: String.Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (String.take i s)) <$> String.lastIndexOf p s

lastIndexOf' :: String.Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s = (\k -> length (String.take k s)) <$> String.lastIndexOf' p i s

length :: String -> Int
length = Array.length <<< toCodePointArray

foreign import singleton :: CodePoint -> String

splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt i s =
  let cps = toCodePointArray s in
  if i < 0 || Array.length cps <= i
    then Nothing
    else Just {
        before: fromCodePointArray (Array.take i cps),
        after: fromCodePointArray (Array.drop i cps)
      }

take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n s = fromCodePointArray (Array.take n (toCodePointArray s))

takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr decode (fromFoldable (toCharCode <$> String.toCharArray s))
  where
  decode :: List Int -> Maybe (Tuple CodePoint (List Int))
  decode (Cons h (Cons l rest)) | isLead h && isTrail l
    = Just (Tuple (unsurrogate h l) rest)
  decode (Cons c rest) = Just (Tuple (CodePoint c) rest)
  decode Nil = Nothing

uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s  = { head: _, tail: drop 1 s } <$> codePointAt 0 s

module CodePoints
  ( module StringReExports
  , CodePoint()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  , count
  , drop
  , dropWhile
  , fromCodePointArray
  --, indexOf
  --, indexOf'
  --, lastIndexOf
  --, lastIndexOf'
  , length
  , singleton
  , splitAt
  , take
  , takeWhile
  , toCodePointArray
  , uncons
  ) where

import Data.Array as Array
import Data.Char (toCharCode)
import Data.List (List(Cons, Nil), fromFoldable)
import Data.Maybe (Maybe(Just, Nothing))
import Data.String (toCharArray)
import Data.String hiding (count, drop, dropWhile, indexOf, indexOf', lastIndexOf, lastIndexOf', length, singleton, splitAt, take, takeWhile, uncons) as StringReExports
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (unfoldr)
import Prelude ((&&), (||), (*), (+), (-), (<$>), (<), (<=), (<<<))

newtype CodePoint = CodePoint Int

codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

codePointFromSurrogatePair :: Int -> Int -> Maybe CodePoint
codePointFromSurrogatePair lead trail | isLead lead && isTrail trail
  = Just (unsurrogate lead trail)
codePointFromSurrogatePair _ _ = Nothing

unsurrogate :: Int -> Int -> CodePoint
unsurrogate h l = CodePoint ((h - 0xD800) * 0x400 + (l - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

codePointAt :: Int -> String -> Maybe CodePoint
codePointAt = _codePointAt codePointAtFallback Just Nothing

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

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = Array.index (toCodePointArray s) n

count :: (CodePoint -> Boolean) -> String -> Int
count = _count isLead isTrail unsurrogate

foreign import _count
  :: (Int -> Boolean)
  -> (Int -> Boolean)
  -> (Int -> Int -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

drop :: Int -> String -> String
drop n s = fromCodePointArray (Array.drop n (toCodePointArray s))

dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

foreign import fromCodePointArray :: Array CodePoint -> String

length :: String -> Int
length = Array.length <<< toCodePointArray

foreign import singleton :: CodePoint -> String

splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt i s =
  let cps = toCodePointArray s in
  if i < 0 || Array.length cps <= i
    then Nothing
    else Just {
        before: fromCodePointArray (Array.take i cps),
        after: fromCodePointArray (Array.drop i cps)
      }

take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n s = fromCodePointArray (Array.take n (toCodePointArray s))

takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr decode (fromFoldable (toCharCode <$> toCharArray s))
  where
  decode :: List Int -> Maybe (Tuple CodePoint (List Int))
  decode (Cons h (Cons l rest)) | isLead h && isTrail l
    = Just (Tuple (unsurrogate h l) rest)
  decode (Cons c rest) = Just (Tuple (CodePoint c) rest)
  decode Nil = Nothing

uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s  = { head: _, tail: drop 1 s } <$> codePointAt 0 s


Remove test code

Remove test code

{-
Copyright 2016 SlamData, Inc.
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Markdown.Eval
  ( evalMarkdown
  , evalMarkdownForm
  ) where

import SlamData.Prelude

import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Writer.Class (class MonadTell)
import Data.Array as A
import Data.HugeNum as HN
import Data.Identity (Identity)
import Data.Int as Int
import Data.Json.Extended as EJSON
import Data.List as L
import Data.List.NonEmpty as NEL
import Data.NonEmpty ((:|))
import Data.String as S
import Data.StrMap as SM
import Matryoshka (project, transAna)
import SlamData.Effects (SlamDataEffects)
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Query as Quasar
import SlamData.SqlSquared.Tagged as SqlT
import SlamData.Workspace.Card.Error as CE
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Markdown.Component.State as MDS
import SlamData.Workspace.Card.Markdown.Model as MD
import SlamData.Workspace.Card.Port as Port
import SqlSquared as Sql
import Text.Markdown.SlamDown as SD
import Text.Markdown.SlamDown.Eval as SDE
import Text.Markdown.SlamDown.Halogen.Component.State as SDH
import Text.Markdown.SlamDown.Parser as SDP
import Text.Markdown.SlamDown.Traverse as SDT
import Text.Parsing.Parser (parseErrorMessage)
import Utils.Path (DirPath)

evalMarkdownForm
  ∷ ∀ m
  . MonadEff SlamDataEffects m
  ⇒ Monad m
  ⇒ MD.Model
  → SD.SlamDownP Port.VarMapValue
  → Port.DataMap
  → m Port.Out
evalMarkdownForm model doc varMap = do
  let inputState = SDH.formStateFromDocument doc
  thisVarMap ← liftEff $ MDS.formStateToVarMap inputState model
  pure (Port.Variables × map Right thisVarMap `SM.union` varMap)

evalMarkdown
  ∷ ∀ m
  . MonadEff SlamDataEffects m
  ⇒ MonadAsk CEM.CardEnv m
  ⇒ MonadThrow CE.CardError m
  ⇒ MonadTell CEM.CardLog m
  ⇒ QuasarDSL m
  ⇒ String
  → Port.DataMap
  → m Port.Out
evalMarkdown str varMap = do
  CEM.CardEnv { path } ← ask
  case SDP.parseMd str of
    Left e → CE.throwMarkdownError (CE.MarkdownParseError {markdown: str, error: e})
    Right sd → do
      let sm = map (Sql.print ∘ unwrap) $ Port.flattenResources varMap
      doc ← evalEmbeddedQueries sm path sd
      pure (Port.SlamDown doc × varMap)

findFields
  ∷ ∀ a
  . SD.SlamDownP a
  → Array String
findFields = SDT.everything (const mempty) extractField
  where
  extractField ∷ SD.Inline a → Array String
  extractField (SD.FormField label _ _) = pure label
  extractField _ = mempty

evalEmbeddedQueries
  ∷ ∀ m
  . MonadEff SlamDataEffects m
  ⇒ MonadThrow CE.CardError m
  ⇒ MonadTell CEM.CardLog m
  ⇒ QuasarDSL m
  ⇒ SM.StrMap String
  → DirPath
  → SD.SlamDownP Port.VarMapValue
  → m (SD.SlamDownP Port.VarMapValue)
evalEmbeddedQueries sm dir =
  SDE.eval
    { code: evalCode
    , textBox: evalTextBox
    , value: evalValue
    , list: evalList
    }

  where

  evalCode
    ∷ Maybe SDE.LanguageId
    → String
    → m Port.VarMapValue
  evalCode mid code
    | languageIsSql mid =
        Port.VarMapValue ∘ transAna Sql.Literal ∘ extractCodeValue <$> runQuery Nothing code
    | otherwise =
        pure $ Port.VarMapValue $ Sql.null

  extractCodeValue ∷ Array EJSON.EJson → EJSON.EJson
  extractCodeValue [ej] = extractSingletonObject ej
  extractCodeValue arr = EJSON.array arr

  languageIsSql
    ∷ Maybe SDE.LanguageId
    → Boolean
  languageIsSql =
    maybe true $ eq "sql" ∘ S.toLower

  extractSingletonObject
    ∷ EJSON.EJson
    → EJSON.EJson
  extractSingletonObject lit =
    case project lit of
      EJSON.Map (EJSON.EJsonMap [key × val]) → val
      _ → lit

  evalValue
    ∷ String
    → String
    → m Port.VarMapValue
  evalValue field code = do
    maybe
      (Port.VarMapValue Sql.null)
      (Port.VarMapValue ∘ transAna Sql.Literal ∘ extractSingletonObject)
      ∘ A.head
      <$> runQuery (Just field) code

  evalTextBox
    ∷ String
    → SD.TextBox (Const String)
    → m (SD.TextBox Identity)
  evalTextBox field tb = do
    let sql = unwrap $ SD.traverseTextBox (map \_ → Const unit) tb
    mresult ← A.head <$> runQuery (Just field) sql
    result ←
      maybe (CE.throwMarkdownError (CE.MarkdownNoTextBoxResults { field, sql })) (pure ∘ extractSingletonObject) mresult
    case tb, project result of
      (SD.PlainText _), (EJSON.String str) →
        pure ∘ SD.PlainText $ pure str
      (SD.Numeric _), (EJSON.Decimal a) →
        pure ∘ SD.Numeric $ pure a
      (SD.Numeric _), (EJSON.Integer a) →
        pure ∘ SD.Numeric $ pure (HN.fromNumber (Int.toNumber a))
      (SD.Time prec _), (EJSON.String time) →
        case SqlT.parseTime time of
          Left error → CE.throwMarkdownError (CE.MarkdownInvalidTimeValue { field, time, error })
          Right r → pure ∘ SD.Time prec $ pure r
      (SD.Date _), (EJSON.String date) →
        case SqlT.parseDate date of
          Left error → CE.throwMarkdownError (CE.MarkdownInvalidDateValue { field, date, error })
          Right r → pure ∘ SD.Date $ pure r
      (SD.DateTime prec _), (EJSON.String datetime) →
        case SqlT.parseDateTime datetime of
          Left error → CE.throwMarkdownError (CE.MarkdownInvalidDateTimeValue { field, datetime, error })
          Right r → pure ∘ SD.DateTime prec $ pure r
      _, _ →
        CE.throwMarkdownError (CE.MarkdownTypeError { field, actual: typeOf result, expected: typesOfField tb })

  -- TODO: use `Meta` when we have it to better determine types. -gb
  typeOf :: EJSON.EJson -> String
  typeOf = show ∘ EJSON.getType

  typesOfField :: ∀ a. SD.TextBox a -> NEL.NonEmptyList String
  typesOfField = case _ of
    SD.PlainText _ → pure "String"
    SD.Numeric _ → NEL.NonEmptyList $ "Number" :| pure "Integer"
    SD.Date _ → pure "Date"
    SD.Time _ _ → pure "Time"
    SD.DateTime _ _ → pure "Timestamp"

  evalList
    ∷ String
    → String
    → m (L.List Port.VarMapValue)
  evalList field code = do
    jitems ← map extractSingletonObject <$> runQuery (Just field) code
    let limit = 500
    pure ∘ L.fromFoldable
      $ if A.length jitems > limit
          then
            ( map (Port.VarMapValue ∘ transAna Sql.Literal) $ A.take limit jitems )
            ⊕ [ SD.stringValue $ "<" ⊕ show limit ⊕ "item limit reached>" ]
          else
          map (Port.VarMapValue ∘ transAna Sql.Literal) jitems

  runQuery
    ∷ Maybe String
    → String
    → m (Array EJSON.EJson)
  runQuery field code =
    let esql = Sql.parse code
    in case esql of
      Left error →
        CE.throwMarkdownError (CE.MarkdownSqlParseError { field, sql: code, error: parseErrorMessage error })
      Right sql → do
        {inputs} ← CE.liftQ $ Quasar.compile dir sql sm
        CEM.addSources inputs
        CE.liftQ $ Quasar.queryEJsonVM dir sql sm

{-
Copyright 2016 SlamData, Inc.
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Markdown.Eval
  ( evalMarkdown
  , evalMarkdownForm
  ) where

import SlamData.Prelude

import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Writer.Class (class MonadTell)
import Data.Array as A
import Data.HugeNum as HN
import Data.Identity (Identity)
import Data.Int as Int
import Data.Json.Extended as EJSON
import Data.List as L
import Data.List.NonEmpty as NEL
import Data.NonEmpty ((:|))
import Data.String as S
import Data.StrMap as SM
import Matryoshka (project, transAna)
import SlamData.Effects (SlamDataEffects)
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Query as Quasar
import SlamData.SqlSquared.Tagged as SqlT
import SlamData.Workspace.Card.Error as CE
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Markdown.Component.State as MDS
import SlamData.Workspace.Card.Markdown.Model as MD
import SlamData.Workspace.Card.Port as Port
import SqlSquared as Sql
import Text.Markdown.SlamDown as SD
import Text.Markdown.SlamDown.Eval as SDE
import Text.Markdown.SlamDown.Halogen.Component.State as SDH
import Text.Markdown.SlamDown.Parser as SDP
import Text.Markdown.SlamDown.Traverse as SDT
import Text.Parsing.Parser (parseErrorMessage)
import Utils.Path (DirPath)

evalMarkdownForm
  ∷ ∀ m
  . MonadEff SlamDataEffects m
  ⇒ Monad m
  ⇒ MD.Model
  → SD.SlamDownP Port.VarMapValue
  → Port.DataMap
  → m Port.Out
evalMarkdownForm model doc varMap = do
  let inputState = SDH.formStateFromDocument doc
  thisVarMap ← liftEff $ MDS.formStateToVarMap inputState model
  pure (Port.Variables × map Right thisVarMap `SM.union` varMap)

evalMarkdown
  ∷ ∀ m
  . MonadEff SlamDataEffects m
  ⇒ MonadAsk CEM.CardEnv m
  ⇒ MonadThrow CE.CardError m
  ⇒ MonadTell CEM.CardLog m
  ⇒ QuasarDSL m
  ⇒ String
  → Port.DataMap
  → m Port.Out
evalMarkdown str varMap = do
  CEM.CardEnv { path } ← ask
  case SDP.parseMd str of
    Left e → CE.throwMarkdownError (CE.MarkdownParseError {markdown: str, error: e})
    Right sd → do
      let sm = map (Sql.print ∘ unwrap) $ Port.flattenResources varMap
      doc ← evalEmbeddedQueries sm path sd
      pure (Port.SlamDown doc × varMap)

findFields
  ∷ ∀ a
  . SD.SlamDownP a
  → Array String
findFields = SDT.everything (const mempty) extractField
  where
  extractField ∷ SD.Inline a → Array String
  extractField (SD.FormField label _ _) = pure label
  extractField _ = mempty

evalEmbeddedQueries
  ∷ ∀ m
  . MonadEff SlamDataEffects m
  ⇒ MonadThrow CE.CardError m
  ⇒ MonadTell CEM.CardLog m
  ⇒ QuasarDSL m
  ⇒ SM.StrMap String
  → DirPath
  → SD.SlamDownP Port.VarMapValue
  → m (SD.SlamDownP Port.VarMapValue)
evalEmbeddedQueries sm dir =
  SDE.eval
    { code: evalCode
    , textBox: evalTextBox
    , value: evalValue
    , list: evalList
    }

  where

  evalCode
    ∷ Maybe SDE.LanguageId
    → String
    → m Port.VarMapValue
  evalCode mid code
    | languageIsSql mid =
        Port.VarMapValue ∘ transAna Sql.Literal ∘ extractCodeValue <$> runQuery Nothing code
    | otherwise =
        pure $ Port.VarMapValue $ Sql.null

  extractCodeValue ∷ Array EJSON.EJson → EJSON.EJson
  extractCodeValue [ej] = extractSingletonObject ej
  extractCodeValue arr = EJSON.array arr

  languageIsSql
    ∷ Maybe SDE.LanguageId
    → Boolean
  languageIsSql =
    maybe true $ eq "sql" ∘ S.toLower

  extractSingletonObject
    ∷ EJSON.EJson
    → EJSON.EJson
  extractSingletonObject lit =
    case project lit of
      EJSON.Map (EJSON.EJsonMap [key × val]) → val
      _ → lit

  evalValue
    ∷ String
    → String
    → m Port.VarMapValue
  evalValue field code = do
    maybe
      (Port.VarMapValue Sql.null)
      (Port.VarMapValue ∘ transAna Sql.Literal ∘ extractSingletonObject)
      ∘ A.head
      <$> runQuery (Just field) code

  evalTextBox
    ∷ String
    → SD.TextBox (Const String)
    → m (SD.TextBox Identity)
  evalTextBox field tb = do
    let sql = unwrap $ SD.traverseTextBox (map \_ → Const unit) tb
    mresult ← A.head <$> runQuery (Just field) sql
    result ←
      maybe (CE.throwMarkdownError (CE.MarkdownNoTextBoxResults { field, sql })) (pure ∘ extractSingletonObject) mresult
    case tb, project result of
      (SD.PlainText _), (EJSON.String str) →
        pure ∘ SD.PlainText $ pure str
      (SD.Numeric _), (EJSON.Decimal a) →
        pure ∘ SD.Numeric $ pure a
      (SD.Numeric _), (EJSON.Integer a) →
        pure ∘ SD.Numeric $ pure (HN.fromNumber (Int.toNumber a))
      (SD.Time prec _), (EJSON.String time) →
        case SqlT.parseTime time of
          Left error → CE.throwMarkdownError (CE.MarkdownInvalidTimeValue { field, time, error })
          Right r → pure ∘ SD.Time prec $ pure r
      (SD.Date _), (EJSON.String date) →
        case SqlT.parseDate date of
          Left error → CE.throwMarkdownError (CE.MarkdownInvalidDateValue { field, date, error })
          Right r → pure ∘ SD.Date $ pure r
      (SD.DateTime prec _), (EJSON.String datetime) →
        case SqlT.parseDateTime datetime of
          Left error → CE.throwMarkdownError (CE.MarkdownInvalidDateTimeValue { field, datetime, error })
          Right r → pure ∘ SD.DateTime prec $ pure r
      _, _ →
        CE.throwMarkdownError (CE.MarkdownTypeError { field, actual: typeOf result, expected: typesOfField tb })

  -- TODO: use `Meta` when we have it to better determine types. -gb
  typeOf :: EJSON.EJson -> String
  typeOf = show ∘ EJSON.getType

  typesOfField :: ∀ a. SD.TextBox a -> NEL.NonEmptyList String
  typesOfField = case _ of
    SD.PlainText _ → pure "String"
    SD.Numeric _ → NEL.NonEmptyList $ "Number" :| L.fromFoldable ["Integer", "Nugget"]
    SD.Date _ → pure "Date"
    SD.Time _ _ → pure "Time"
    SD.DateTime _ _ → pure "Timestamp"

  evalList
    ∷ String
    → String
    → m (L.List Port.VarMapValue)
  evalList field code = do
    jitems ← map extractSingletonObject <$> runQuery (Just field) code
    let limit = 500
    pure ∘ L.fromFoldable
      $ if A.length jitems > limit
          then
            ( map (Port.VarMapValue ∘ transAna Sql.Literal) $ A.take limit jitems )
            ⊕ [ SD.stringValue $ "<" ⊕ show limit ⊕ "item limit reached>" ]
          else
          map (Port.VarMapValue ∘ transAna Sql.Literal) jitems

  runQuery
    ∷ Maybe String
    → String
    → m (Array EJSON.EJson)
  runQuery field code =
    let esql = Sql.parse code
    in case esql of
      Left error →
        CE.throwMarkdownError (CE.MarkdownSqlParseError { field, sql: code, error: parseErrorMessage error })
      Right sql → do
        {inputs} ← CE.liftQ $ Quasar.compile dir sql sm
        CEM.addSources inputs
        CE.liftQ $ Quasar.queryEJsonVM dir sql sm


general type for Eff.Ref-backed cached functions

module Genetics.Browser.Config where

import Prelude

import Color (Color, rotateHue)
import Control.Alt ((<|>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (REF, Ref)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Reader (class MonadReader, ask)
import Data.Monoid (mempty)
import Data.Record as Record
import Data.Symbol (class IsSymbol, SProxy(..))
import Graphics.Drawing (Drawing)
import Type.Prelude (class RowLacks, class RowToList, RLProxy(..), SProxy(..))
import Type.Row (Cons, Nil, kind RowList)
import Unsafe.Coerce (unsafeCoerce)

type VScale =
  { color          :: Color
  , hPad           :: Number
  , numSteps       :: Int
  , yAxisFontSize  :: Int
  , yLabelFontSize :: Int }

_vscale = SProxy :: SProxy "vscale"

drawVScale :: VScale -> Drawing
drawVScale c = mempty

drawVScale' :: forall m r.
               MonadReader {vscale :: VScale | r} m
            => m Drawing
drawVScale' = do
  conf <- _.vscale <$> ask
  pure $ drawVScale conf

type Legend =
  { hPad     :: Number
  , vPad     :: Number
  , fontSize :: Int }

_legend = SProxy :: SProxy "legend"

drawLegend :: Legend -> Drawing
drawLegend _ = mempty

drawLegend' :: forall m r.
               MonadReader {legend :: Legend | r} m
            => m Drawing
drawLegend' = drawLegend <<< _.legend <$> ask

type BothR =
  ( vscale :: VScale
  , legend :: Legend )

type Both = Record BothR

aaa :: Both
aaa = { vscale: unsafeCoerce unit
      , legend: unsafeCoerce unit }

type BothRF =
  ( vscale :: VScale -> Drawing
  , legend :: Legend -> Drawing )

type BothF = Record BothRF

bbb :: BothF
bbb = { vscale: unsafeCoerce unit
      , legend: unsafeCoerce unit }

drawBoth :: Both -> Drawing
drawBoth c = drawVScale c.vscale <> drawLegend c.legend

drawBoth' :: forall m r.
            MonadReader Both m
         => m Drawing
drawBoth' = append <$> drawVScale' <*> drawLegend'
  -- a <- drawVScale'
  -- b <- drawLegend'
  -- pure $ a <> b

reactiveConfig :: forall a b.
                  (a -> b)
               -> a
               -> Eff _ { run :: Eff _ b
                        , getConfig :: Eff _ a
                        , modConfig :: (a -> a) -> Eff _ Unit }
reactiveConfig f i = do
  curArg <- Ref.newRef i

  let run = f <$> Ref.readRef curArg
      getConfig = Ref.readRef curArg
      modConfig = Ref.modifyRef curArg

  pure { run, getConfig, modConfig }

newtype RC a b =
  RC { run :: Eff (ref :: REF) b
     , getConfig :: Eff (ref :: REF) a
     , modConfig :: (a -> a) -> Eff (ref :: REF) Unit }

reactiveConfig' :: forall a b.
                  (a -> b)
               -> a
               -> Eff _ (RC a b)
reactiveConfig' f i = RC <$> reactiveConfig f i

doThing :: forall m a a' b b' t.
           Apply m
        => { theA :: a -> a'
           , theB :: b -> b' }
        -> { theA :: a
           , theB :: b }
        -> (forall x y. (x -> y) -> x -> m (t x y))
        -> m { theA :: t a a'
             , theB :: t b b'}
doThing funs confs g =
  { theA: _, theB: _ }
  <$> g funs.theA confs.theA
  <*> g funs.theB confs.theB

class RCSeqRecord
  ( rl   :: RowList )
  ( row  :: # Type  )
  ( row' :: # Type  )
  | rl -> row row'
  where
    rcSeqRecordImpl :: forall e.
                       RLProxy rl
                    -> Record row
                    -> Eff (ref :: REF | e) (Record row')

instance rcSeqRecordNil
  :: RCSeqRecord Nil row () where
    rcSeqRecordImpl _ _ = pure {}

instance rcSeqRecordCons
  :: ( IsSymbol name
     , RowCons  name (Eff e ty) trash row
     , RCSeqRecord tail row tailRow'
     , RowLacks name tailRow'
     , RowCons name ty tailRow' row'
     ) => RCSeqRecord (Cons name (Eff e ty) tail) row row'
     where
       rcSeqRecordImpl _ r = do
         let n = SProxy :: SProxy name
         a <- unsafeCoerceEff $ Record.get n r
         tail <- rcSeqRecordImpl (RLProxy :: RLProxy tail) r
         pure $ Record.insert n a tail

-- | don't export constructor
data Cached a b = C'ed (Ref a) (Ref b) (a -> b)

cache :: forall a b.
         (a -> b)
      -> a
      -> Eff _ (Cached a b)
cache f i = do
  let o = f i
  inRef  <- Ref.newRef i
  outRef <- Ref.newRef o
  pure $ C'ed inRef outRef f

readIn :: forall a b.
          Cached a b -> Eff _ a
readIn (C'ed i _ _) = Ref.readRef i

readOut :: forall a b.
           Cached a b -> Eff _ b
readOut (C'ed _ o _) = Ref.readRef o

modIn :: forall a b.
         (a -> a) -> Cached a b -> Eff _ (Cached a b)
modIn g c@(C'ed i o f) = do
  input <- g <$> Ref.readRef i
  let output = f input
  Ref.writeRef i input
  Ref.writeRef o output
  pure c

-- mapIn :: forall a b c.
--          (c -> a) -> c -> Cached a b -> Eff _ (Cached c b)
-- mapIn g (C'ed iR oR f) = do
--   let h = f <<< g

--   i <- Ref.readRef iR
--   let i' = g i

--   inRef  <- Ref.newRef $ i'
--   outRef <- Ref.newRef $ f i'
--   pure $ C'ed inRef

-- class RCApplyRecord
--   ( li :: RowList )
--   ( lf :: RowList )
--   ( ri :: # Type  )
--   ( rf :: # Type  )
--   ( ro :: # Type  )
--   | li -> ri
--   , lf -> rf
--   , li lf -> ro
--     where
--       rcApplyRecordImpl :: forall e.
--                            RLProxy li
--                         -> RLProxy lf
--                         -> Record ri
--                         -> Record rf
--                         -> Eff (ref :: REF | e) (Record ro)

-- instance rcApplyRecordNil
--   :: RCApplyRecord Nil Nil ri rf () where
--     rcApplyRecordImpl _ _ _ _ = pure {}

-- instance rcApplyRecordCons
--   :: ( IsSymbol name
--      , RowCons  name i trashI ri
--      , RowCons  name (i -> Eff (ref :: REF) o) trashF rf
--      , Row

-- class HKTApplyRecord
--   ( li :: RowList )
--   ( lf :: RowList )
--   ( ri :: # Type  )
--   ( rf :: # Type  )
--   ( ro :: # Type  )
--   ( f  ::   Type -> Type -> Type )
--   | li -> ri
--   , lf -> rf
--   , li lf -> ro
--     where
--       applyRecordImpl :: forall x y t.
--                          Applicative t
--                       => RLProxy li
--                       -> RLProxy lf
--                       -> (x -> y -> f x y)
--                       -> Record ri
--                       -> Record rf
--                       -> t (Record ro)

-- instance hktApplyRecordNilRC
--   :: HKTApplyRecord Nil Nil ri rf () RC where
--     applyRecordImpl _ _ _ _ _ = pure {}

-- instance hktApplyRecordCons
--   :: ( IsSymbol k
--      , RowCons  k i        trashI ri
--      , RowCons  k (i -> o) trashF rf
--      , RowCons  k (f i o ) rot    ro
--      , RowLacks k rot
--      , HKTApplyRecord ti tf ri rf rot RC
--      ) => HKTApplyRecord (Cons k i ti) (Cons k (i -> o) tf) ri rf ro RC
--      where
--        applyRecordImpl _ _ f ri rf =
--          let name = SProxy :: SProxy k
--              i = Record.get name ri
--              g = Record.get name rf
--              x :: f i o
--              x = f i g

--       doThingImpl :: RLProxy lc
--                   -> RLProxy lf
--                   -> Record rc
--                   -> Record rf
--                   -> Eff (ref :: REF) (Record ro)

-- class EffConfigRecord
--   ( lc :: RowList )
--   ( lf :: RowList )
--   -- ( lo :: RowList )
--   ( rc :: # Type  )
--   ( rf :: # Type  )
--   ( ro :: # Type  )
--   | lc -> rc
--   , lf -> rf
--   , lc lf -> ro
--   -- , lc lf -> lo, lf lo -> lc, lc lo -> lf
--     where
--       doThingImpl :: RLProxy lc
--                   -> RLProxy lf
--                   -> Record rc
--                   -> Record rf
--                   -> Eff (ref :: REF) (Record ro)

-- instance nilEffConfigRecord
--   :: EffConfigRecord Nil Nil () () () where
--     doThingImpl _ _ _ _ = pure {}

-- instance consEffConfigRecord
--   :: ( IsSymbol l
--      , RowCons  l a        trashC rc
--      , RowCons  l (a -> b) trashF rf
--      , RowCons  l (RC a b)       ro'    ro
--      , RowLacks l          ro'
--      , EffConfigRecord tc tf rc rf ro'
--      ) => EffConfigRecord (Cons l a tc) (Cons l (a -> b) tf) rc rf ro
--   where
--     doThingImpl _ _ rc rf = do
--       let c = Record.get (SProxy :: SProxy l) rc
--           f = Record.get (SProxy :: SProxy l) rf
--       o <- reactiveConfig' f c
--       t <- doThingImpl (RLProxy :: RLProxy tc) (RLProxy :: RLProxy tf) rc rf
--       pure $ Record.insert (SProxy :: SProxy l) o t

-- doThing :: forall lc lf rc rf ro.
--            EffConfigRecord lc lf rc rf ro
--         => Record rc
--         -> Record rf
--         -> Eff _ (Record ro)
-- doThing = doThingImpl (RLProxy :: RLProxy lc) (RLProxy :: RLProxy lf)

-- test :: forall lc lf rc rf ro.
--         RowToList BothR lc
--      => RowToList BothRF lf
--      => EffConfigRecord lc lf BothR BothRF ro
--      => Eff _ (Record ro)
-- test = doThing aaa bbb

-- test :: _
-- test = doThing aaa bbb

module Genetics.Browser.Config where

import Prelude

import Color (Color, rotateHue)
import Control.Alt ((<|>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Reader (class MonadReader, ask)
import Data.Monoid (mempty)
import Data.Record as Record
import Data.Symbol (class IsSymbol, SProxy(..))
import Graphics.Drawing (Drawing)
import Type.Prelude (class RowLacks, class RowToList, RLProxy(..), SProxy(..))
import Type.Row (Cons, Nil, kind RowList)
import Unsafe.Coerce (unsafeCoerce)

type VScale =
  { color          :: Color
  , hPad           :: Number
  , numSteps       :: Int
  , yAxisFontSize  :: Int
  , yLabelFontSize :: Int }

_vscale = SProxy :: SProxy "vscale"

drawVScale :: VScale -> Drawing
drawVScale c = mempty

drawVScale' :: forall m r.
               MonadReader {vscale :: VScale | r} m
            => m Drawing
drawVScale' = do
  conf <- _.vscale <$> ask
  pure $ drawVScale conf

type Legend =
  { hPad     :: Number
  , vPad     :: Number
  , fontSize :: Int }

_legend = SProxy :: SProxy "legend"

drawLegend :: Legend -> Drawing
drawLegend _ = mempty

drawLegend' :: forall m r.
               MonadReader {legend :: Legend | r} m
            => m Drawing
drawLegend' = drawLegend <<< _.legend <$> ask

type BothR =
  ( vscale :: VScale
  , legend :: Legend )

type Both = Record BothR

aaa :: Both
aaa = { vscale: unsafeCoerce unit
      , legend: unsafeCoerce unit }

type BothRF =
  ( vscale :: VScale -> Drawing
  , legend :: Legend -> Drawing )

type BothF = Record BothRF

bbb :: BothF
bbb = { vscale: unsafeCoerce unit
      , legend: unsafeCoerce unit }

drawBoth :: Both -> Drawing
drawBoth c = drawVScale c.vscale <> drawLegend c.legend

drawBoth' :: forall m r.
            MonadReader Both m
         => m Drawing
drawBoth' = append <$> drawVScale' <*> drawLegend'
  -- a <- drawVScale'
  -- b <- drawLegend'
  -- pure $ a <> b

reactiveConfig :: forall a b.
                  (a -> b)
               -> a
               -> Eff _ { run :: Eff _ b
                        , getConfig :: Eff _ a
                        , modConfig :: (a -> a) -> Eff _ Unit }
reactiveConfig f i = do
  curArg <- Ref.newRef i

  let run = f <$> Ref.readRef curArg
      getConfig = Ref.readRef curArg
      modConfig = Ref.modifyRef curArg

  pure { run, getConfig, modConfig }

newtype RC a b =
  RC { run :: Eff (ref :: REF) b
     , getConfig :: Eff (ref :: REF) a
     , modConfig :: (a -> a) -> Eff (ref :: REF) Unit }

reactiveConfig' :: forall a b.
                  (a -> b)
               -> a
               -> Eff _ (RC a b)
reactiveConfig' f i = RC <$> reactiveConfig f i

doThing :: forall m a a' b b' t.
           Apply m
        => { theA :: a -> a'
           , theB :: b -> b' }
        -> { theA :: a
           , theB :: b }
        -> (forall x y. (x -> y) -> x -> m (t x y))
        -> m { theA :: t a a'
             , theB :: t b b'}
doThing funs confs g =
  { theA: _, theB: _ }
  <$> g funs.theA confs.theA
  <*> g funs.theB confs.theB

class RCSeqRecord
  ( rl   :: RowList )
  ( row  :: # Type  )
  ( row' :: # Type  )
  | rl -> row row'
  where
    rcSeqRecordImpl :: forall e.
                       RLProxy rl
                    -> Record row
                    -> Eff (ref :: REF | e) (Record row')

instance rcSeqRecordNil
  :: RCSeqRecord Nil row () where
    rcSeqRecordImpl _ _ = pure {}

instance rcSeqRecordCons
  :: ( IsSymbol name
     , RowCons  name (Eff e ty) trash row
     , RCSeqRecord tail row tailRow'
     , RowLacks name tailRow'
     , RowCons name ty tailRow' row'
     ) => RCSeqRecord (Cons name (Eff e ty) tail) row row'
     where
       rcSeqRecordImpl _ r = do
         let n = SProxy :: SProxy name
         a <- unsafeCoerceEff $ Record.get n r
         tail <- rcSeqRecordImpl (RLProxy :: RLProxy tail) r
         pure $ Record.insert n a tail

-- class RCApplyRecord
--   ( li :: RowList )
--   ( lf :: RowList )
--   ( ri :: # Type  )
--   ( rf :: # Type  )
--   ( ro :: # Type  )
--   | li -> ri
--   , lf -> rf
--   , li lf -> ro
--     where
--       rcApplyRecordImpl :: forall e.
--                            RLProxy li
--                         -> RLProxy lf
--                         -> Record ri
--                         -> Record rf
--                         -> Eff (ref :: REF | e) (Record ro)

-- instance rcApplyRecordNil
--   :: RCApplyRecord Nil Nil ri rf () where
--     rcApplyRecordImpl _ _ _ _ = pure {}

-- instance rcApplyRecordCons
--   :: ( IsSymbol name
--      , RowCons  name i trashI ri
--      , RowCons  name (i -> Eff (ref :: REF) o) trashF rf
--      , Row

-- class HKTApplyRecord
--   ( li :: RowList )
--   ( lf :: RowList )
--   ( ri :: # Type  )
--   ( rf :: # Type  )
--   ( ro :: # Type  )
--   ( f  ::   Type -> Type -> Type )
--   | li -> ri
--   , lf -> rf
--   , li lf -> ro
--     where
--       applyRecordImpl :: forall x y t.
--                          Applicative t
--                       => RLProxy li
--                       -> RLProxy lf
--                       -> (x -> y -> f x y)
--                       -> Record ri
--                       -> Record rf
--                       -> t (Record ro)

-- instance hktApplyRecordNilRC
--   :: HKTApplyRecord Nil Nil ri rf () RC where
--     applyRecordImpl _ _ _ _ _ = pure {}

-- instance hktApplyRecordCons
--   :: ( IsSymbol k
--      , RowCons  k i        trashI ri
--      , RowCons  k (i -> o) trashF rf
--      , RowCons  k (f i o ) rot    ro
--      , RowLacks k rot
--      , HKTApplyRecord ti tf ri rf rot RC
--      ) => HKTApplyRecord (Cons k i ti) (Cons k (i -> o) tf) ri rf ro RC
--      where
--        applyRecordImpl _ _ f ri rf =
--          let name = SProxy :: SProxy k
--              i = Record.get name ri
--              g = Record.get name rf
--              x :: f i o
--              x = f i g

--       doThingImpl :: RLProxy lc
--                   -> RLProxy lf
--                   -> Record rc
--                   -> Record rf
--                   -> Eff (ref :: REF) (Record ro)

doThing funs confs = do
  theA <- reactiveConfig' funs.theA confs.theA
  theB <- reactiveConfig' funs.theB confs.theB
  pure { theA, theB }

-- class EffConfigRecord
--   ( lc :: RowList )
--   ( lf :: RowList )
--   -- ( lo :: RowList )
--   ( rc :: # Type  )
--   ( rf :: # Type  )
--   ( ro :: # Type  )
--   | lc -> rc
--   , lf -> rf
--   , lc lf -> ro
--   -- , lc lf -> lo, lf lo -> lc, lc lo -> lf
--     where
--       doThingImpl :: RLProxy lc
--                   -> RLProxy lf
--                   -> Record rc
--                   -> Record rf
--                   -> Eff (ref :: REF) (Record ro)

-- instance nilEffConfigRecord
--   :: EffConfigRecord Nil Nil () () () where
--     doThingImpl _ _ _ _ = pure {}

-- instance consEffConfigRecord
--   :: ( IsSymbol l
--      , RowCons  l a        trashC rc
--      , RowCons  l (a -> b) trashF rf
--      , RowCons  l (RC a b)       ro'    ro
--      , RowLacks l          ro'
--      , EffConfigRecord tc tf rc rf ro'
--      ) => EffConfigRecord (Cons l a tc) (Cons l (a -> b) tf) rc rf ro
--   where
--     doThingImpl _ _ rc rf = do
--       let c = Record.get (SProxy :: SProxy l) rc
--           f = Record.get (SProxy :: SProxy l) rf
--       o <- reactiveConfig' f c
--       t <- doThingImpl (RLProxy :: RLProxy tc) (RLProxy :: RLProxy tf) rc rf
--       pure $ Record.insert (SProxy :: SProxy l) o t

-- doThing :: forall lc lf rc rf ro.
--            EffConfigRecord lc lf rc rf ro
--         => Record rc
--         -> Record rf
--         -> Eff _ (Record ro)
-- doThing = doThingImpl (RLProxy :: RLProxy lc) (RLProxy :: RLProxy lf)

-- test :: forall lc lf rc rf ro.
--         RowToList BothR lc
--      => RowToList BothRF lf
--      => EffConfigRecord lc lf BothR BothRF ro
--      => Eff _ (Record ro)
-- test = doThing aaa bbb

-- test :: _
-- test = doThing aaa bbb