Add "Request" handling to App component

Add "Request" handling to App component

For async updates, we set a value on the app state's request field,
which is then handled in the useAff hook

module Components.App
  ( new
  ) where

import Lambda.Prelude hiding (State)

import Components.Alert as Alert
import Components.Modal as Modal
import Components.Spinner as Spinner
import Components.Level as Level
import Components.ConsistencyError as ConsistencyError
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 Components.Copy as Copy
import Components.ParseError as ParseError
import Data.Array as Array
import Data.Foldable (intercalate)
import Data.Grammar (pluralizeWith)
import Data.List as List
import Effect.Save (FileName(..), saveTextAs)
import Lambda.Api as Api
import Lambda.Env as Env
import Lambda.Language.Definition (Definition(..))
import Lambda.Language.Definition as Definition
import Lambda.Language.Expression (Expression)
import Lambda.Language.History (History)
import Lambda.Language.History as History
import Lambda.Language.Name (Name)
import Lambda.Language.Nameless (Nameless)
import Lambda.Language.Nameless as Nameless
import Lambda.Language.Parser (ParseError, parse)
import Lambda.Language.Parser as Parser
import Lambda.Language.Prelude as Prelude
import Lambda.Language.Pretty (Rep(..), toggle, pretty, toString)
import Lambda.Language.Program (Program)
import Lambda.Language.Snapshot.Code (Code)
import Lambda.Language.Statement (Statement(..))
import Lambda.Language.World (World, ConsistencyError)
import Lambda.Language.World as World
import Lambda.Machine (Machine)
import Lambda.Machine as Machine
import React.Basic (fragment, 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
import React.Basic.Hooks.Aff (useAff)
import Effect.Aff as Aff
import Effect.Aff (Milliseconds(..))

type Props =
  { code :: Maybe Code
  }

-- | Manages text-input, global definitions, semantic consistency
-- | (world field), and machine state, if any.
type State =
  { text :: String
  , defs :: Array Definition
  , expr :: Maybe Expression
  , world :: World
  , machine :: Maybe Machine
  , history :: History
  , rep :: Rep
  , alert :: Maybe Alert
  , steps :: Maybe Int
  , request :: Maybe Request
  }

data Alert
  = Help
  | ApiError String
  | ParseError String ParseError
  | Inconsistent ConsistencyError
  | Link Code

data Request
  = Fetch Code
  | Store Program

derive instance eqRequest :: Eq Request

new :: Component Props
new = do
  reducer <- mkReducer update
  copy <- Copy.new
  modal <- Modal.new
  spinner <- Spinner.new
  component "App" \{ code: mCode }  -> Hooks.do
    state /\ dispatch <- useReducer (mkState mCode) reducer
    _ <- useAff state.request $ case state.request of
      Nothing -> pure unit
      Just (Store program) -> do
        result <- Api.store program
        liftEffect $ dispatch $ either ShowError ShowCode result
      Just (Fetch code) -> do
          result <- Api.fetch code
          liftEffect $ dispatch $ either ShowError Load result

    let
      alert = case state.alert of
        Just Help -> row $ Alert.component
          { level: Level.Info
          , dismiss: dispatch DismissAlert
          , child: Help.component {}
          }
        Just (ApiError error) -> row $ Alert.component
          { level: Level.Danger
          , dismiss: dispatch DismissAlert
          , child: R.text error
          }
        Just (ParseError input error) -> row $ Alert.component
          { level: Level.Danger
          , dismiss: dispatch DismissAlert
          , child: ParseError.component
            { input
            , error
            }
          }
        Just (Inconsistent error) -> row $ Alert.component
          { level: Level.Danger
          , child: ConsistencyError.component { error }
          , dismiss: dispatch DismissAlert
          }
        Just (Link code) -> modal
          { level: Level.Info
          , title: "Copy Link To This Machine"
          , dismiss: dispatch DismissAlert
          , children:
            [ copy
              { text: Env.host <> "/" <> unwrap code
              }
            ]
          }
        Nothing -> React.empty

    pure $ fragment
      [ R.div
        { className: "container"
        , children:
          [ row $ R.h2
            { className: "page-header"
            , children: [R.text "Lambda Machine"]
            }
          , alert
          , 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
            (stepsHeader state.steps)
            (Controls.component
              { machine: state.machine
              , onStep: dispatch <<< Step
              , onClear: dispatch Clear
              , onShare: dispatch Share
              , onSave: save state
              , onSugar: dispatch ToggleSugar
              , rep: state.rep
              }
            )
          , row $ Expressions.component
            { history: state.history
            , rep: state.rep
            }
          , row $ Footer.component {}
          ]
        }
        , maybe React.empty (\_ -> spinner {}) state.request
      ]

-- | 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]}
      ]
    }

-- | Set of user-driven events
data Action
  = ShowHelp
  | DismissAlert
  | UpdateText String
  | ParseText
  | DeleteDef Name
  | AddDef Definition
  | SetExpr Expression
  | Step Machine
  | Clear
  | ToggleSugar
  | ShowError Api.Error
  | ShowCode Code
  | Load Program
  | Share

-- | Empty state with default global definitions
mkState :: Maybe Code -> State
mkState code = empty
  { defs = Prelude.defs
  , world = World.new $ defsToGlobals Prelude.defs
  , request = Fetch <$> code
  }

empty :: State
empty =
  { text: ""
  , expr: Nothing
  , defs: []
  , world: World.empty
  , machine: Nothing
  , history: History.empty
  , rep: Raw
  , alert: Nothing
  , steps: Nothing
  , request: Nothing
  }

load :: Program -> State -> State
load { defs, expr } old =
  case result of
    Left alert -> old { alert = Just alert, request = Nothing }
    Right state -> state { request = Nothing }
 where
  define state = alertFail <<< flip addDef state
  focus state = alertFail <<< flip setExpr state
  result = do
    state <- foldM define empty defs
    maybe (pure state) (focus state) expr

alertFail :: State -> Either Alert State
alertFail state = case state.alert of
  Just alert -> Left alert
  Nothing -> Right state

