adds fix-typo command

adds fix-typo command

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

module IdePurescript.Atom.Main where

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.Maybe.Trans (MaybeT(MaybeT), runMaybeT, lift)
import Control.Monad.Error.Class (catchError)
import Control.Promise (Promise)
import Control.Promise as 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.Completion as C
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.Psci as Psci
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 Prelude
import PscIde (NET)
import PscIde as P
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

    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

      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


use absurd  for handling void case

use absurd  for handling void case

module Test.Spec.Reporter.Base
  ( defaultSummary
  , defaultReporter
  , defaultUpdate
  , RunningItem(..)
  ) where

import Prelude

import Control.Monad.State (StateT, evalStateT, execStateT, get, gets, put)
import Control.Monad.State as State
import Control.Monad.Trans.Class (lift)
import Control.Monad.Writer (class MonadWriter, Writer, runWriter)
import Data.Either (Either(..))
import Data.Foldable (all, for_, intercalate, traverse_)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.List (List(..), (:), reverse)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), isJust)
import Data.Tuple (Tuple(..), uncurry)
import Effect.Class (liftEffect)
import Effect.Exception as Error
import Pipes (await, yield)
import Pipes.Core (Pipe)
import Test.Spec (Tree)
import Test.Spec as S
import Test.Spec.Console (tellLn)
import Test.Spec.Console as Console
import Test.Spec.Result (Result(..))
import Test.Spec.Runner (Reporter)
import Test.Spec.Runner.Event (Event)
import Test.Spec.Runner.Event as Event
import Test.Spec.Style (styled)
import Test.Spec.Style as Style
import Test.Spec.Summary (Summary(..))
import Test.Spec.Summary as Summary
import Test.Spec.Tree (Path)

defaultSummary :: forall m
   . MonadWriter String m
  => Array (Tree Void Result)
  -> m Unit
defaultSummary xs = do
  case Summary.summarize xs of
    (Count {passed, failed, pending}) -> do
      when (passed  > 0) $ tellLn $ styled Style.green $ show passed  <> " passing"
      when (pending > 0) $ tellLn $ styled Style.cyan $ show pending <> " pending"
      when (failed  > 0) $ tellLn $ styled Style.red $ show failed  <> " failed"
  tellLn ""
  printFailures xs

printFailures
  :: forall m
   . MonadWriter String m
  => Array (Tree Void Result)
  -> m Unit
printFailures xs' = evalStateT (go xs') {i: 0, crumbs: Nil}
  where
    go :: Array (Tree Void Result) -> StateT { i :: Int, crumbs :: List String } m Unit
    go = traverse_ case _ of
      S.Node (Left n) xs -> do
        {crumbs} <- State.get
        State.modify_ _{crumbs = n : crumbs}
        go xs
        State.modify_ _{crumbs = crumbs}
      S.Node (Right v) xs -> absurd v
      S.Leaf n (Just (Failure err)) -> do
        {i, crumbs} <- State.modify \s -> s{i = s.i +1}
        let label = intercalate " " (reverse $ n:crumbs)
        tellLn $ show i <> ") " <> label
        tellLn $ styled Style.red $ Style.indent 2 <> Error.message err
      S.Leaf _ _ -> pure unit

-- | Monadic left scan with state.
-- | TODO: Is this already included in purescript-pipes somehow, or should be?
scanWithStateM
  :: forall a x m r
   . Monad m
  => (x -> a -> m x) -> m x -> Pipe a a m r
scanWithStateM step begin = do
  x <- lift begin
  go x
  where
    go x = do
        a  <- await
        yield a
        x' <- lift (step x a)
        go $ x'

-- | A default reporter implementation that can be used as a base to build
-- | other reporters on top of.
defaultReporter
  :: forall s
   . s
  -> (Event -> StateT s (Writer String) Unit)
  -> Reporter
defaultReporter initialState onEvent = pure initialState # scanWithStateM \s e ->
  let Tuple res log = runWriter $ execStateT (onEvent e) s
  in liftEffect $ Console.write log $> res

data RunningItem
  = RunningTest String (Maybe Result)
  | RunningPending String
  | RunningSuite String Boolean

derive instance runningItemGeneric :: Generic RunningItem _
instance runningItemShow :: Show RunningItem where show = genericShow

defaultUpdate
  :: forall s
  . { getRunningItems :: s -> Map Path RunningItem
    , putRunningItems :: Map Path RunningItem -> s -> s
    , printFinishedItem :: Path -> RunningItem -> StateT s (Writer String) Unit
    , update :: Event -> StateT s (Writer String) Unit
    }
  -> (Event -> StateT s (Writer String) Unit)
defaultUpdate opts e = do
  baseUpdate e
  opts.update e
  where
    baseUpdate = case _ of
      Event.Suite Event.Sequential _ _ ->
        pure unit
      Event.Suite Event.Parallel path name -> do
        modifyRunningItems $ Map.insert path $ RunningSuite name false
      Event.SuiteEnd path -> do
        modifyRunningItems $ flip Map.update path case _ of
          RunningSuite n _ -> Just $ RunningSuite n true
          a -> Nothing
      Event.Test Event.Sequential path name -> do
        pure unit
      Event.Test Event.Parallel path name -> do
        modifyRunningItems $ Map.insert path $ RunningTest name Nothing
      Event.TestEnd path name res -> do
        runningItem <- gets opts.getRunningItems
        case Map.lookup path runningItem of
          Just (RunningTest n _) ->
            modifyRunningItems $ Map.insert path $ RunningTest n $ Just res
          _ ->
            pure unit
      Event.Pending path name -> do
        runningItem <- gets opts.getRunningItems
        unless (Map.isEmpty runningItem) do
          modifyRunningItems $ Map.insert path $ RunningPending name
      Event.End _ -> pure unit
      Event.Start _ -> pure unit
    modifyRunningItems f = do
      s <- get
      let
        nextRunningItems = f $ opts.getRunningItems s
        allFinished = all runningItemIsFinished nextRunningItems
      put $ opts.putRunningItems (if allFinished then Map.empty else nextRunningItems) s

      when allFinished do
        for_ (asArray $ Map.toUnfoldable nextRunningItems) $ uncurry opts.printFinishedItem
      where
        asArray = identity :: Array ~> Array
        runningItemIsFinished = case _ of
          RunningPending _ -> true
          RunningTest _ res -> isJust res
          RunningSuite _ finished -> finished

module Test.Spec.Reporter.Base
  ( defaultSummary
  , defaultReporter
  , defaultUpdate
  , RunningItem(..)
  ) where

import Prelude

import Control.Monad.State (StateT, evalStateT, execStateT, get, gets, put)
import Control.Monad.State as State
import Control.Monad.Trans.Class (lift)
import Control.Monad.Writer (class MonadWriter, Writer, runWriter)
import Data.Either (Either(..))
import Data.Foldable (all, for_, intercalate, traverse_)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.List (List(..), (:), reverse)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), isJust)
import Data.Tuple (Tuple(..), uncurry)
import Effect.Class (liftEffect)
import Effect.Exception as Error
import Pipes (await, yield)
import Pipes.Core (Pipe)
import Test.Spec (Tree)
import Test.Spec as S
import Test.Spec.Console (tellLn)
import Test.Spec.Console as Console
import Test.Spec.Result (Result(..))
import Test.Spec.Runner (Reporter)
import Test.Spec.Runner.Event (Event)
import Test.Spec.Runner.Event as Event
import Test.Spec.Style (styled)
import Test.Spec.Style as Style
import Test.Spec.Summary (Summary(..))
import Test.Spec.Summary as Summary
import Test.Spec.Tree (Path)

defaultSummary :: forall m
   . MonadWriter String m
  => Array (Tree Void Result)
  -> m Unit
defaultSummary xs = do
  case Summary.summarize xs of
    (Count {passed, failed, pending}) -> do
      when (passed  > 0) $ tellLn $ styled Style.green $ show passed  <> " passing"
      when (pending > 0) $ tellLn $ styled Style.cyan $ show pending <> " pending"
      when (failed  > 0) $ tellLn $ styled Style.red $ show failed  <> " failed"
  tellLn ""
  printFailures xs

printFailures
  :: forall m
   . MonadWriter String m
  => Array (Tree Void Result)
  -> m Unit
printFailures xs' = evalStateT (go xs') {i: 0, crumbs: Nil}
  where
    go :: Array (Tree Void Result) -> StateT { i :: Int, crumbs :: List String } m Unit
    go = traverse_ case _ of
      S.Node (Left n) xs -> do
        {crumbs} <- State.get
        State.modify_ _{crumbs = n : crumbs}
        go xs
        State.modify_ _{crumbs = crumbs}
      S.Node (Right _) xs -> go xs
      S.Leaf n (Just (Failure err)) -> do
        {i, crumbs} <- State.modify \s -> s{i = s.i +1}
        let label = intercalate " " (reverse $ n:crumbs)
        tellLn $ show i <> ") " <> label
        tellLn $ styled Style.red $ Style.indent 2 <> Error.message err
      S.Leaf _ _ -> pure unit

-- | Monadic left scan with state.
-- | TODO: Is this already included in purescript-pipes somehow, or should be?
scanWithStateM
  :: forall a x m r
   . Monad m
  => (x -> a -> m x) -> m x -> Pipe a a m r
scanWithStateM step begin = do
  x <- lift begin
  go x
  where
    go x = do
        a  <- await
        yield a
        x' <- lift (step x a)
        go $ x'

-- | A default reporter implementation that can be used as a base to build
-- | other reporters on top of.
defaultReporter
  :: forall s
   . s
  -> (Event -> StateT s (Writer String) Unit)
  -> Reporter
defaultReporter initialState onEvent = pure initialState # scanWithStateM \s e ->
  let Tuple res log = runWriter $ execStateT (onEvent e) s
  in liftEffect $ Console.write log $> res

data RunningItem
  = RunningTest String (Maybe Result)
  | RunningPending String
  | RunningSuite String Boolean

derive instance runningItemGeneric :: Generic RunningItem _
instance runningItemShow :: Show RunningItem where show = genericShow

defaultUpdate
  :: forall s
  . { getRunningItems :: s -> Map Path RunningItem
    , putRunningItems :: Map Path RunningItem -> s -> s
    , printFinishedItem :: Path -> RunningItem -> StateT s (Writer String) Unit
    , update :: Event -> StateT s (Writer String) Unit
    }
  -> (Event -> StateT s (Writer String) Unit)
defaultUpdate opts e = do
  baseUpdate e
  opts.update e
  where
    baseUpdate = case _ of
      Event.Suite Event.Sequential _ _ ->
        pure unit
      Event.Suite Event.Parallel path name -> do
        modifyRunningItems $ Map.insert path $ RunningSuite name false
      Event.SuiteEnd path -> do
        modifyRunningItems $ flip Map.update path case _ of
          RunningSuite n _ -> Just $ RunningSuite n true
          a -> Nothing
      Event.Test Event.Sequential path name -> do
        pure unit
      Event.Test Event.Parallel path name -> do
        modifyRunningItems $ Map.insert path $ RunningTest name Nothing
      Event.TestEnd path name res -> do
        runningItem <- gets opts.getRunningItems
        case Map.lookup path runningItem of
          Just (RunningTest n _) ->
            modifyRunningItems $ Map.insert path $ RunningTest n $ Just res
          _ ->
            pure unit
      Event.Pending path name -> do
        runningItem <- gets opts.getRunningItems
        unless (Map.isEmpty runningItem) do
          modifyRunningItems $ Map.insert path $ RunningPending name
      Event.End _ -> pure unit
      Event.Start _ -> pure unit
    modifyRunningItems f = do
      s <- get
      let
        nextRunningItems = f $ opts.getRunningItems s
        allFinished = all runningItemIsFinished nextRunningItems
      put $ opts.putRunningItems (if allFinished then Map.empty else nextRunningItems) s

      when allFinished do
        for_ (asArray $ Map.toUnfoldable nextRunningItems) $ uncurry opts.printFinishedItem
      where
        asArray = identity :: Array ~> Array
        runningItemIsFinished = case _ of
          RunningPending _ -> true
          RunningTest _ res -> isJust res
          RunningSuite _ finished -> finished


! Fix for situations where call to require('express') has been optimized out

module Node.Express.App
    ( AppM()
    , App()
    , listen, use, useExternal, useAt, useOnParam, useOnError
    , getProp, setProp
    , http, get, post, put, delete, all
    ) where

import Data.Foreign
import Data.Function
import Data.Maybe
import Control.Monad.Eff
import Control.Monad.Eff.Class

import Node.Express.Types
import Node.Express.Internal.App
import Node.Express.Handler

--| Monad responsible for application related operations (initial setup mostly).
data AppM a = AppM (Application -> ExpressM a)
type App = AppM Unit

instance functorAppM :: Functor AppM where
    (<$>) f (AppM h) = AppM \app -> liftM1 f $ h app

instance applyAppM :: Apply AppM where
    (<*>) (AppM f) (AppM h) = AppM \app -> do
        res <- h app
        trans <- f app
        return $ trans res

instance applicativeAppM :: Applicative AppM where
    pure x = AppM \_ -> return x

instance bindAppM :: Bind AppM where
    (>>=) (AppM h) f = AppM \app -> do
        res <- h app
        case f res of
             AppM g -> g app

instance monadAppM :: Monad AppM

instance monadEffAppM :: MonadEff AppM where
    liftEff act = AppM \_ -> liftEff act

--| Run application on specified port and execute callback after launch.
listen :: forall e. App -> Port -> (Event -> Eff e Unit) -> ExpressM Unit
listen (AppM act) port cb = do
    pure express -- DO NOT DELETE THIS LINE
    -- Otherwise call to 'require(express)' may be optimized out
    app <- intlMkApplication
    act app
    intlAppListen app port cb

--| Use specified middleware handler.
use :: Handler -> App
use middleware = AppM \app ->
    intlAppUse app $ withHandler middleware

--| Use any function as middleware.
--  Introduced to ease usage of a bunch of external
--  middleware written for express.js.
--  See http://expressjs.com/4x/api.html#middleware
useExternal :: Fn3 Request Response (ExpressM Unit) (ExpressM Unit) -> App
useExternal fn = AppM \app ->
    intlAppUseExternal app fn

--| Use specified middleware only on requests matching path.
useAt :: Path -> Handler -> App
useAt route middleware = AppM \app ->
    intlAppUseAt app route $ withHandler middleware

--| Process route param with specified handler.
useOnParam :: String -> (String -> Handler) -> App
useOnParam param handler = AppM \app ->
    intlAppUseOnParam app param (withHandler <<< handler)

--| Use error handler. Probably this should be the last middleware to attach.
useOnError :: (Error -> Handler) -> App
useOnError handler = AppM \app ->
    intlAppUseOnError app (withHandler <<< handler)

--| Get application property.
-- See http://expressjs.com/4x/api.html#app-settings
getProp :: forall a. (ReadForeign a) => String -> AppM (Maybe a)
getProp name = AppM \app ->
    intlAppGetProp app name

--| Set application property.
-- See http://expressjs.com/4x/api.html#app-settings
setProp :: forall a. (ReadForeign a) => String -> a -> App
setProp name val = AppM \app ->
    intlAppSetProp app name val