-- | 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
  Share -> share s
  ToggleSugar -> toggleSugar s
  ShowError err -> showError err s
  ShowCode code -> showCode code s
  Load program -> load program s

-- | Present the tutorial alert
showHelp :: State -> State
showHelp = _ { alert = pure Help }

-- | Show Api error
showError :: Api.Error -> State -> State
showError err = _
  { alert = pure $ ApiError $ toString $ pretty Sugar err
  , request = Nothing
  }

-- | Show link to machine that loads snapshot
showCode :: Code -> State -> State
showCode code = _
  { alert = pure $ Link code
  , request = Nothing
  }

-- | 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 Parser.run parse s.text of
    Left error -> s
      { alert = pure $ ParseError s.text error
      }
    Right (Define def) ->
      addDef def s
    Right (Eval 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 error -> s
    { alert = pure $ Inconsistent error
    }
  Right world -> s
    { defs = deleteByName name s.defs
    , world = world
    , 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 = Array.filter $ (_ /= name) <<< _.name <<< un Definition

-- | 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 name nameless s.world of
  Left error -> s
    { alert = pure $ Inconsistent error
    }
  Right world -> s
    { text = ""
    , defs = deleteByName name s.defs `Array.snoc` def
    , world = world
    , alert = Nothing
    }
 where
  { expr, name } = Definition.split def
  nameless = Nameless.from expr

-- | Attempt to set the main expression. If the expression depends on
-- | undefined names, present an error message.
setExpr :: Expression -> State -> State
setExpr syntax s =
  case World.focus expr s.world of
    Left error -> s
      { alert = pure $ Inconsistent error
      }
    Right world ->
      let
        machine = Machine.new globals expr
        snapshot = Machine.snapshot machine
      in s
        { text = ""
        , expr = Just syntax
        , world = world
        , machine = pure machine
        , history = History.new snapshot
        , alert = Nothing
        , steps = Just 0
        }
 where
  expr = Nameless.from syntax
  globals = defsToGlobals s.defs

-- | Convert `Definition`s to pairs of names and expressions.
defsToGlobals :: Array Definition -> Array (Tuple Name Nameless)
defsToGlobals = map \def ->
  let {expr, name} = Definition.split def
  in Tuple name $ Nameless.from expr

-- | Do one step of evaluation and update the history.
step :: Machine -> State -> State
step m0 s =  s
  { machine = pure m
  , history = history
  , steps = (1 + _) <$> s.steps
  }
 where
  m = Machine.step m0
  snapshot = Machine.snapshot m
  history = History.add snapshot s.history

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

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

-- | Store program
share :: State -> State
share s = s { request = Just $ Store { defs, expr } }
 where
  { defs, expr } = s

-- | Download the state as a text file.
save :: State -> Effect Unit
save {rep, defs, history} =
  saveTextAs text $ FileName "evaluation.txt"
 where
  layout [] rhs = intercalate "\n" rhs
  layout lhs [] = intercalate "\n" lhs
  layout lhs rhs = intercalate "\n" $ fold [lhs, pure "", rhs]
  text = layout
    (toString <<< pretty rep <$> defs)
    (Array.fromFoldable $ List.reverse $ History.toStrings rep history)

stepsHeader :: Maybe Int -> JSX
stepsHeader = case _ of
  Nothing -> R.h3
    { className: "text-muted"
    , children: [R.text "Steps"]
    }
  Just n -> R.h3_
    [ R.text $ fold
      [ show n
      , " "
      , pluralizeWith "s" n "Step"
      ]
    ]

module Components.App
  ( mkApp
  ) where

import Lambda.Prelude hiding (State)

import Components.Alert (Level(..))
import Components.Alert as Alert
import Components.ConsistencyError as ConsistencyError
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 Components.ParseError as ParseError
import Data.Array as Array
import Data.Foldable (intercalate)
import Data.Grammar (pluralizeWith)
import Data.List as List
import Effect.Class (liftEffect)
import Effect.Save (FileName(..), saveTextAs)
import Lambda.Api as Api
import Lambda.Env as Env
import Lambda.Language.Definition (Definition(..))
import Lambda.Language.Definition as Definition
import Lambda.Language.Expression (Expression)
import Lambda.Language.History (History)
import Lambda.Language.History as History
import Lambda.Language.Name (Name)
import Lambda.Language.Nameless (Nameless)
import Lambda.Language.Nameless as Nameless
import Lambda.Language.Parser (parse)
import Lambda.Language.Parser as Parser
import Lambda.Language.Prelude as Prelude
import Lambda.Language.Pretty (Rep(..), toggle, pretty, toString)
import Lambda.Language.Program (Program)
import Lambda.Language.Snapshot.Code (Code)
import Lambda.Language.Statement (Statement(..))
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
import React.Basic.Hooks.Aff (useAff)

type Props =
  { code :: Maybe Code
  }

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

data Request
  = Fetch Code
  | Store Program

derive instance eqRequest :: Eq Request

mkApp :: Component Props
mkApp = do
  reducer <- mkReducer update
  component "App" \{ code: mCode }  -> Hooks.do
    state /\ dispatch <- useReducer (mkState mCode) reducer
    _ <- useAff state.request $ case state.request of
      Nothing -> pure unit
      Just (Store program) -> do
        result <- Api.store program
        liftEffect $ do
          dispatch $ case result of
            Left err -> ShowError err
            Right code -> ShowCode code
      Just (Fetch code) -> do
        result <- Api.fetch code
        liftEffect $ dispatch $ case result of
          Left err -> ShowError err
          Right program -> Load program

    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
          (stepsHeader state.steps)
          (Controls.component
            { machine: state.machine
            , onStep: dispatch <<< Step
            , onClear: dispatch Clear
            , onShare: dispatch Share
            , 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]}
      ]
    }

-- | Set of user-driven events
data Action
  = ShowHelp
  | DismissAlert
  | UpdateText String
  | ParseText
  | DeleteDef Name
  | AddDef Definition
  | SetExpr Expression
  | Step Machine
  | Clear
  | ToggleSugar
  | ShowError Api.Error
  | ShowCode Code
  | Load Program
  | Share