--| Bind specified handler to handle request matching route and method.
http :: forall r. (RoutePattern r) => Method -> r -> Handler -> App
http method route handler = AppM \app ->
    intlAppHttp app (show method) route $ withHandler handler

--| Shortcut for `http GET`.
get :: forall r. (RoutePattern r) => r -> Handler -> App
get = http GET

--| Shortcut for `http POST`.
post :: forall r. (RoutePattern r) => r -> Handler -> App
post = http POST

--| Shortcut for `http PUT`.
put :: forall r. (RoutePattern r) => r -> Handler -> App
put = http PUT

--| Shortcut for `http DELETE`.
delete :: forall r. (RoutePattern r) => r -> Handler -> App
delete = http DELETE

--| Shortcut for `http ALL` (match on any http method).
all :: forall r. (RoutePattern r) => r -> Handler -> App
all = http ALL

module Node.Express.App
    ( AppM()
    , App()
    , listen, use, useExternal, useAt, useOnParam, useOnError
    , getProp, setProp
    , http, get, post, put, delete, all
    ) where

import Data.Foreign
import Data.Function
import Data.Maybe
import Control.Monad.Eff
import Control.Monad.Eff.Class

import Node.Express.Types
import Node.Express.Internal.App
import Node.Express.Handler

--| Monad responsible for application related operations (initial setup mostly).
data AppM a = AppM (Application -> ExpressM a)
type App = AppM Unit

instance functorAppM :: Functor AppM where
    (<$>) f (AppM h) = AppM \app -> liftM1 f $ h app

instance applyAppM :: Apply AppM where
    (<*>) (AppM f) (AppM h) = AppM \app -> do
        res <- h app
        trans <- f app
        return $ trans res

instance applicativeAppM :: Applicative AppM where
    pure x = AppM \_ -> return x

instance bindAppM :: Bind AppM where
    (>>=) (AppM h) f = AppM \app -> do
        res <- h app
        case f res of
             AppM g -> g app

instance monadAppM :: Monad AppM

instance monadEffAppM :: MonadEff AppM where
    liftEff act = AppM \_ -> liftEff act

--| Run application on specified port and execute callback after launch.
listen :: forall e. App -> Port -> (Event -> Eff e Unit) -> ExpressM Unit
listen (AppM act) port cb = do
    app <- intlMkApplication
    act app
    intlAppListen app port cb

--| Use specified middleware handler.
use :: Handler -> App
use middleware = AppM \app ->
    intlAppUse app $ withHandler middleware

--| Use any function as middleware.
--  Introduced to ease usage of a bunch of external
--  middleware written for express.js.
--  See http://expressjs.com/4x/api.html#middleware
useExternal :: Fn3 Request Response (ExpressM Unit) (ExpressM Unit) -> App
useExternal fn = AppM \app ->
    intlAppUseExternal app fn

--| Use specified middleware only on requests matching path.
useAt :: Path -> Handler -> App
useAt route middleware = AppM \app ->
    intlAppUseAt app route $ withHandler middleware

--| Process route param with specified handler.
useOnParam :: String -> (String -> Handler) -> App
useOnParam param handler = AppM \app ->
    intlAppUseOnParam app param (withHandler <<< handler)

--| Use error handler. Probably this should be the last middleware to attach.
useOnError :: (Error -> Handler) -> App
useOnError handler = AppM \app ->
    intlAppUseOnError app (withHandler <<< handler)

--| Get application property.
-- See http://expressjs.com/4x/api.html#app-settings
getProp :: forall a. (ReadForeign a) => String -> AppM (Maybe a)
getProp name = AppM \app ->
    intlAppGetProp app name

--| Set application property.
-- See http://expressjs.com/4x/api.html#app-settings
setProp :: forall a. (ReadForeign a) => String -> a -> App
setProp name val = AppM \app ->
    intlAppSetProp app name val

--| Bind specified handler to handle request matching route and method.
http :: forall r. (RoutePattern r) => Method -> r -> Handler -> App
http method route handler = AppM \app ->
    intlAppHttp app (show method) route $ withHandler handler

--| Shortcut for `http GET`.
get :: forall r. (RoutePattern r) => r -> Handler -> App
get = http GET

--| Shortcut for `http POST`.
post :: forall r. (RoutePattern r) => r -> Handler -> App
post = http POST

--| Shortcut for `http PUT`.
put :: forall r. (RoutePattern r) => r -> Handler -> App
put = http PUT

--| Shortcut for `http DELETE`.
delete :: forall r. (RoutePattern r) => r -> Handler -> App
delete = http DELETE

--| Shortcut for `http ALL` (match on any http method).
all :: forall r. (RoutePattern r) => r -> Handler -> App
all = http ALL


makes Actions serializable.

makes Actions serializable.

module Render.Types where

import Data.Tuple
import Data.Maybe
import qualified Data.Map as M
import Data.Either
import Data.Foreign
import Data.Foreign.Class

-----------------
--| TopicType |--
-----------------

data TopicType = Discussion
               | Presentation
               | Workshop

instance eqTopicType :: Eq TopicType where
(==) tt1 tt2 = show tt1 == show tt2
(/=) tt1 tt2 = show tt1 /= show tt2

instance showTopicType :: Show TopicType where
  show Discussion = "Discussion"
  show Presentation = "Presentation"
  show Workshop = "Workshop"

instance foreignTopicType :: IsForeign TopicType where
  read val = case readString val of
    Right "Discussion"   -> Right Discussion
    Right "Presentation" -> Right Presentation
    Right "Workshop"     -> Right Workshop
    _                    -> Left $ JSONError "Cant read TopicType"

-- Used to fill Dropdowns etc.
-- TODO: Find a proper way to enumerate Union Datatypes
topicTypes = [Discussion, Presentation, Workshop]

--------------
--| Topics |--
--------------

newtype Topic = Topic { description :: String, typ :: TopicType }

instance eqTopic :: Eq Topic where
  (==) (Topic t1) (Topic t2) = t1.description == t2.description && t1.typ == t2.typ
  (/=) (Topic t1) (Topic t2) = t1.description /= t2.description || t1.typ /= t2.typ

instance foreignTopic :: IsForeign Topic where
    read val = do
      description <- readProp "description" val :: F String
      typ         <- readProp "typ"         val :: F TopicType
      return $ Topic {description: description, typ: typ}

------------
--| Slot |--
------------

newtype Slot = Slot { room :: Room, block :: Block }
instance eqSlot :: Eq Slot where
  (==) (Slot s1) (Slot s2) = s1.room == s2.room && s1.block == s2.block
  (/=) (Slot s1) (Slot s2) = s1.room /= s2.room || s1.block /= s2.block

instance ordSlot :: Ord Slot where
  compare (Slot s1) (Slot s2) = (show s1.room ++ show s1.block) `compare` (show s2.room ++ show s2.block)

instance showSlot :: Show Slot where
  show (Slot s) = "{ room: " ++ show s.room ++" block: " ++ show s.block ++ "}"

instance foreignSlot :: IsForeign Slot where
  read val = do
    room <- readProp "room" val :: F Room
    block <- readProp "block" val :: F Block
    return $ Slot {room: room, block: block}

------------
--| Room |--
------------

newtype Room = Room { name :: String, capacity :: Number }
instance showRoom :: Show Room where
  show (Room r) = r.name
instance eqRoom :: Eq Room where
  (==) (Room r1) (Room r2) = r1.name == r2.name
  (/=) (Room r1) (Room r2) = r1.name /= r2.name
instance foreignRoom :: IsForeign Room where
  read val = do
    name     <- readProp "name" val     :: F String
    capacity <- readProp "capacity" val :: F Number
    return $ Room {name: name, capacity: capacity}