-- | Empty state with default global definitions
mkState :: Maybe Code -> State
mkState code = empty
  { defs = Prelude.defs
  , world = World.new $ defsToGlobals Prelude.defs
  , request = Fetch <$> code
  }

empty :: State
empty =
  { text: ""
  , expr: Nothing
  , defs: []
  , world: World.empty
  , machine: Nothing
  , history: History.empty
  , rep: Raw
  , alert: Nothing
  , steps: Nothing
  , request: Nothing
  }

load :: Program -> State -> State
load { defs, expr } old =
  case result of
    Left alert -> old { alert = Just alert, request = Nothing }
    Right state -> state { request = Nothing }
 where
  define state = alertFail <<< flip addDef state
  focus state = alertFail <<< flip setExpr state
  result = do
    state <- foldM define empty defs
    maybe (pure state) (focus state) expr

alertFail :: State -> Either (Tuple Level JSX) State
alertFail state = case state.alert of
  Just alert -> Left alert
  Nothing -> Right state

-- | 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
  Share -> share s
  ToggleSugar -> toggleSugar s
  ShowError err -> showError err s
  ShowCode code -> showCode code s
  Load program -> load program s

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

-- | Show Api error
showError :: Api.Error -> State -> State
showError err = _
  { alert = pure $ Tuple Info $ R.p
    { children:
      [ R.text $ toString $ pretty Sugar err
      ]
    }
  , request = Nothing
  }

-- | Show link to machine that loads snapshot
showCode :: Code -> State -> State
showCode code = _
  { alert = pure $ Tuple Info $ R.p
    { children:
      [ R.text $ Env.host <> "/" <> unwrap code
      ]
    }
  , request = Nothing
  }

-- | 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 Parser.run parse s.text of
    Left error -> s
      { alert = pure
        $ Tuple Danger
        $ ParseError.component
          { input: s.text
          , error
          }
      }
    Right (Define def) ->
      addDef def s
    Right (Eval 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 error -> s
    { alert = pure
      $ Tuple Danger
      $ ConsistencyError.component
        { error
        }
    }
  Right world -> s
    { defs = deleteByName name s.defs
    , world = world
    , 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 = Array.filter $ (_ /= name) <<< _.name <<< un Definition

-- | 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 name nameless s.world of
  Left error -> s
    { alert = pure
      $ Tuple Danger
      $ ConsistencyError.component
        { error
        }
    }
  Right world -> s
    { text = ""
    , defs = deleteByName name s.defs `Array.snoc` def
    , world = world
    , alert = Nothing
    }
 where
  { expr, name } = Definition.split def
  nameless = Nameless.from expr

-- | Attempt to set the main expression. If the expression depends on
-- | undefined names, present an error message.
setExpr :: Expression -> State -> State
setExpr syntax s =
  case World.focus expr s.world of
    Left error -> s
      { alert = pure
        $ Tuple Danger
        $ ConsistencyError.component
          { error
          }
      }
    Right world ->
      let
        machine = Machine.new globals expr
        snapshot = Machine.snapshot machine
      in s
        { text = ""
        , expr = Just syntax
        , world = world
        , machine = pure machine
        , history = History.new snapshot
        , alert = Nothing
        , steps = Just 0
        }
 where
  expr = Nameless.from syntax
  globals = defsToGlobals s.defs

-- | Convert `Definition`s to pairs of names and expressions.
defsToGlobals :: Array Definition -> Array (Tuple Name Nameless)
defsToGlobals = map \def ->
  let {expr, name} = Definition.split def
  in Tuple name $ Nameless.from expr

-- | Do one step of evaluation and update the history.
step :: Machine -> State -> State
step m0 s =  s
  { machine = pure m
  , history = history
  , steps = (1 + _) <$> s.steps
  }
 where
  m = Machine.step m0
  snapshot = Machine.snapshot m
  history = History.add snapshot s.history

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

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

-- | Store program
share :: State -> State
share s = s { request = Just $ Store { defs, expr } }
 where
  { defs, expr } = s

-- | Download the state as a text file.
save :: State -> Effect Unit
save {rep, defs, history} =
  saveTextAs text $ FileName "evaluation.txt"
 where
  text = intercalate "\n" $ fold
    [ toString <<< pretty rep <$> defs
    , pure ""
    , Array.fromFoldable $ List.reverse $ History.toStrings rep history
    ]

stepsHeader :: Maybe Int -> JSX
stepsHeader = case _ of
  Nothing -> R.h3
    { className: "text-muted"
    , children: [R.text "Steps"]
    }
  Just n -> R.h3_
    [ R.text $ fold
      [ show n
      , " "
      , pluralizeWith "s" n "Step"
      ]
    ]


Updated types of "render" and "parse" to reflect that both have side effects (internal caching within mustache.js)

module Mustache where

import Control.Monad.Eff (Eff())
import Data.StrMap
import Prelude

type Template = String

type Tag = String

type View = StrMap String

type Partials = StrMap String

foreign import data MustacheEffect :: !

foreign import name :: String

foreign import version :: String

foreign import tags :: Array Tag

foreign import parse :: forall e. Template -> Array Tag -> Eff (mustache :: MustacheEffect | e) (Array (Array String))

foreign import render :: forall e. Template -> View -> Partials -> Eff (mustache :: MustacheEffect | e) String

foreign import escape :: String -> String

foreign import clearCache :: forall e. Eff (mustache :: MustacheEffect | e) Unit

module Mustache where

import Control.Monad.Eff (Eff())
import Data.StrMap
import Prelude

type Template = String

type Tag = String

type View = StrMap String

type Partials = StrMap String

foreign import data MustacheEffect :: !

foreign import name :: String

foreign import version :: String

foreign import tags :: Array Tag

foreign import parse :: Template -> Array Tag -> Array (Array String)

foreign import render :: Template -> View -> Partials -> String

foreign import escape :: String -> String

foreign import clearCache :: forall e. Eff (mustache :: MustacheEffect | e) Unit


Resolve warning

Resolve warning

module IdePurescript.Atom.Psci where

import Prelude
import Ansi.Codes (Color(..))
import Atom.Atom (getAtom)
import Atom.CommandRegistry (addCommand', COMMAND, addCommand)
import Atom.Config (CONFIG, getConfig)
import Atom.Editor (setText, getText, TextEditor, EDITOR, getSelectedText, moveToBeginningOfLine, moveDown, getTextInRange, getCursorBufferPosition)
import Atom.Grammar (GRAMMAR)
import Atom.GrammarRegistry (grammarForScopeName)
import Atom.NotificationManager (addError, NOTIFY)
import Atom.Pane (PANE, destroyItem)
import Atom.Point (getRow, mkPoint)
import Atom.Project (PROJECT)
import Atom.Range (mkRange)
import Atom.Workspace (getActiveTextEditor, WORKSPACE, defaultOpenOptions, open, addOpener, paneForItem)
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff (whileE, Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (catchException, error)
import Control.Monad.Eff.Ref (readRef, writeRef, Ref, newRef, REF)
import Control.Monad.Except (runExcept)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Types (htmlDocumentToDocument)
import DOM.HTML.Window (document)
import DOM.Node.Document (createElement)
import DOM.Node.Element (setClassName, setAttribute)
import DOM.Node.Node (setTextContent, firstChild, removeChild, hasChildNodes, appendChild)
import DOM.Node.ParentNode (querySelector)
import DOM.Node.Types (elementToParentNode, elementToNode, Element)
import DOM.Util (setTimeout, setScrollTop, getScrollHeight)
import Data.Array (uncons, (!!), cons, drop)
import Data.Either (either, Either(..))
import Data.Foldable (traverse_)
import Data.Foreign (readString)
import Data.Int (fromNumber)
import Data.Maybe (maybe, Maybe(Nothing, Just), isJust, fromMaybe)
import Data.Nullable (toNullable, Nullable, toMaybe)
import Data.String (Pattern(Pattern), indexOf, trim)
import Data.String.Regex (split, regex)
import Data.String.Regex.Flags (noFlags)
import Global (readInt)
import IdePurescript.Atom.Imports (launchAffAndRaise)
import IdePurescript.Atom.LinterBuild (getProjectRoot)
import IdePurescript.Atom.PromptPanel (focus)
import IdePurescript.Regex (match')
import Node.ChildProcess (CHILD_PROCESS, ChildProcess, Exit(Normally), defaultSpawnOptions, onClose, onError, spawn, stderr, stdin, stdout, toStandardError)
import Node.Encoding (Encoding(UTF8))
import Node.FS (FS)
import Node.Stream (end, writeString, onDataString)
import Unsafe.Coerce (unsafeCoerce)

foreign import init :: forall eff. Eff eff Unit

type PscPane = { getTitle :: Unit -> String, element :: Element }

createElement' :: forall eff. String -> Eff (dom :: DOM | eff) Element
createElement' elt = do
  doc <- htmlDocumentToDocument <$> (window >>= document)
  createElement elt doc

foreign import getModel :: forall eff. Element -> Eff (dom :: DOM | eff) (Nullable TextEditor)

foreign import copy :: forall eff. Eff (dom :: DOM | eff) Unit

paneUri :: String
paneUri = "purescript://psci"

registerCommands :: forall eff. Eff (command :: COMMAND, dom :: DOM | eff) Unit
registerCommands = do
  atom <- getAtom
  addCommand atom.commands ".psci-pane" "ide-purescript:psci-copy" $ const copy

opener :: forall eff. String -> Eff (dom :: DOM, console :: CONSOLE | eff) (Nullable PscPane)
opener s =
  case indexOf (Pattern paneUri) s of
    Just 0 -> do
      div <- createElement' "div"
      setClassName "psci-pane" div
      setAttribute "tabindex" "0" div
      topDiv <- createElement' "div"
      setClassName "psci-lines" topDiv
      appendChild (elementToNode topDiv) (elementToNode div)
      bottomDiv <- createElement' "div"
      setClassName "psci-input padded inset-panel" bottomDiv

      editorElt <- createElement' "atom-text-editor"
      setAttribute "mini" "true" editorElt
      appendChild (elementToNode editorElt) (elementToNode bottomDiv)

      appendChild (elementToNode bottomDiv) (elementToNode div)

      setTimeout 10 $ focus editorElt

      pure $ toNullable $ Just { getTitle: \_ -> "PSCI", element: div }
    _ -> pure $ toNullable Nothing

openPsci :: forall eff. Aff (ref :: REF, console :: CONSOLE, workspace :: WORKSPACE, note :: NOTIFY, dom :: DOM | eff) TextEditor
openPsci = makeAff \err cb -> do
  atom <- getAtom
  addOpener atom.workspace (unsafeCoerce opener)
  open atom.workspace paneUri (defaultOpenOptions { split = "right", activatePane = false }) cb (err $ error "Can't Open PSCI")

type PsciEff eff =
  ( ref :: REF
  , console :: CONSOLE
  , workspace :: WORKSPACE
  , pane :: PANE
  , note :: NOTIFY
  , grammar :: GRAMMAR
  , editor :: EDITOR
  , config :: CONFIG
  , fs :: FS
  , project :: PROJECT
  , cp :: CHILD_PROCESS
  , dom :: DOM
  , command :: COMMAND | eff)

-- TODO: contribute to purescript-ansi
colorForCode :: Int -> Maybe Color
colorForCode c =
  case c of
    30 -> Just Black
    31 -> Just Red
    32 -> Just Green
    33 -> Just Yellow
    34 -> Just Blue
    35 -> Just Magenta
    36 -> Just Cyan
    37 -> Just White
    90 -> Just Grey
    91 -> Just BrightRed
    92 -> Just BrightGreen
    93 -> Just BrightYellow
    94 -> Just BrightBlue
    95 -> Just BrightMagenta
    96 -> Just BrightCyan
    97 -> Just BrightWhite
    _  -> Nothing

data Rgb = Rgb Int Int Int

xtermColor :: Color -> Rgb
xtermColor c = case c of
  White         -> Rgb 229 229 229
  Black         -> Rgb 0 0 0
  Blue          -> Rgb 0 0 238
  Cyan          -> Rgb 0 205 205
  Green         -> Rgb 0 205 0
  Magenta       -> Rgb 205 0 205
  Red           -> Rgb 205 0 0
  Yellow        -> Rgb 205 205 0
  Grey          -> Rgb 127 127 127
  BrightBlack   -> Rgb 127 127 127
  BrightRed     -> Rgb 255 0 0
  BrightGreen   -> Rgb 0 255 0
  BrightYellow  -> Rgb 255 255 0
  BrightBlue    -> Rgb 92 92 255
  BrightMagenta -> Rgb 255 0 255
  BrightCyan    -> Rgb 0 255 255
  BrightWhite   -> Rgb 255 255 255

renderRgbCss :: Rgb -> String
renderRgbCss (Rgb r g b) = "rgb(" <> show r <> "," <> show g <> "," <> show b <> ")"

replaceAnsiColor :: forall eff. String -> Eff (PsciEff eff) (Array Element)
replaceAnsiColor text = toNodes parts
  where
    parts :: Array String
    parts = either (const []) (\r -> split r text) (regex """(\x1b\[[0-9;]+m)""" noFlags)

    colEscape :: String -> Maybe Int
    colEscape str = case match' (regex """\x1b\[([0-9]+)m""" noFlags) str of
      Just [_, Just num] -> fromNumber (readInt 10 num)
      _ -> Nothing

    colorCss :: Int -> String
    colorCss n = "color: " <> maybe "black" (renderRgbCss <<< xtermColor) (colorForCode n)

    toNodes :: Array String -> Eff (PsciEff eff) (Array Element)
    toNodes [] = pure []
    toNodes xs | (maybe Nothing colEscape (xs !! 2)) == Just 0 && isJust (maybe Nothing colEscape (xs !! 0)) =
      case maybe Nothing colEscape (xs !! 0), xs !! 1 of
        Just n, Just innerText -> do
          span <- createElement' "span"
          setTextContent innerText (elementToNode span)
          setAttribute "style" (colorCss n) span
          rest <- toNodes (drop 3 xs)
          pure $ cons span rest
        _, _ -> pure []
    toNodes xs = do
      let str = fromMaybe "" (xs !! 0)
      span <- createElement' "span"
      setTextContent str (elementToNode span)
      rest <- toNodes (drop 1 xs)
      pure $ cons span rest

appendText :: forall eff. PscPane  -> String -> Eff (PsciEff eff) Unit
appendText {element} text = do
  div <- createElement' "div"
  setClassName "psci-line" div
  replaceAnsiColor text >>= traverse_ \node -> appendChild (elementToNode node) (elementToNode div)
  lines <- toMaybe <$> querySelector ".psci-lines" (elementToParentNode element)
  maybe (log "appendText failed") (\lines' -> do
    appendChild (elementToNode div) (elementToNode lines')
    height <- getScrollHeight lines'
    setScrollTop lines' height) lines

clearText :: forall eff. PscPane -> Eff (PsciEff eff) Unit
clearText {element} = do
  let node = elementToNode element
  whileE (hasChildNodes node) do
    child <- toMaybe <$> firstChild node
    maybe (pure unit) (void <<< flip removeChild node) child

sendText :: forall eff. PscPane -> ChildProcess -> String -> Eff (PsciEff eff) Unit
sendText pane proc text = do
  let text' = trim text <> "\n"
  appendText pane text'
  void $ writeString (stdin proc) UTF8 text' (pure unit)

sendText' :: forall eff. (TextEditor -> Eff (PsciEff eff) String) -> PscPane -> ChildProcess -> Eff (PsciEff eff) Unit
sendText' getText pane proc  = do
  atom <- getAtom
  activeEditor <- getActiveTextEditor atom.workspace
  maybe (pure unit) (\ed -> do
    text <- getText ed
    sendText pane proc text
    ) activeEditor

sendLine :: forall eff. PscPane -> ChildProcess -> Eff (PsciEff eff) Unit
sendLine = sendText' $ \ed -> do
  pos <- getCursorBufferPosition ed
  let p c = mkPoint (getRow pos) c
  text <- getTextInRange ed (mkRange (p 0) (p 1000))
  moveDown ed 1
  moveToBeginningOfLine ed
  pure text

closePsci :: forall eff. PscPane -> ChildProcess -> Eff (PsciEff eff) Unit
closePsci pane proc = do
  sendText pane proc ":q"
  end (stdin proc) (pure unit)

sendSelection :: forall eff. PscPane -> ChildProcess -> Eff (PsciEff eff) Unit
sendSelection = sendText' getSelectedText

startRepl :: forall eff. Ref (Maybe PscPane) -> Ref (Maybe ChildProcess) -> Aff (PsciEff eff) Unit
startRepl paneRef psciRef = do
  atom <- liftEff'' getAtom
  let notifyErr :: forall eff1. String -> Eff (console :: CONSOLE, note :: NOTIFY | eff1) Unit
      notifyErr msg = do
        log msg
        addError atom.notifications msg

  pane :: PscPane <- unsafeCoerce openPsci

  liftEff'' do
    writeRef paneRef $ Just pane
    log "Started PSCI"
    grammar <- grammarForScopeName atom.grammars "source.purescript.psci"
    pure unit

  cmd <- liftEff'' $ runExcept <$> readString <$> getConfig atom.config "ide-purescript.psciCommand"
  rootPath <- liftEff'' $ getProjectRoot false
  let command = case cmd, regex "\\s+" noFlags of
                  Right cmd', Right r -> split r cmd'
                  _, _ -> []
  psciProcess <- liftEff'' $ case rootPath, uncons command of
    Just _, Just { head: bin, tail: args } ->
      Just <$> spawn bin args (defaultSpawnOptions { cwd = rootPath })
    Nothing, _ -> Nothing <$ notifyErr "Couldn't find project root, are you in a PureScript project?"
    _, Nothing -> Nothing <$ (notifyErr $ "Couldn't parse PSCI command: " <> show command)
  liftEff'' $ maybe (pure unit) (writeRef psciRef <<< Just) psciProcess
  liftEff'' $ maybe (pure unit) (\proc -> catchException (\e -> notifyErr $ "Couldn't launch PSCI: " <> show e) $ do
    onDataString (stdout proc) UTF8 (appendText pane)
    onDataString (stderr proc) UTF8 (appendText pane)
    onError proc (notifyErr <<< show <<< toStandardError)
    onClose proc (\exit ->
      case exit of
        Normally 0 -> log "psci exited successfully"
        _ -> notifyErr "PSCI exited abnormally"
      )
    editorElt <- toMaybe <$> querySelector ".psci-input atom-text-editor" (elementToParentNode pane.element)
    case editorElt of
      Just editorElt' -> (do
        editor <- toMaybe <$> getModel editorElt'
        maybe (pure unit) (\ed -> do
          addCommand' atom.commands editorElt' "core:confirm" (\_ -> do
            text <- getText ed
            setText ed ""
            sendText pane proc text
          )
        ) editor
      )
      Nothing -> pure unit
    log "Started PSCI"
  ) psciProcess

  where liftEff'' :: forall a. Eff (PsciEff eff) a -> Aff (PsciEff eff) a
        liftEff'' = liftEff

activate :: forall eff. Eff (PsciEff eff) Unit
activate = do
  atom <- getAtom
  paneRef <- newRef (Nothing :: Maybe PscPane)
  psciRef <- newRef (Nothing :: Maybe ChildProcess)

  let close = do
        pane <- liftEff $ readRef paneRef
        psci <- liftEff $ readRef psciRef
        case pane, psci of
          Just e, Just p -> do
            closePsci e p
            writeRef psciRef Nothing
            writeRef paneRef Nothing
            atomPane <- paneForItem atom.workspace e
            case atomPane of
              Just pp -> void $ destroyItem pp e
              Nothing -> pure unit
          _, _ -> pure unit

  let runCmd c = do
        pane <- liftEff $ readRef paneRef
        psci <- liftEff $ readRef psciRef
        case pane, psci of
          Just e, Just p -> liftEff $ c e p
          _, _ -> do
            startRepl paneRef psciRef
            runCmd c

  let open = launchAffAndRaise $ startRepl paneRef psciRef
  let reset = do
        ed <- readRef paneRef
        close
        maybe (pure unit) clearText ed
        open

  let cmd isEditor name action = addCommand atom.commands "atom-workspace" ("ide-purescript:psci-"<>name) (const action)
        where scope = if isEditor then "atom-text-editor" else "atom-workspace"
  cmd false "open" $ reset
  cmd true  "send-line" $ launchAffAndRaise $ runCmd sendLine
  cmd true  "send-selection" $ launchAffAndRaise $ runCmd sendSelection
  cmd true  "reset" $ reset

module IdePurescript.Atom.Psci where

import Prelude
import Ansi.Codes (Color(..))
import Atom.Atom (getAtom)
import Atom.CommandRegistry (addCommand', COMMAND, addCommand)
import Atom.Config (CONFIG, getConfig)
import Atom.Editor (setText, getText, TextEditor, EDITOR, getSelectedText, moveToBeginningOfLine, moveDown, getTextInRange, getCursorBufferPosition)
import Atom.Grammar (GRAMMAR)
import Atom.GrammarRegistry (grammarForScopeName)
import Atom.NotificationManager (addError, NOTIFY)
import Atom.Pane (PANE, destroyItem)
import Atom.Point (getRow, mkPoint)
import Atom.Project (PROJECT)
import Atom.Range (mkRange)
import Atom.Workspace (getActiveTextEditor, WORKSPACE, defaultOpenOptions, open, addOpener, paneForItem)
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff (whileE, Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (catchException, error)
import Control.Monad.Eff.Ref (readRef, writeRef, Ref, newRef, REF)
import Control.Monad.Except (runExcept)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Types (htmlDocumentToDocument)
import DOM.HTML.Window (document)
import DOM.Node.Document (createElement)
import DOM.Node.Element (setClassName, setAttribute)
import DOM.Node.Node (setTextContent, firstChild, removeChild, hasChildNodes, appendChild)
import DOM.Node.ParentNode (querySelector)
import DOM.Node.Types (elementToParentNode, elementToNode, Element)
import DOM.Util (setTimeout, setScrollTop, getScrollHeight)
import Data.Array (uncons, (!!), cons, drop)
import Data.Either (either, Either(..))
import Data.Foldable (traverse_)
import Data.Foreign (readString)
import Data.Int (fromNumber)
import Data.Maybe (maybe, Maybe(Nothing, Just), isJust, fromMaybe)
import Data.Nullable (toNullable, Nullable, toMaybe)
import Data.String (Pattern(Pattern), indexOf, trim)
import Data.String.Regex (split, regex)
import Data.String.Regex.Flags (noFlags)
import Global (readInt)
import IdePurescript.Atom.Imports (launchAffAndRaise)
import IdePurescript.Atom.LinterBuild (getProjectRoot)
import IdePurescript.Atom.PromptPanel (focus)
import IdePurescript.Regex (match')
import Node.ChildProcess (CHILD_PROCESS, ChildProcess, Exit(Normally), defaultSpawnOptions, onClose, onError, spawn, stderr, stdin, stdout, toStandardError)
import Node.Encoding (Encoding(UTF8))
import Node.FS (FS)
import Node.Stream (end, writeString, onDataString)
import Unsafe.Coerce (unsafeCoerce)

foreign import init :: forall eff. Eff eff Unit

type PscPane = { getTitle :: Unit -> String, element :: Element }

createElement' :: forall eff. String -> Eff (dom :: DOM | eff) Element
createElement' elt = do
  doc <- htmlDocumentToDocument <$> (window >>= document)
  createElement elt doc

foreign import getModel :: forall eff. Element -> Eff (dom :: DOM | eff) (Nullable TextEditor)

foreign import copy :: forall eff. Eff (dom :: DOM | eff) Unit

paneUri :: String
paneUri = "purescript://psci"

registerCommands :: forall eff. Eff (command :: COMMAND, dom :: DOM | eff) Unit
registerCommands = do
  atom <- getAtom
  addCommand atom.commands ".psci-pane" "ide-purescript:psci-copy" $ const copy

opener :: forall eff. String -> Eff (dom :: DOM, console :: CONSOLE | eff) (Nullable PscPane)
opener s =
  case indexOf (Pattern paneUri) s of
    Just 0 -> do
      div <- createElement' "div"
      setClassName "psci-pane" div
      setAttribute "tabindex" "0" div
      topDiv <- createElement' "div"
      setClassName "psci-lines" topDiv
      appendChild (elementToNode topDiv) (elementToNode div)
      bottomDiv <- createElement' "div"
      setClassName "psci-input padded inset-panel" bottomDiv

      editorElt <- createElement' "atom-text-editor"
      setAttribute "mini" "true" editorElt
      appendChild (elementToNode editorElt) (elementToNode bottomDiv)

      appendChild (elementToNode bottomDiv) (elementToNode div)

      setTimeout 10 $ focus editorElt

      pure $ toNullable $ Just { getTitle: \_ -> "PSCI", element: div }
    _ -> pure $ toNullable Nothing

openPsci :: forall eff. Aff (ref :: REF, console :: CONSOLE, workspace :: WORKSPACE, note :: NOTIFY, dom :: DOM | eff) TextEditor
openPsci = makeAff \err cb -> do
  atom <- getAtom
  addOpener atom.workspace (unsafeCoerce opener)
  open atom.workspace paneUri (defaultOpenOptions { split = "right", activatePane = false }) cb (err $ error "Can't Open PSCI")

type PsciEff eff =
  ( ref :: REF
  , console :: CONSOLE
  , workspace :: WORKSPACE
  , pane :: PANE
  , note :: NOTIFY
  , grammar :: GRAMMAR
  , editor :: EDITOR
  , config :: CONFIG
  , fs :: FS
  , project :: PROJECT
  , cp :: CHILD_PROCESS
  , dom :: DOM
  , command :: COMMAND | eff)

-- TODO: contribute to purescript-ansi
colorForCode :: Int -> Maybe Color
colorForCode c =
  case c of
    30 -> Just Black
    31 -> Just Red
    32 -> Just Green
    33 -> Just Yellow
    34 -> Just Blue
    35 -> Just Magenta
    36 -> Just Cyan
    37 -> Just White
    90 -> Just Grey
    91 -> Just BrightRed
    92 -> Just BrightGreen
    93 -> Just BrightYellow
    94 -> Just BrightBlue
    95 -> Just BrightMagenta
    96 -> Just BrightCyan
    97 -> Just BrightWhite
    _  -> Nothing

data Rgb = Rgb Int Int Int

xtermColor :: Color -> Rgb
xtermColor c = case c of
  White         -> Rgb 229 229 229
  Black         -> Rgb 0 0 0
  Blue          -> Rgb 0 0 238
  Cyan          -> Rgb 0 205 205
  Green         -> Rgb 0 205 0
  Magenta       -> Rgb 205 0 205
  Red           -> Rgb 205 0 0
  Yellow        -> Rgb 205 205 0
  Grey          -> Rgb 127 127 127
  BrightBlack   -> Rgb 127 127 127
  BrightRed     -> Rgb 255 0 0
  BrightGreen   -> Rgb 0 255 0
  BrightYellow  -> Rgb 255 255 0
  BrightBlue    -> Rgb 92 92 255
  BrightMagenta -> Rgb 255 0 255
  BrightCyan    -> Rgb 0 255 255
  BrightWhite   -> Rgb 255 255 255

renderRgbCss :: Rgb -> String
renderRgbCss (Rgb r g b) = "rgb(" <> show r <> "," <> show g <> "," <> show b <> ")"

replaceAnsiColor :: forall eff. String -> Eff (PsciEff eff) (Array Element)
replaceAnsiColor text = toNodes parts
  where
    parts :: Array String
    parts = either (const []) (\r -> split r text) (regex """(\x1b\[[0-9;]+m)""" noFlags)

    colEscape :: String -> Maybe Int
    colEscape text = case match' (regex """\x1b\[([0-9]+)m""" noFlags) text of
      Just [_, Just num] -> fromNumber (readInt 10 num)
      _ -> Nothing

    colorCss :: Int -> String
    colorCss n = "color: " <> maybe "black" (renderRgbCss <<< xtermColor) (colorForCode n)

    toNodes :: Array String -> Eff (PsciEff eff) (Array Element)
    toNodes [] = pure []
    toNodes xs | (maybe Nothing colEscape (xs !! 2)) == Just 0 && isJust (maybe Nothing colEscape (xs !! 0)) =
      case maybe Nothing colEscape (xs !! 0), xs !! 1 of
        Just n, Just innerText -> do
          span <- createElement' "span"
          setTextContent innerText (elementToNode span)
          setAttribute "style" (colorCss n) span
          rest <- toNodes (drop 3 xs)
          pure $ cons span rest
        _, _ -> pure []
    toNodes xs = do
      let text = fromMaybe "" (xs !! 0)
      span <- createElement' "span"
      setTextContent text (elementToNode span)
      rest <- toNodes (drop 1 xs)
      pure $ cons span rest

appendText :: forall eff. PscPane  -> String -> Eff (PsciEff eff) Unit
appendText {element} text = do
  div <- createElement' "div"
  setClassName "psci-line" div
  replaceAnsiColor text >>= traverse_ \node -> appendChild (elementToNode node) (elementToNode div)
  lines <- toMaybe <$> querySelector ".psci-lines" (elementToParentNode element)
  maybe (log "appendText failed") (\lines' -> do
    appendChild (elementToNode div) (elementToNode lines')
    height <- getScrollHeight lines'
    setScrollTop lines' height) lines

clearText :: forall eff. PscPane -> Eff (PsciEff eff) Unit
clearText {element} = do
  let node = elementToNode element
  whileE (hasChildNodes node) do
    child <- toMaybe <$> firstChild node
    maybe (pure unit) (void <<< flip removeChild node) child

sendText :: forall eff. PscPane -> ChildProcess -> String -> Eff (PsciEff eff) Unit
sendText pane proc text = do
  let text' = trim text <> "\n"
  appendText pane text'
  void $ writeString (stdin proc) UTF8 text' (pure unit)

sendText' :: forall eff. (TextEditor -> Eff (PsciEff eff) String) -> PscPane -> ChildProcess -> Eff (PsciEff eff) Unit
sendText' getText pane proc  = do
  atom <- getAtom
  activeEditor <- getActiveTextEditor atom.workspace
  maybe (pure unit) (\ed -> do
    text <- getText ed
    sendText pane proc text
    ) activeEditor

sendLine :: forall eff. PscPane -> ChildProcess -> Eff (PsciEff eff) Unit
sendLine = sendText' $ \ed -> do
  pos <- getCursorBufferPosition ed
  let p c = mkPoint (getRow pos) c
  text <- getTextInRange ed (mkRange (p 0) (p 1000))
  moveDown ed 1
  moveToBeginningOfLine ed
  pure text

closePsci :: forall eff. PscPane -> ChildProcess -> Eff (PsciEff eff) Unit
closePsci pane proc = do
  sendText pane proc ":q"
  end (stdin proc) (pure unit)

sendSelection :: forall eff. PscPane -> ChildProcess -> Eff (PsciEff eff) Unit
sendSelection = sendText' getSelectedText

startRepl :: forall eff. Ref (Maybe PscPane) -> Ref (Maybe ChildProcess) -> Aff (PsciEff eff) Unit
startRepl paneRef psciRef = do
  atom <- liftEff'' getAtom
  let notifyErr :: forall eff1. String -> Eff (console :: CONSOLE, note :: NOTIFY | eff1) Unit
      notifyErr msg = do
        log msg
        addError atom.notifications msg

  pane :: PscPane <- unsafeCoerce openPsci

  liftEff'' do
    writeRef paneRef $ Just pane
    log "Started PSCI"
    grammar <- grammarForScopeName atom.grammars "source.purescript.psci"
    pure unit

  cmd <- liftEff'' $ runExcept <$> readString <$> getConfig atom.config "ide-purescript.psciCommand"
  rootPath <- liftEff'' $ getProjectRoot false
  let command = case cmd, regex "\\s+" noFlags of
                  Right cmd', Right r -> split r cmd'
                  _, _ -> []
  psciProcess <- liftEff'' $ case rootPath, uncons command of
    Just _, Just { head: bin, tail: args } ->
      Just <$> spawn bin args (defaultSpawnOptions { cwd = rootPath })
    Nothing, _ -> Nothing <$ notifyErr "Couldn't find project root, are you in a PureScript project?"
    _, Nothing -> Nothing <$ (notifyErr $ "Couldn't parse PSCI command: " <> show command)
  liftEff'' $ maybe (pure unit) (writeRef psciRef <<< Just) psciProcess
  liftEff'' $ maybe (pure unit) (\proc -> catchException (\e -> notifyErr $ "Couldn't launch PSCI: " <> show e) $ do
    onDataString (stdout proc) UTF8 (appendText pane)
    onDataString (stderr proc) UTF8 (appendText pane)
    onError proc (notifyErr <<< show <<< toStandardError)
    onClose proc (\exit ->
      case exit of
        Normally 0 -> log "psci exited successfully"
        _ -> notifyErr "PSCI exited abnormally"
      )
    editorElt <- toMaybe <$> querySelector ".psci-input atom-text-editor" (elementToParentNode pane.element)
    case editorElt of
      Just editorElt' -> (do
        editor <- toMaybe <$> getModel editorElt'
        maybe (pure unit) (\ed -> do
          addCommand' atom.commands editorElt' "core:confirm" (\_ -> do
            text <- getText ed
            setText ed ""
            sendText pane proc text
          )
        ) editor
      )
      Nothing -> pure unit
    log "Started PSCI"
  ) psciProcess

  where liftEff'' :: forall a. Eff (PsciEff eff) a -> Aff (PsciEff eff) a
        liftEff'' = liftEff

activate :: forall eff. Eff (PsciEff eff) Unit
activate = do
  atom <- getAtom
  paneRef <- newRef (Nothing :: Maybe PscPane)
  psciRef <- newRef (Nothing :: Maybe ChildProcess)

  let close = do
        pane <- liftEff $ readRef paneRef
        psci <- liftEff $ readRef psciRef
        case pane, psci of
          Just e, Just p -> do
            closePsci e p
            writeRef psciRef Nothing
            writeRef paneRef Nothing
            atomPane <- paneForItem atom.workspace e
            case atomPane of
              Just pp -> void $ destroyItem pp e
              Nothing -> pure unit
          _, _ -> pure unit

  let runCmd c = do
        pane <- liftEff $ readRef paneRef
        psci <- liftEff $ readRef psciRef
        case pane, psci of
          Just e, Just p -> liftEff $ c e p
          _, _ -> do
            startRepl paneRef psciRef
            runCmd c

  let open = launchAffAndRaise $ startRepl paneRef psciRef
  let reset = do
        ed <- readRef paneRef
        close
        maybe (pure unit) clearText ed
        open

  let cmd isEditor name action = addCommand atom.commands "atom-workspace" ("ide-purescript:psci-"<>name) (const action)
        where scope = if isEditor then "atom-text-editor" else "atom-workspace"
  cmd false "open" $ reset
  cmd true  "send-line" $ launchAffAndRaise $ runCmd sendLine
  cmd true  "send-selection" $ launchAffAndRaise $ runCmd sendSelection
  cmd true  "reset" $ reset