-------------
--| Block |--
-------------

newtype Block = Block { start :: String }
instance showBlock :: Show Block where
  show (Block b) = b.start
instance eqBlock :: Eq Block where
  (==) (Block b1) (Block b2) = b1.start == b2.start
  (/=) (Block b1) (Block b2) = b1.start /= b2.start
instance foreignBlock :: IsForeign Block where
  read val = do
    start <- readProp "start" val     :: F String
    return $ Block {start: start}

---------------
--| Actions |--
---------------

data Action = AddTopic Topic
            | DeleteTopic Topic
            | AssignTopic Slot Topic
            | UnassignTopic Topic
            | ShowError String

instance foreignAction :: IsForeign Action where
read val = case readProp "action" val of
  Right "AddTopic" -> do
    t <- readProp "topic" val :: F Topic
    return $ AddTopic t
  Right "DeleteTopic" -> do
    t <- readProp "topic" val :: F Topic
    return $ DeleteTopic t
  Right "AssignTopic" -> do
    s <- readProp "slot" val :: F Slot
    t <- readProp "topic" val :: F Topic
    return $ AssignTopic s t
  Right "UnassignTopic" -> do
    t <- readProp "topic" val :: F Topic
    return $ UnassignTopic t
  Right "ShowError" -> do
    m <- readProp "message" val :: F String
    return $ ShowError m
  Left e -> Right $ ShowError (show e)

class AsForeign a where
  serialize :: a -> Foreign

instance actionAsForeign :: AsForeign Action where
  serialize (AddTopic (Topic t)) = toForeign { action: "AddTopic"
                                             , topic: { description: t.description
                                                      , typ: show t.typ
                                                      }
                                             }
  serialize (DeleteTopic (Topic t)) = toForeign { action: "DeleteTopic"
                                                , topic: { description: t.description
                                                         , typ: show t.typ
                                                         }
                                                }
  serialize (AssignTopic s (Topic t)) = toForeign { action: "AssignTopic"
                                                        , topic: { description: t.description
                                                                 , typ: show t.typ
                                                                 }
                                                        , slot: s
                                                        }

  serialize (UnassignTopic (Topic t)) = toForeign { action: "UnassignTopic"
                                                  , topic: { description: t.description
                                                           , typ: show t.typ
                                                           }
                                                  }

  serialize (ShowError s) = toForeign { action: "ShowError"
                                      , message: s
                                      }
-------------------------
--| Gesamter AppState |--
-------------------------

type Timeslot = Tuple Slot Topic

type AppState = { topics :: [Topic]
                , rooms :: [Room]
                , blocks :: [Block]
                , slots :: [Slot]
                , timeslots :: M.Map Slot Topic
                }

type SanitizedTopic = { description :: String, typ :: String }
type SanitizedSlot =  { room :: String, block :: String }
type SanitizedTimeslot = Tuple SanitizedSlot SanitizedTopic

type SanitizedAppState = { topics :: [SanitizedTopic]
                         , rooms :: [Room]
                         , blocks :: [Block]
                         , slots :: [SanitizedSlot]
                         , timeslots :: [SanitizedTimeslot]
                         }

 --------------------
 --| Dummy Values |--
 --------------------

emptyState = {topics: [], rooms:[], blocks:[], slots: [], timeslots: []}

myRoom = Room {name: "Berlin", capacity: 100}
myRoom1 = Room {name: "Hamburg", capacity: 80}
myRoom2 = Room {name: "Köln", capacity: 30}

myBlock = Block {start: "8:00am"}
myBlock1 = Block {start: "12:00am"}

mySlot = Slot {room:myRoom, block:myBlock}
mySlot1 = Slot {room:myRoom1, block:myBlock1}

myTopic = Topic {description:"Purescript is great", typ:Workshop}
myTopic1 = Topic {description:"Reactive Design", typ:Presentation}
myTopic2 = Topic {description:"Functional Javascript", typ:Discussion}

myState1 = { topics: [myTopic, myTopic1, myTopic2]
           , slots : [mySlot, mySlot1]
           , rooms : [myRoom, myRoom1, myRoom2]
           , blocks : [myBlock, myBlock1]
           , timeslots: M.fromList [Tuple mySlot myTopic, Tuple mySlot1 myTopic1]
           }

module Render.Types where

import Data.Tuple
import Data.Maybe
import qualified Data.Map as M
import Data.Either
import Data.Foreign
import Data.Foreign.Class

-----------------
--| TopicType |--
-----------------

data TopicType = Discussion
               | Presentation
               | Workshop

instance eqTopicType :: Eq TopicType where
(==) tt1 tt2 = show tt1 == show tt2
(/=) tt1 tt2 = show tt1 /= show tt2

instance showTopicType :: Show TopicType where
  show Discussion = "Discussion"
  show Presentation = "Presentation"
  show Workshop = "Workshop"

instance foreignTopicType :: IsForeign TopicType where
  read val = case readString val of
    Right "Discussion"   -> Right Discussion
    Right "Presentation" -> Right Presentation
    Right "Workshop"     -> Right Workshop
    _                    -> Left $ JSONError "Cant read TopicType"

-- Used to fill Dropdowns etc.
-- TODO: Find a proper way to enumerate Union Datatypes
topicTypes = [Discussion, Presentation, Workshop]

--------------
--| Topics |--
--------------

newtype Topic = Topic { description :: String, typ :: TopicType }

instance eqTopic :: Eq Topic where
  (==) (Topic t1) (Topic t2) = t1.description == t2.description && t1.typ == t2.typ
  (/=) (Topic t1) (Topic t2) = t1.description /= t2.description || t1.typ /= t2.typ

instance foreignTopic :: IsForeign Topic where
    read val = do
      description <- readProp "description" val :: F String
      typ         <- readProp "typ"         val :: F TopicType
      return $ Topic {description: description, typ: typ}

------------
--| Slot |--
------------

newtype Slot = Slot { room :: Room, block :: Block }
instance eqSlot :: Eq Slot where
  (==) (Slot s1) (Slot s2) = s1.room == s2.room && s1.block == s2.block
  (/=) (Slot s1) (Slot s2) = s1.room /= s2.room || s1.block /= s2.block

instance ordSlot :: Ord Slot where
  compare (Slot s1) (Slot s2) = (show s1.room ++ show s1.block) `compare` (show s2.room ++ show s2.block)

instance showSlot :: Show Slot where
  show (Slot s) = "{ room: " ++ show s.room ++" block: " ++ show s.block ++ "}"

instance foreignSlot :: IsForeign Slot where
  read val = do
    room <- readProp "room" val :: F Room
    block <- readProp "block" val :: F Block
    return $ Slot {room: room, block: block}

------------
--| Room |--
------------

newtype Room = Room { name :: String, capacity :: Number }
instance showRoom :: Show Room where
  show (Room r) = r.name
instance eqRoom :: Eq Room where
  (==) (Room r1) (Room r2) = r1.name == r2.name
  (/=) (Room r1) (Room r2) = r1.name /= r2.name
instance foreignRoom :: IsForeign Room where
  read val = do
    name     <- readProp "name" val     :: F String
    capacity <- readProp "capacity" val :: F Number
    return $ Room {name: name, capacity: capacity}

-------------
--| Block |--
-------------

newtype Block = Block { start :: String }
instance showBlock :: Show Block where
  show (Block b) = b.start
instance eqBlock :: Eq Block where
  (==) (Block b1) (Block b2) = b1.start == b2.start
  (/=) (Block b1) (Block b2) = b1.start /= b2.start
instance foreignBlock :: IsForeign Block where
  read val = do
    start <- readProp "start" val     :: F String
    return $ Block {start: start}

---------------
--| Actions |--
---------------

data Action = AddTopic Topic
            | DeleteTopic Topic
            | AssignTopic Slot Topic
            | UnassignTopic Topic
            | ShowError String

-------------------------
--| Gesamter AppState |--
-------------------------

type Timeslot = Tuple Slot Topic

type AppState = { topics :: [Topic]
                , rooms :: [Room]
                , blocks :: [Block]
                , slots :: [Slot]
                , timeslots :: M.Map Slot Topic
                }

type SanitizedTopic = { description :: String, typ :: String }
type SanitizedSlot =  { room :: String, block :: String }
type SanitizedTimeslot = Tuple SanitizedSlot SanitizedTopic

type SanitizedAppState = { topics :: [SanitizedTopic]
                         , rooms :: [Room]
                         , blocks :: [Block]
                         , slots :: [SanitizedSlot]
                         , timeslots :: [SanitizedTimeslot]
                         }

 --------------------
 --| Dummy Values |--
 --------------------

emptyState = {topics: [], rooms:[], blocks:[], slots: [], timeslots: []}

myRoom = Room {name: "Berlin", capacity: 100}
myRoom1 = Room {name: "Hamburg", capacity: 80}
myRoom2 = Room {name: "Köln", capacity: 30}

myBlock = Block {start: "8:00am"}
myBlock1 = Block {start: "12:00am"}

mySlot = Slot {room:myRoom, block:myBlock}
mySlot1 = Slot {room:myRoom1, block:myBlock1}

myTopic = Topic {description:"Purescript is great", typ:Workshop}
myTopic1 = Topic {description:"Reactive Design", typ:Presentation}
myTopic2 = Topic {description:"Functional Javascript", typ:Discussion}

myState1 = { topics: [myTopic, myTopic1, myTopic2]
           , slots : [mySlot, mySlot1]
           , rooms : [myRoom, myRoom1, myRoom2]
           , blocks : [myBlock, myBlock1]
           , timeslots: M.fromList [Tuple mySlot myTopic, Tuple mySlot1 myTopic1]
           }


scatter ordinate and size non configurable

{-
Copyright 2017 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Setups.DimensionMap.Defaults
  ( ProjectionDefaults
  , getDefaults
  , dynamicMeasure
  , isFlat
  ) where

import SlamData.Prelude
import Data.Argonaut (JCursor)
import Data.Int as Int
import Data.Lens ((?~), (^.))
import Data.StrMap as SM
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Package.DSL as T
import SlamData.Workspace.Card.Setups.Package.Projection as Pr
import SlamData.Workspace.Card.Setups.Transform.Aggregation as Ag

type ProjectionDefaults =
  { dimension ∷ JCursor → D.LabeledJCursor
  , label ∷ String
  , value ∷ String
  , select ∷ String
  , deselectable ∷ Boolean
  }

jcursorProjection ∷ JCursor → D.Dimension Void JCursor
jcursorProjection = D.projection

getDefaults ∷ T.Projection → ProjectionDefaults
getDefaults prj = case defaults ^. T.unpackProjection prj of
  Just a  → a
  Nothing → dynamicMeasure prj

defaults ∷ SM.StrMap ProjectionDefaults
defaults = foldr insertProjection SM.empty statics
  where
  insertProjection (prj × val) =
    T.unpackProjection prj ?~ val

statics ∷ Array (T.Projection × ProjectionDefaults)
statics =
  [ Pr._dimension ×
      { dimension: jcursorProjection
      , label: "Dimension"
      , value: "Choose dimension"
      , select: "Choose dimension"
      , deselectable: true
      }
  , Pr._high ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "High"
      , value: "Choose high"
      , select: "Choose measure for high position"
      , deselectable: false
      }
  , Pr._low ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "Low"
      , value: "Choose low"
      , select: "Choose measure for low position"
      , deselectable: false
      }
  , Pr._open ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "Open"
      , value: "Choose open"
      , select: "Choose measure for open position"
      , deselectable: false
      }
  , Pr._close ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "Close"
      , value: "Choose close"
      , select: "Choose measure for close position"
      , deselectable: false
      }
  , Pr._parallel ×
      { dimension: jcursorProjection
      , label: "Parallel"
      , value: "Choose parallel"
      , select: "Choose parallel"
      , deselectable: true
      }
  , Pr._value ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "Measure #1"
      , value: "Choose measure"
      , select: "Choose measure"
      , deselectable: false
      }
  , Pr._series ×
      { dimension: jcursorProjection
      , label: "Series"
      , value: "Choose series"
      , select: "Choose series"
      , deselectable: true
      }
  , Pr._category ×
      { dimension: jcursorProjection
      , label: "Category"
      , value: "Choose category"
      , select: "Choose category"
      , deselectable: true
      }
  , Pr._stack ×
      { dimension: jcursorProjection
      , label: "Stack"
      , value: "Choose stack"
      , select: "Choose stack"
      , deselectable: true
      }
  , Pr._source ×
      { dimension: jcursorProjection
      , label: "Source"
      , value: "Choose source"
      , select: "Choose source"
      , deselectable: true
      }
  , Pr._target ×
      { dimension: jcursorProjection
      , label: "Target"
      , value: "Choose target"
      , select: "Choose target"
      , deselectable: true
      }
  , Pr._abscissa ×
      { dimension: jcursorProjection
      , label: "X-axis"
      , value: "Choose x-axis"
      , select: "Choose x-axis"
      , deselectable: true
      }
  , Pr._ordinate ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "Y-axis"
      , value: "Choose y-axis"
      , select: "Choose y-axis"
      , deselectable: false
      }
  , Pr._secondValue ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "Measure #2"
      , value: "Choose measure"
      , select: "Choose measure"
      , deselectable: false
      }
  , Pr._donut ×
      { dimension: jcursorProjection
      , label: "Donut"
      , value: "Choose donut"
      , select: "Choose donut"
      , deselectable: true
      }
  , Pr._multiple ×
      { dimension: jcursorProjection
      , label: "Multiple"
      , value: "Choose multiple"
      , select: "Choose multiple"
      , deselectable: true
      }
  , Pr._size ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "Size"
      , value: "Choose size"
      , select: "Choose size"
      , deselectable: false
      }
  , Pr._color ×
      { dimension: jcursorProjection
      , label: "Color"
      , value: "Choose color"
      , select: "Choose color"
      , deselectable: true
      }
  , Pr._scatterOrdinate ×
      { dimension: jcursorProjection
      , label: "Y-axis"
      , value: "Choose y-axis"
      , select: "Choose y-axis"
      , deselectable: true
      }
  , Pr._scatterSize ×
      { dimension: jcursorProjection
      , label: "Size"
      , value: "Choose size"
      , select: "Choose size"
      , deselectable: true
      }
  ]

dynamicMeasure ∷ T.Projection → ProjectionDefaults
dynamicMeasure prj =
  { dimension: jcursorProjection
  , label: "Measure" <> maybe "" (\o → " #" <> show o) offset
  , value: "Choose measure"
  , select: "Choose measure"
  , deselectable: true
  }
  where
  offset = map (add 1) ∘ Int.fromString =<< T.idReflection ^. T.unpackProjection prj

-- | Some projections shouldn't be aggregated
isFlat ∷ T.Projection → Boolean
isFlat prj = case T.idReflection ^. T.unpackProjection prj of
  Just "flatValue" → true
  Just "scatterSize" → true
  Just "scatterOrdinate" → true
  _ → false

{-
Copyright 2017 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Setups.DimensionMap.Defaults
  ( ProjectionDefaults
  , getDefaults
  , dynamicMeasure
  , isFlat
  ) where

import SlamData.Prelude
import Data.Argonaut (JCursor)
import Data.Int as Int
import Data.Lens ((?~), (^.))
import Data.StrMap as SM
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Package.DSL as T
import SlamData.Workspace.Card.Setups.Package.Projection as Pr
import SlamData.Workspace.Card.Setups.Transform.Aggregation as Ag

type ProjectionDefaults =
  { dimension ∷ JCursor → D.LabeledJCursor
  , label ∷ String
  , value ∷ String
  , select ∷ String
  , deselectable ∷ Boolean
  }

jcursorProjection ∷ JCursor → D.Dimension Void JCursor
jcursorProjection = D.projection

getDefaults ∷ T.Projection → ProjectionDefaults
getDefaults prj = case defaults ^. T.unpackProjection prj of
  Just a  → a
  Nothing → dynamicMeasure prj

defaults ∷ SM.StrMap ProjectionDefaults
defaults = foldr insertProjection SM.empty statics
  where
  insertProjection (prj × val) =
    T.unpackProjection prj ?~ val

statics ∷ Array (T.Projection × ProjectionDefaults)
statics =
  [ Pr._dimension ×
      { dimension: jcursorProjection
      , label: "Dimension"
      , value: "Choose dimension"
      , select: "Choose dimension"
      , deselectable: true
      }
  , Pr._high ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "High"
      , value: "Choose high"
      , select: "Choose measure for high position"
      , deselectable: false
      }
  , Pr._low ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "Low"
      , value: "Choose low"
      , select: "Choose measure for low position"
      , deselectable: false
      }
  , Pr._open ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "Open"
      , value: "Choose open"
      , select: "Choose measure for open position"
      , deselectable: false
      }
  , Pr._close ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "Close"
      , value: "Choose close"
      , select: "Choose measure for close position"
      , deselectable: false
      }
  , Pr._parallel ×
      { dimension: jcursorProjection
      , label: "Parallel"
      , value: "Choose parallel"
      , select: "Choose parallel"
      , deselectable: true
      }
  , Pr._value ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "Measure #1"
      , value: "Choose measure"
      , select: "Choose measure"
      , deselectable: false
      }
  , Pr._series ×
      { dimension: jcursorProjection
      , label: "Series"
      , value: "Choose series"
      , select: "Choose series"
      , deselectable: true
      }
  , Pr._category ×
      { dimension: jcursorProjection
      , label: "Category"
      , value: "Choose category"
      , select: "Choose category"
      , deselectable: true
      }
  , Pr._stack ×
      { dimension: jcursorProjection
      , label: "Stack"
      , value: "Choose stack"
      , select: "Choose stack"
      , deselectable: true
      }
  , Pr._source ×
      { dimension: jcursorProjection
      , label: "Source"
      , value: "Choose source"
      , select: "Choose source"
      , deselectable: true
      }
  , Pr._target ×
      { dimension: jcursorProjection
      , label: "Target"
      , value: "Choose target"
      , select: "Choose target"
      , deselectable: true
      }
  , Pr._abscissa ×
      { dimension: jcursorProjection
      , label: "X-axis"
      , value: "Choose x-axis"
      , select: "Choose x-axis"
      , deselectable: true
      }
  , Pr._ordinate ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "Y-axis"
      , value: "Choose y-axis"
      , select: "Choose y-axis"
      , deselectable: false
      }
  , Pr._secondValue ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "Measure #2"
      , value: "Choose measure"
      , select: "Choose measure"
      , deselectable: false
      }
  , Pr._donut ×
      { dimension: jcursorProjection
      , label: "Donut"
      , value: "Choose donut"
      , select: "Choose donut"
      , deselectable: true
      }
  , Pr._multiple ×
      { dimension: jcursorProjection
      , label: "Multiple"
      , value: "Choose multiple"
      , select: "Choose multiple"
      , deselectable: true
      }
  , Pr._size ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "Size"
      , value: "Choose size"
      , select: "Choose size"
      , deselectable: false
      }
  , Pr._color ×
      { dimension: jcursorProjection
      , label: "Color"
      , value: "Choose color"
      , select: "Choose color"
      , deselectable: true
      }
  , Pr._scatterOrdinate ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "Y-axis"
      , value: "Choose y-axis"
      , select: "Choose y-axis"
      , deselectable: true
      }
  , Pr._scatterSize ×
      { dimension: D.projectionWithAggregation $ Just Ag.Sum
      , label: "Size"
      , value: "Choose size"
      , select: "Choose size"
      , deselectable: true
      }
  ]

dynamicMeasure ∷ T.Projection → ProjectionDefaults
dynamicMeasure prj =
  { dimension: jcursorProjection
  , label: "Measure" <> maybe "" (\o → " #" <> show o) offset
  , value: "Choose measure"
  , select: "Choose measure"
  , deselectable: true
  }
  where
  offset = map (add 1) ∘ Int.fromString =<< T.idReflection ^. T.unpackProjection prj

-- | Some projections shouldn't be aggregated
isFlat ∷ T.Projection → Boolean
isFlat prj = case T.idReflection ^. T.unpackProjection prj of
  Just "flatValue" → true
  _ → false


Use FileName newtype

Use FileName newtype

module Components.App
  ( mkApp
  ) where

import Lambda.Prelude

import Components.Alert (Level(..))
import Components.Alert as Alert
import Components.Controls as Controls
import Components.Definitions as Definitions
import Components.Expressions as Expressions
import Components.Footer as Footer
import Components.Help as Help
import Components.Input as Input
import Data.Array (concat, cons, filter, reverse, snoc)
import Data.Foldable (intercalate)
import Effect.Save (FileName(..), saveTextAs)
import Lambda.Language.Expr
  ( Expr
  , syntaxToExpr
  )
import Lambda.Language.Name (Name)
import Lambda.Language.Parse (formatParseError, parseAll, parseDefinition, parseEither, unsafeParse)
import Lambda.Language.PrettyPrint (Rep(..), Doc, prettyPrint, selectRep, toggleRep)
import Lambda.Language.Syntax (Definition, Syntax, defToDoc, defToSyntax)
import Lambda.Language.World (World)
import Lambda.Language.World as World
import Lambda.Machine (Machine)
import Lambda.Machine as Machine
import React.Basic (JSX)
import React.Basic as React
import React.Basic.DOM as R
import React.Basic.Hooks (Component, component, mkReducer, useReducer)
import React.Basic.Hooks as Hooks

-- | Manages text-input, global definitions, semantic consistency
-- | (world field), and machine state, if any.
type State =
  { text :: String
  , defs :: Array Definition
  , world :: World
  , machine :: Maybe Machine
  , history :: Array (Doc String)
  , rep :: Rep
  , alert :: Maybe (Tuple Level JSX)
  }

mkApp :: Component {}
mkApp = do
  reducer <- mkReducer update
  component "App" \_ -> Hooks.do
    state /\ dispatch <- useReducer initialState reducer
    pure $ R.div
      { className: "container"
      , children:
        [ row $ R.h2
          { className: "page-header"
          , children: [R.text "Lambda Machine"]
          }
        , row $ case state.alert of
            Nothing ->
              React.empty
            Just (Tuple level body) ->
              Alert.component
                { level
                , child: body
                , dismiss: dispatch DismissAlert
                }
        , row $ Input.component
          { text: state.text
          , onChange: dispatch <<< UpdateText
          , onSubmit: dispatch ParseText
          , onHelp: dispatch ShowHelp
          }
        , row $ R.h3_ [R.text "Definitions"]
        , row $ Definitions.component
          { defs: state.defs
          , rep: state.rep
          , onDelete: dispatch <<< DeleteDef
          }
        , split
          (R.h3_ [R.text "Evaluation"])
          (Controls.component
            { machine: state.machine
            , onStep: dispatch <<< Step
            , onClear: dispatch Clear
            , onSave: save state
            , onSugar: dispatch ToggleSugar
            , rep: state.rep
            }
          )
        , row $ Expressions.component
          { history: state.history
          , rep: state.rep
          }
        , row $ Footer.component {}
        ]
      }

-- | Row containing a single full-width element
row :: JSX -> JSX
row child =
  R.div
    { className: "row"
    , children: [R.div {className: "col-sm-12", children: [child]}]
    }

-- | Row containing two equal-width elements
split :: JSX -> JSX -> JSX
split lhs rhs =
  R.div
    { className: "row"
    , children:
      [ R.div {className: "col-sm-6", children: [lhs]}
      , R.div {className: "col-sm-6", children: [rhs]}
      ]
    }

-- | Default set of global definitions
prelude :: Array Definition
prelude =
  unsafeParse parseDefinition <$>
    [ "identity x = x"
    , "const x y = x"
    , "fix f = (λx. f (x x)) (λy. f (y y))"
    , "true t f = t"
    , "false t f = f"
    , "and x y = x y false"
    , "or x y = x true y"
    , "succ n s z = s (n s z)"
    , "pred n f x = n (λg. λh. h (g f)) (λu. x) (λu. u)"
    , "add m n s z = m s (n s z)"
    , "mul m n s z = m (n s) z"
    , "is-zero? n = n (λx. false) true"
    , "foldr f z l = l f z"
    , "any = foldr or false"
    , "all = foldr and true"
    ]

-- | Set of user-driven events
data Action
  = ShowHelp
  | DismissAlert
  | UpdateText String
  | ParseText
  | DeleteDef Name
  | AddDef Definition
  | SetExpr Syntax
  | Step Machine
  | Clear
  | ToggleSugar

-- | Empty state with default global definitions
initialState :: State
initialState =
  { text: ""
  , defs: prelude
  , world: World.new $ defsToGlobals prelude
  , machine: Nothing
  , history: []
  , rep: Raw
  , alert: Nothing
  }

-- | Update `State` in response to an `Action`
update :: State -> Action -> State
update s = case _ of
  ShowHelp -> showHelp s
  DismissAlert -> dismissAlert s
  UpdateText text -> updateText text s
  ParseText -> parseText s
  DeleteDef name -> deleteDef name s
  AddDef def -> addDef def s
  SetExpr expr -> setExpr expr s
  Step machine -> step machine s
  Clear -> clear s
  ToggleSugar -> toggleSugar s

-- | Present the tutorial alert
showHelp :: State -> State
showHelp =
  _ {alert = pure $ Tuple Info $ Help.component {} }

-- | Dismiss any alert
dismissAlert :: State -> State
dismissAlert =
  _ {alert = Nothing}

-- | Update input text
updateText :: String -> State -> State
updateText text =
  _ {alert = Nothing, text = text}

-- | Attempt to parse the input. Input may be a definition, an
-- | expression, or malformed, in which case, we'll surface a
-- | syntax error.
parseText :: State -> State
parseText s
  | s.text == "" = s
parseText s =
  case parseAll parseEither s.text of
    Left error ->
      s {alert = pure $ alert Danger $ formatParseError s.text error}
    Right (Left def) ->
      addDef def s
    Right (Right syntax) ->
      setExpr syntax s

-- | Attempt to delete a global definition. If the input or any other
-- | global definition depends on it, we'll refuse to delete the
-- | definition and present an error message.
deleteDef :: Name -> State -> State
deleteDef name s = case World.undefine name s.world of
  Left err ->
    s {alert = pure $ alert Danger $ show err}
  Right world -> s
    { defs = deleteByName name s.defs
    , world = world
    , machine = Machine.remove name <$> s.machine
    , alert = Nothing
    }

-- | Remove a definition by name. Used when deleting a definition or
-- | redefining an extant definition.
deleteByName :: Name -> Array Definition -> Array Definition
deleteByName name = filter $ (_ /= name) <<< _.name

-- | Attempt to add a new global definition. If the definition depends
-- | on undefined names, present an error message.
addDef :: Definition -> State -> State
addDef def s = case World.define def.name expr s.world of
  Left err ->
    s {alert = pure $ alert Danger $ show err}
  Right world -> s
    { text = ""
    , defs = deleteByName def.name s.defs `snoc` def
    , world = world
    , machine = Machine.add def.name expr <$> s.machine
    , alert = Nothing
    }
 where
  expr = syntaxToExpr $ defToSyntax def

-- | Attempt to set the main expression. If the expression depends on
-- | undefined names, present an error message.
setExpr :: Syntax -> State -> State
setExpr syntax s =
  case World.focus expr s.world of
    Left err ->
      s {alert = pure $ alert Danger $ show err}
    Right world -> s
      { text = ""
      , world = world
      , machine = machine
      , history = history
      , alert = Nothing
      }
 where
  expr = syntaxToExpr syntax
  globals = defsToGlobals s.defs
  history = pure $ prettyPrint syntax
  machine = pure $ Machine.new globals expr

-- | Convert `Definition`s to pairs of names and expressions.
defsToGlobals :: Array Definition -> Array (Tuple Name Expr)
defsToGlobals = map \def -> Tuple def.name $ syntaxToExpr $ defToSyntax def

-- | Do one step of evaluation and update the history.
step :: Machine -> State -> State
step m0 s =  s
  { machine = pure m
  , history = history
  }
 where
  m = Machine.step m0
  { root } = Machine.snapshot m
  history
    | Machine.halted m = s.history
    | otherwise = prettyPrint root `cons` s.history

-- | Unload the `Machine` and unset the main expression
clear :: State -> State
clear s = s
  { world = World.unfocus s.world
  , machine = Nothing
  , history = []
  }

-- | Toggle syntactic sugar for Church numerals and lists.
toggleSugar :: State -> State
toggleSugar s = s {rep = toggleRep s.rep}

-- | Download the state as a text file.
save :: State -> Effect Unit
save {rep, defs, history} =
  saveTextAs text $ FileName "evaluation.txt"
 where
  allDefs = concat
    [ map defToDoc defs
    , [pure ""]
    , reverse history
    ]
  text = intercalate "\n" $ flip selectRep rep <$> allDefs

-- | Create an alert element with the specified message.
alert :: Level -> String -> Tuple Level JSX
alert level message =
  Tuple level body
 where
  body = R.p
    { className: "preformatted"
    , children: [R.text message]
    }

module Components.App
  ( mkApp
  ) where

import Lambda.Prelude

import Components.Alert (Level(..))
import Components.Alert as Alert
import Components.Controls as Controls
import Components.Definitions as Definitions
import Components.Expressions as Expressions
import Components.Footer as Footer
import Components.Help as Help
import Components.Input as Input
import Data.Array (concat, cons, filter, reverse, snoc)
import Data.Foldable (intercalate)
import Effect.Save (saveTextAs)
import Lambda.Language.Expr
  ( Expr
  , syntaxToExpr
  )
import Lambda.Language.Name (Name)
import Lambda.Language.Parse (formatParseError, parseAll, parseDefinition, parseEither, unsafeParse)
import Lambda.Language.PrettyPrint (Rep(..), Doc, prettyPrint, selectRep, toggleRep)
import Lambda.Language.Syntax (Definition, Syntax, defToDoc, defToSyntax)
import Lambda.Language.World (World)
import Lambda.Language.World as World
import Lambda.Machine (Machine)
import Lambda.Machine as Machine
import React.Basic (JSX)
import React.Basic as React
import React.Basic.DOM as R
import React.Basic.Hooks (Component, component, mkReducer, useReducer)
import React.Basic.Hooks as Hooks

-- | Manages text-input, global definitions, semantic consistency
-- | (world field), and machine state, if any.
type State =
  { text :: String
  , defs :: Array Definition
  , world :: World
  , machine :: Maybe Machine
  , history :: Array (Doc String)
  , rep :: Rep
  , alert :: Maybe (Tuple Level JSX)
  }

mkApp :: Component {}
mkApp = do
  reducer <- mkReducer update
  component "App" \_ -> Hooks.do
    state /\ dispatch <- useReducer initialState reducer
    pure $ R.div
      { className: "container"
      , children:
        [ row $ R.h2
          { className: "page-header"
          , children: [R.text "Lambda Machine"]
          }
        , row $ case state.alert of
            Nothing ->
              React.empty
            Just (Tuple level body) ->
              Alert.component
                { level
                , child: body
                , dismiss: dispatch DismissAlert
                }
        , row $ Input.component
          { text: state.text
          , onChange: dispatch <<< UpdateText
          , onSubmit: dispatch ParseText
          , onHelp: dispatch ShowHelp
          }
        , row $ R.h3_ [R.text "Definitions"]
        , row $ Definitions.component
          { defs: state.defs
          , rep: state.rep
          , onDelete: dispatch <<< DeleteDef
          }
        , split
          (R.h3_ [R.text "Evaluation"])
          (Controls.component
            { machine: state.machine
            , onStep: dispatch <<< Step
            , onClear: dispatch Clear
            , onSave: save state
            , onSugar: dispatch ToggleSugar
            , rep: state.rep
            }
          )
        , row $ Expressions.component
          { history: state.history
          , rep: state.rep
          }
        , row $ Footer.component {}
        ]
      }

-- | Row containing a single full-width element
row :: JSX -> JSX
row child =
  R.div
    { className: "row"
    , children: [R.div {className: "col-sm-12", children: [child]}]
    }

-- | Row containing two equal-width elements
split :: JSX -> JSX -> JSX
split lhs rhs =
  R.div
    { className: "row"
    , children:
      [ R.div {className: "col-sm-6", children: [lhs]}
      , R.div {className: "col-sm-6", children: [rhs]}
      ]
    }

-- | Default set of global definitions
prelude :: Array Definition
prelude =
  unsafeParse parseDefinition <$>
    [ "identity x = x"
    , "const x y = x"
    , "fix f = (λx. f (x x)) (λy. f (y y))"
    , "true t f = t"
    , "false t f = f"
    , "and x y = x y false"
    , "or x y = x true y"
    , "succ n s z = s (n s z)"
    , "pred n f x = n (λg. λh. h (g f)) (λu. x) (λu. u)"
    , "add m n s z = m s (n s z)"
    , "mul m n s z = m (n s) z"
    , "is-zero? n = n (λx. false) true"
    , "foldr f z l = l f z"
    , "any = foldr or false"
    , "all = foldr and true"
    ]

-- | Set of user-driven events
data Action
  = ShowHelp
  | DismissAlert
  | UpdateText String
  | ParseText
  | DeleteDef Name
  | AddDef Definition
  | SetExpr Syntax
  | Step Machine
  | Clear
  | ToggleSugar

-- | Empty state with default global definitions
initialState :: State
initialState =
  { text: ""
  , defs: prelude
  , world: World.new $ defsToGlobals prelude
  , machine: Nothing
  , history: []
  , rep: Raw
  , alert: Nothing
  }

-- | Update `State` in response to an `Action`
update :: State -> Action -> State
update s = case _ of
  ShowHelp -> showHelp s
  DismissAlert -> dismissAlert s
  UpdateText text -> updateText text s
  ParseText -> parseText s
  DeleteDef name -> deleteDef name s
  AddDef def -> addDef def s
  SetExpr expr -> setExpr expr s
  Step machine -> step machine s
  Clear -> clear s
  ToggleSugar -> toggleSugar s

-- | Present the tutorial alert
showHelp :: State -> State
showHelp =
  _ {alert = pure $ Tuple Info $ Help.component {} }

-- | Dismiss any alert
dismissAlert :: State -> State
dismissAlert =
  _ {alert = Nothing}

-- | Update input text
updateText :: String -> State -> State
updateText text =
  _ {alert = Nothing, text = text}

-- | Attempt to parse the input. Input may be a definition, an
-- | expression, or malformed, in which case, we'll surface a
-- | syntax error.
parseText :: State -> State
parseText s
  | s.text == "" = s
parseText s =
  case parseAll parseEither s.text of
    Left error ->
      s {alert = pure $ alert Danger $ formatParseError s.text error}
    Right (Left def) ->
      addDef def s
    Right (Right syntax) ->
      setExpr syntax s

-- | Attempt to delete a global definition. If the input or any other
-- | global definition depends on it, we'll refuse to delete the
-- | definition and present an error message.
deleteDef :: Name -> State -> State
deleteDef name s = case World.undefine name s.world of
  Left err ->
    s {alert = pure $ alert Danger $ show err}
  Right world -> s
    { defs = deleteByName name s.defs
    , world = world
    , machine = Machine.remove name <$> s.machine
    , alert = Nothing
    }

-- | Remove a definition by name. Used when deleting a definition or
-- | redefining an extant definition.
deleteByName :: Name -> Array Definition -> Array Definition
deleteByName name = filter $ (_ /= name) <<< _.name

-- | Attempt to add a new global definition. If the definition depends
-- | on undefined names, present an error message.
addDef :: Definition -> State -> State
addDef def s = case World.define def.name expr s.world of
  Left err ->
    s {alert = pure $ alert Danger $ show err}
  Right world -> s
    { text = ""
    , defs = deleteByName def.name s.defs `snoc` def
    , world = world
    , machine = Machine.add def.name expr <$> s.machine
    , alert = Nothing
    }
 where
  expr = syntaxToExpr $ defToSyntax def

-- | Attempt to set the main expression. If the expression depends on
-- | undefined names, present an error message.
setExpr :: Syntax -> State -> State
setExpr syntax s =
  case World.focus expr s.world of
    Left err ->
      s {alert = pure $ alert Danger $ show err}
    Right world -> s
      { text = ""
      , world = world
      , machine = machine
      , history = history
      , alert = Nothing
      }
 where
  expr = syntaxToExpr syntax
  globals = defsToGlobals s.defs
  history = pure $ prettyPrint syntax
  machine = pure $ Machine.new globals expr

-- | Convert `Definition`s to pairs of names and expressions.
defsToGlobals :: Array Definition -> Array (Tuple Name Expr)
defsToGlobals = map \def -> Tuple def.name $ syntaxToExpr $ defToSyntax def

-- | Do one step of evaluation and update the history.
step :: Machine -> State -> State
step m0 s =  s
  { machine = pure m
  , history = history
  }
 where
  m = Machine.step m0
  { root } = Machine.snapshot m
  history
    | Machine.halted m = s.history
    | otherwise = prettyPrint root `cons` s.history

-- | Unload the `Machine` and unset the main expression
clear :: State -> State
clear s = s
  { world = World.unfocus s.world
  , machine = Nothing
  , history = []
  }

-- | Toggle syntactic sugar for Church numerals and lists.
toggleSugar :: State -> State
toggleSugar s = s {rep = toggleRep s.rep}

-- | Download the state as a text file.
save :: State -> Effect Unit
save {rep, defs, history} =
  saveTextAs text "evaluation.txt"
 where
  allDefs = concat
    [ map defToDoc defs
    , [pure ""]
    , reverse history
    ]
  text = intercalate "\n" $ flip selectRep rep <$> allDefs

-- | Create an alert element with the specified message.
alert :: Level -> String -> Tuple Level JSX
alert level message =
  Tuple level body
 where
  body = R.p
    { className: "preformatted"
    , children: [R.text message]
    }