Don't autosave explore notebooks until modified

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Notebook.Component
  ( notebookComponent
  , initialState
  , QueryP()
  , StateP()
  , module Notebook.Component.Query
  , module Notebook.Component.State
  ) where

import Prelude

import Control.Bind ((=<<), join)
import Control.Monad (when, unless)
import Control.Monad.Aff.Console (log)
import Control.UI.Browser (newTab, locationObject)

import Data.Argonaut (Json())
import Data.Array (catMaybes, nub)
import Data.BrowserFeatures (BrowserFeatures())
import Data.Either (Either(..), either)
import Data.Foldable (traverse_, for_)
import Data.Traversable (for)
import Data.Functor (($>))
import Data.Functor.Aff (liftAff)
import Data.Functor.Coproduct (Coproduct(), coproduct, left, right)
import Data.Functor.Eff (liftEff)
import Data.Lens (LensP(), view, (.~), (%~), (?~))
import Data.List as List
import Data.Maybe (Maybe(..), maybe, isNothing)
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as Pathy
import Data.Set as S
import Data.String as Str
import Data.These (These(..))
import Data.Time (Milliseconds(..))
import Data.Traversable (for)
import Data.Tuple (Tuple(..), fst, snd)

import DOM.HTML.Location as Location

import Halogen
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Halogen.Themes.Bootstrap3 as B

import Render.Common (glyph, fadeWhen)
import Render.CssClasses as CSS

import Model.AccessType (AccessType(..), isEditable)
import Model.Common (mkNotebookHash, mkNotebookCellHash, mkNotebookURL)
import Model.Notebook.Action as NA
import Model.Resource as R

import Notebook.Cell.CellId (CellId(), cellIdToString)
import Notebook.Cell.CellType (CellType(..), AceMode(..), cellName, cellGlyph, autorun)
import Notebook.Cell.Common.EvalQuery (CellEvalQuery(..))
import Notebook.Cell.Component (CellQueryP(), CellQuery(..), InnerCellQuery(), CellStateP(), AnyCellQuery(..))
import Notebook.Cell.JTable.Component as JTC
import Notebook.Cell.Markdown.Component as MDC
import Notebook.Cell.API.Component as APIC
import Notebook.Cell.Port (Port())
import Notebook.CellSlot (CellSlot(..))
import Notebook.Common (Slam(), forceRerender')
import Notebook.Component.Query
import Notebook.Component.State
import Notebook.FileInput.Component as Fi
import Notebook.Model as Model

import Ace.Halogen.Component as Ace

import Quasar.Aff as Quasar
import Utils.Debounced (debouncedEventSource)
import Utils.Path (DirPath())

type QueryP = Coproduct Query (ChildF CellSlot CellQueryP)
type StateP =
  InstalledState State CellStateP Query CellQueryP Slam CellSlot

type NotebookHTML = ParentHTML CellStateP Query CellQueryP Slam CellSlot
type NotebookDSL =
  ParentDSL State CellStateP Query CellQueryP Slam CellSlot

initialState :: BrowserFeatures -> StateP
initialState fs = installedState $ initialNotebook fs

notebookComponent :: Component StateP QueryP Slam
notebookComponent = parentComponent' render eval peek

render :: State -> NotebookHTML
render state =
  case state.stateMode of
    Loading ->
      H.div
        [ P.classes [ B.alert, B.alertInfo ] ]
        [ H.h1
          [ P.class_ B.textCenter ]
          [ H.text "Loading..." ]
          -- We need to render the cells but have them invisible during loading
          -- otherwise the various nested components won't initialise correctly
        , renderCells false
        ]
    Ready ->
      -- WARNING: Very strange things happen when this is not in a div; see SD-1326.
      H.div_
        [ renderCells true
        ]
    Error err ->
      H.div
        [ P.classes [ B.alert, B.alertDanger ] ]
        [ H.h1
            [ P.class_ B.textCenter ]
            [ H.text err ]
        ]

  where

  renderCells visible =
    -- The key here helps out virtual-dom: the entire subtree will be moved
    -- when the loading message disappears, rather than being reconstructed in
    -- the parent element
    H.div ([P.key "notebook-cells"] <> if visible then [] else [P.class_ CSS.invisible])
      $ List.fromList (map renderCell state.cells)
     <> if isEditable state.accessType then [newCellMenu state] else []

  renderCell cellDef =
    H.div
      ([ P.key ("cell" <> cellIdToString cellDef.id)
       ] <> maybe [] (viewingStyle cellDef) state.viewingCell)
      [ H.Slot cellDef.ctor ]

  viewingStyle cellDef cid =
    if cellDef.id == cid || cellIsLinkedCellOf { childId: cellDef.id, parentId: cid } state
      then []
      else [ P.class_ CSS.invisible ]

newCellMenu :: State -> NotebookHTML
newCellMenu state =
  H.ul
    [ P.class_ CSS.newCellMenu ]
    [ H.li_
        [ H.button
            [ P.classes [B.btnLg, B.btnLink]
            , E.onClick (E.input_ ToggleAddCellMenu)
            , P.title "Insert new cell"
            ]
            [ glyph
                if state.isAddingCell
                then B.glyphiconMinus
                else B.glyphiconPlus
            ]
        ]
    , insertMenuItem (Ace SQLMode)
    , insertMenuItem (Ace MarkdownMode)
    , insertMenuItem Explore
    , insertMenuItem Search
    , insertMenuItem API
    ]
  where
  insertMenuItem :: CellType -> NotebookHTML
  insertMenuItem cellType =
    H.li_
      [ H.button
          [ P.title (cellName cellType)
          , E.onClick $ E.input_ (AddCell cellType)
          , P.classes (fadeWhen $ not (state.isAddingCell))
          ]
          [ glyph (cellGlyph cellType) ]
      ]

eval :: Natural Query NotebookDSL
eval (AddCell cellType next) = modify (addCell cellType Nothing) $> next
eval (RunActiveCell next) =
  (maybe (pure unit) runCell =<< gets (_.activeCellId)) $> next
eval (ToggleAddCellMenu next) = modify (_isAddingCell %~ not) $> next
eval (LoadNotebook fs dir next) = do
  modify (_stateMode .~ Loading)
  json <- liftAff $ Quasar.load $ dir </> Pathy.file "index"
  case Model.decode =<< json of
    Left err -> do
      liftAff $ log err
      modify (_stateMode .~ Error "There was a problem decoding the saved notebook")
      pure next
    Right model ->
      let peeledPath = Pathy.peel dir
          path = fst <$> peeledPath
          name = either Just (const Nothing) <<< snd =<< peeledPath
      in case fromModel fs path name model of
        Tuple cells st -> do
          set st
          forceRerender'
          ranCells <- catMaybes <$> for cells \cell -> do
            query (CellSlot cell.cellId) $ left $ action $ LoadCell cell
            pure if cell.hasRun then Just cell.cellId else Nothing
          -- We only need to run the root node in each subgraph, as doing so
          -- will result in all child nodes being run also as the outputs
          -- propagate down each subgraph.
          traverse_ runCell $ nub $ flip findRoot st <$> ranCells
          modify (_stateMode .~ Ready)
          pure next
eval (ExploreFile fs res next) = do
  modify
    $ (_path .~ Pathy.parentDir res)
    <<< (_browserFeatures .~ fs)
    <<< (addCell Explore Nothing)
  forceRerender'
  query (CellSlot zero) $ right
    $ ChildF unit $ right $ ExploreQuery
    $ right $ ChildF unit
    $ action $ Fi.SelectFile $ R.File res
  forceRerender'
  runCell zero
  pure next
eval (Publish next) =
  gets notebookPath >>= \mpath -> do
    for_ mpath $ liftEff <<< newTab <<< flip mkNotebookURL (NA.Load ReadOnly)
    pure next
eval (Reset fs dir next) = do
  let nb = initialNotebook fs
      peeledPath = Pathy.peel dir
      path = fst <$> peeledPath
      name = maybe nb.name This (either Just (const Nothing) <<< snd =<< peeledPath)
  set $ nb { path = path, name = name }
  pure next
eval (SetName name next) = modify (_name .~ That name) $> next
eval (SetAccessType aType next) = modify (_accessType .~ aType) $> next
eval (GetNotebookPath k) = k <$> gets notebookPath
eval (SetViewingCell mbcid next) = modify (_viewingCell .~ mbcid) $> next
eval (SaveNotebook next) = saveNotebook unit $> next
eval (RunPendingCells next) = runPendingCells unit $> next
eval (GetGlobalVarMap k) = k <$> gets _.globalVarMap
eval (SetGlobalVarMap m next) = modify (_globalVarMap .~ m) $> next
eval (FindCellParent cid k) = k <$> gets (findParent cid)
eval (GetCellType cid k) = k <$> gets (getCellType cid)

peek :: forall a. ChildF CellSlot CellQueryP a -> NotebookDSL Unit
peek (ChildF (CellSlot cellId) q) =
  coproduct (peekCell cellId) (peekCellInner cellId) q

-- | Peek on the cell component to observe actions from the cell control
-- | buttons.
peekCell :: forall a. CellId -> CellQuery a -> NotebookDSL Unit
peekCell cellId q = case q of
  RunCell _ -> runCell cellId
  RefreshCell _ -> runCell <<< findRoot cellId =<< get
  TrashCell _ -> do
    descendants <- gets (findDescendants cellId)
    modify $ removeCells (S.insert cellId descendants)
    triggerSave unit
  CreateChildCell cellType _ -> do
    Tuple st newCellId <- gets $ addCell' cellType (Just cellId)
    set st
    forceRerender'
    input <- map join $ query (CellSlot cellId) $ left (request GetOutput)
    case input of
      Just input' -> do
        path <- gets notebookPath
        let setupInfo = { notebookPath: path, inputPort: input' }
        void $ query (CellSlot newCellId)
             $ right $ ChildF unit $ left $ action (SetupCell setupInfo)
      Nothing -> pure unit
    when (autorun cellType) $ runCell newCellId
  ShareCell _ -> pure unit
  _ -> pure unit

-- | Peek on the inner cell components to observe `NotifyRunCell`, which is
-- | raised by actions within a cell that should cause the cell to run.
peekCellInner :: forall a. CellId -> ChildF Unit InnerCellQuery a -> NotebookDSL Unit
peekCellInner cellId (ChildF _ q) =
  coproduct (peekEvalCell cellId) (peekAnyCell cellId) q

peekEvalCell :: forall a. CellId -> CellEvalQuery a -> NotebookDSL Unit
peekEvalCell cellId (NotifyRunCell _) = runCell cellId
peekEvalCell _ _ = pure unit

peekAnyCell :: forall a. CellId -> AnyCellQuery a -> NotebookDSL Unit
peekAnyCell cellId q = do
  when (queryShouldRun q) $ runCell cellId
  when (queryShouldSave q) $ triggerSave unit
  pure unit

queryShouldRun :: forall a. AnyCellQuery a -> Boolean
queryShouldRun (VizQuery q) = true
queryShouldRun (JTableQuery q) = JTC.queryShouldRun q
queryShouldRun (MarkdownQuery q) = MDC.queryShouldRun q
queryShouldRun (APIQuery q) = APIC.queryShouldRun q
queryShouldRun _ = false

queryShouldSave  :: forall a. AnyCellQuery a -> Boolean
queryShouldSave (AceQuery q) =
  coproduct evalQueryShouldSave aceQueryShouldSave q
queryShouldSave _ = true

evalQueryShouldSave :: forall a. CellEvalQuery a -> Boolean
evalQueryShouldSave _ = true

aceQueryShouldSave
  :: forall p a. ChildF p Ace.AceQuery a -> Boolean
aceQueryShouldSave (ChildF _ q) =
  case q of
    Ace.TextChanged _ -> true
    _ -> false

-- | Runs all cell that are present in the set of pending cells.
runPendingCells :: Unit -> NotebookDSL Unit
runPendingCells _ = do
  cells <- gets _.pendingCells
  modify (_pendingCells .~ S.empty)
  traverse_ runCell' cells
  where
  runCell' :: CellId -> NotebookDSL Unit
  runCell' cellId = do
    mbParentId <- gets (findParent cellId)
    case mbParentId of
      -- if there's no parent there's no input port value to pass through
      Nothing -> updateCell Nothing cellId
      Just parentId -> do
        value <- map join $ query (CellSlot parentId) $ left (request GetOutput)
        case value of
          -- if there's a parent but no output the parent cell hasn't been evaluated
          -- yet, so we can't run this cell either
          Nothing -> pure unit
          -- if there's a parent and an output, pass it on as this cell's input
          Just p -> updateCell (Just p) cellId
    triggerSave unit

-- | Enqueues the cell with the specified ID in the set of cells that are
-- | pending to run and enqueues a debounced query to trigger the cells to
-- | actually run.
runCell :: CellId -> NotebookDSL Unit
runCell cellId = do
  modify (addPendingCell cellId)
  _runTrigger `fireDebouncedQuery` RunPendingCells

-- | Updates the evaluated value for a cell by running it with the specified
-- | input and then runs any cells that depend on the cell's output with the
-- | new result.
updateCell :: Maybe Port -> CellId -> NotebookDSL Unit
updateCell inputPort cellId = do
  path <- gets notebookPath
  globalVarMap <- gets _.globalVarMap
  let input = { notebookPath: path, inputPort, cellId, globalVarMap }
  result <- join <$> (query (CellSlot cellId) $ left $ request (UpdateCell input))
  maybe (pure unit) (runCellDescendants cellId) result
  where
  runCellDescendants :: CellId -> Port -> NotebookDSL Unit
  runCellDescendants parentId value = do
    children <- gets (findChildren parentId)
    traverse_ (updateCell (Just value)) children

-- | Triggers the query for autosave. This does not immediate perform the save
-- | action, but instead enqueues a debounced query to trigger the actual save.
triggerSave :: Unit -> NotebookDSL Unit
triggerSave _ = _saveTrigger `fireDebouncedQuery` SaveNotebook

-- | Fires the specified debouced query trigger with the passed query. This
-- | function also handles constructing the initial trigger if it has not yet
-- | been created.
fireDebouncedQuery
  :: LensP State (Maybe DebounceTrigger)
  -> Action Query
  -> NotebookDSL Unit
fireDebouncedQuery lens act = do
  t <- gets (view lens) >>= \mbt -> case mbt of
    Just t' -> pure t'
    Nothing -> do
      t' <- debouncedEventSource liftEff subscribe' (Milliseconds 500.0)
      modify (lens ?~ t')
      pure t'
  liftH $ liftH $ t $ action $ act

-- | Saves the notebook as JSON, using the current values present in the state.
saveNotebook :: Unit -> NotebookDSL Unit
saveNotebook _ = get >>= \st ->
  unless (isUnsaved st && isExploreNotebook st) do
    for_ st.path \path -> do
      cells <- catMaybes <$> for (List.fromList st.cells) \cell ->
        query (CellSlot cell.id) $ left $ request (SaveCell cell.id cell.ty)

      let json = Model.encode { cells, dependencies: st.dependencies }

      savedName <- case st.name of
        This name -> save path name json
        That name -> do
          newName <- getNewName' path name
          save path newName json
        Both oldName newName -> do
          save path oldName json
          if newName == nameFromDirName oldName
            then pure oldName
            else rename path oldName newName

      modify (_name .~ This savedName)

      -- We need to get the modified version of the notebook state.
      mpath <- gets notebookPath
      case mpath of
        Nothing -> pure unit
        Just path' -> do
          let
            notebookHash =
              case st.viewingCell of
                Nothing -> mkNotebookHash path' (NA.Load st.accessType) st.globalVarMap
                Just cid -> mkNotebookCellHash path' cid st.accessType st.globalVarMap
          liftEff $ locationObject >>= Location.setHash notebookHash

  where

  isUnsaved :: State -> Boolean
  isUnsaved = isNothing <<< notebookPath

  isExploreNotebook :: State -> Boolean
  isExploreNotebook { cells } =
    List.toUnfoldable (map _.ty cells) == [Explore, JTable]

  -- Finds a new name for a notebook in the specified parent directory, using
  -- a name value as a basis to start with.
  getNewName' :: DirPath -> String -> NotebookDSL Pathy.DirName
  getNewName' dir name =
    let baseName = name ++ "." ++ Config.notebookExtension
    in liftAff $ Pathy.DirName <$> Quasar.getNewName dir baseName

  -- Saves a notebook and returns the name it was saved as.
  save :: DirPath -> Pathy.DirName -> Json -> NotebookDSL Pathy.DirName
  save dir name json = do
    let notebookPath = dir </> Pathy.dir' name </> Pathy.file "index"
    liftAff $ Quasar.save notebookPath json
    pure name

  -- Renames a notebook and returns the new name it was changed to.
  rename :: DirPath -> Pathy.DirName -> String -> NotebookDSL Pathy.DirName
  rename dir oldName newName = do
    newName' <- getNewName' dir newName
    let oldPath = dir </> Pathy.dir' oldName
        newPath = dir </> Pathy.dir' newName'
    liftAff $ Quasar.move (R.Directory oldPath) (Right newPath)
    pure newName'

-- | Takes a `DirName` for a saved notebook and returns the name part without
-- | the `.slam` extension.
nameFromDirName :: Pathy.DirName -> String
nameFromDirName dirName =
  let name = Pathy.runDirName dirName
  in Str.take (Str.length name - Str.length Config.notebookExtension - 1) name

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Notebook.Component
  ( notebookComponent
  , initialState
  , QueryP()
  , StateP()
  , module Notebook.Component.Query
  , module Notebook.Component.State
  ) where

import Prelude

import Control.Bind ((=<<), join)
import Control.Monad (when)
import Control.Monad.Aff.Console (log)
import Control.UI.Browser (newTab, locationObject)

import Data.Argonaut (Json())
import Data.Array (catMaybes, nub)
import Data.BrowserFeatures (BrowserFeatures())
import Data.Either (Either(..), either)
import Data.Foldable (traverse_, for_)
import Data.Traversable (for)
import Data.Functor (($>))
import Data.Functor.Aff (liftAff)
import Data.Functor.Coproduct (Coproduct(), coproduct, left, right)
import Data.Functor.Eff (liftEff)
import Data.Lens (LensP(), view, (.~), (%~), (?~))
import Data.List as List
import Data.Maybe (Maybe(..), maybe)
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as Pathy
import Data.Set as S
import Data.String as Str
import Data.These (These(..))
import Data.Time (Milliseconds(..))
import Data.Traversable (for)
import Data.Tuple (Tuple(..), fst, snd)

import DOM.HTML.Location as Location

import Halogen
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Halogen.Themes.Bootstrap3 as B

import Render.Common (glyph, fadeWhen)
import Render.CssClasses as CSS

import Model.AccessType (AccessType(..), isEditable)
import Model.Common (mkNotebookHash, mkNotebookCellHash, mkNotebookURL)
import Model.Notebook.Action as NA
import Model.Resource as R

import Notebook.Cell.CellId (CellId(), cellIdToString)
import Notebook.Cell.CellType (CellType(..), AceMode(..), cellName, cellGlyph, autorun)
import Notebook.Cell.Common.EvalQuery (CellEvalQuery(..))
import Notebook.Cell.Component (CellQueryP(), CellQuery(..), InnerCellQuery(), CellStateP(), AnyCellQuery(..))
import Notebook.Cell.JTable.Component as JTC
import Notebook.Cell.Markdown.Component as MDC
import Notebook.Cell.API.Component as APIC
import Notebook.Cell.Port (Port())
import Notebook.CellSlot (CellSlot(..))
import Notebook.Common (Slam(), forceRerender')
import Notebook.Component.Query
import Notebook.Component.State
import Notebook.FileInput.Component as Fi
import Notebook.Model as Model

import Ace.Halogen.Component as Ace

import Quasar.Aff as Quasar
import Utils.Debounced (debouncedEventSource)
import Utils.Path (DirPath())

type QueryP = Coproduct Query (ChildF CellSlot CellQueryP)
type StateP =
  InstalledState State CellStateP Query CellQueryP Slam CellSlot

type NotebookHTML = ParentHTML CellStateP Query CellQueryP Slam CellSlot
type NotebookDSL =
  ParentDSL State CellStateP Query CellQueryP Slam CellSlot

initialState :: BrowserFeatures -> StateP
initialState fs = installedState $ initialNotebook fs

notebookComponent :: Component StateP QueryP Slam
notebookComponent = parentComponent' render eval peek

render :: State -> NotebookHTML
render state =
  case state.stateMode of
    Loading ->
      H.div
        [ P.classes [ B.alert, B.alertInfo ] ]
        [ H.h1
          [ P.class_ B.textCenter ]
          [ H.text "Loading..." ]
          -- We need to render the cells but have them invisible during loading
          -- otherwise the various nested components won't initialise correctly
        , renderCells false
        ]
    Ready ->
      -- WARNING: Very strange things happen when this is not in a div; see SD-1326.
      H.div_
        [ renderCells true
        ]
    Error err ->
      H.div
        [ P.classes [ B.alert, B.alertDanger ] ]
        [ H.h1
            [ P.class_ B.textCenter ]
            [ H.text err ]
        ]

  where

  renderCells visible =
    -- The key here helps out virtual-dom: the entire subtree will be moved
    -- when the loading message disappears, rather than being reconstructed in
    -- the parent element
    H.div ([P.key "notebook-cells"] <> if visible then [] else [P.class_ CSS.invisible])
      $ List.fromList (map renderCell state.cells)
     <> if isEditable state.accessType then [newCellMenu state] else []

  renderCell cellDef =
    H.div
      ([ P.key ("cell" <> cellIdToString cellDef.id)
       ] <> maybe [] (viewingStyle cellDef) state.viewingCell)
      [ H.Slot cellDef.ctor ]

  viewingStyle cellDef cid =
    if cellDef.id == cid || cellIsLinkedCellOf { childId: cellDef.id, parentId: cid } state
      then []
      else [ P.class_ CSS.invisible ]

newCellMenu :: State -> NotebookHTML
newCellMenu state =
  H.ul
    [ P.class_ CSS.newCellMenu ]
    [ H.li_
        [ H.button
            [ P.classes [B.btnLg, B.btnLink]
            , E.onClick (E.input_ ToggleAddCellMenu)
            , P.title "Insert new cell"
            ]
            [ glyph
                if state.isAddingCell
                then B.glyphiconMinus
                else B.glyphiconPlus
            ]
        ]
    , insertMenuItem (Ace SQLMode)
    , insertMenuItem (Ace MarkdownMode)
    , insertMenuItem Explore
    , insertMenuItem Search
    , insertMenuItem API
    ]
  where
  insertMenuItem :: CellType -> NotebookHTML
  insertMenuItem cellType =
    H.li_
      [ H.button
          [ P.title (cellName cellType)
          , E.onClick $ E.input_ (AddCell cellType)
          , P.classes (fadeWhen $ not (state.isAddingCell))
          ]
          [ glyph (cellGlyph cellType) ]
      ]

eval :: Natural Query NotebookDSL
eval (AddCell cellType next) = modify (addCell cellType Nothing) $> next
eval (RunActiveCell next) =
  (maybe (pure unit) runCell =<< gets (_.activeCellId)) $> next
eval (ToggleAddCellMenu next) = modify (_isAddingCell %~ not) $> next
eval (LoadNotebook fs dir next) = do
  modify (_stateMode .~ Loading)
  json <- liftAff $ Quasar.load $ dir </> Pathy.file "index"
  case Model.decode =<< json of
    Left err -> do
      liftAff $ log err
      modify (_stateMode .~ Error "There was a problem decoding the saved notebook")
      pure next
    Right model ->
      let peeledPath = Pathy.peel dir
          path = fst <$> peeledPath
          name = either Just (const Nothing) <<< snd =<< peeledPath
      in case fromModel fs path name model of
        Tuple cells st -> do
          set st
          forceRerender'
          ranCells <- catMaybes <$> for cells \cell -> do
            query (CellSlot cell.cellId) $ left $ action $ LoadCell cell
            pure if cell.hasRun then Just cell.cellId else Nothing
          -- We only need to run the root node in each subgraph, as doing so
          -- will result in all child nodes being run also as the outputs
          -- propagate down each subgraph.
          traverse_ runCell $ nub $ flip findRoot st <$> ranCells
          modify (_stateMode .~ Ready)
          pure next
eval (ExploreFile fs res next) = do
  modify
    $ (_path .~ Pathy.parentDir res)
    <<< (_browserFeatures .~ fs)
    <<< (addCell Explore Nothing)
  forceRerender'
  query (CellSlot zero) $ right
    $ ChildF unit $ right $ ExploreQuery
    $ right $ ChildF unit
    $ action $ Fi.SelectFile $ R.File res
  forceRerender'
  runCell zero
  pure next
eval (Publish next) =
  gets notebookPath >>= \mpath -> do
    for_ mpath $ liftEff <<< newTab <<< flip mkNotebookURL (NA.Load ReadOnly)
    pure next
eval (Reset fs dir next) = do
  let nb = initialNotebook fs
      peeledPath = Pathy.peel dir
      path = fst <$> peeledPath
      name = maybe nb.name This (either Just (const Nothing) <<< snd =<< peeledPath)
  set $ nb { path = path, name = name }
  pure next
eval (SetName name next) = modify (_name .~ That name) $> next
eval (SetAccessType aType next) = modify (_accessType .~ aType) $> next
eval (GetNotebookPath k) = k <$> gets notebookPath
eval (SetViewingCell mbcid next) = modify (_viewingCell .~ mbcid) $> next
eval (SaveNotebook next) = saveNotebook unit $> next
eval (RunPendingCells next) = runPendingCells unit $> next
eval (GetGlobalVarMap k) = k <$> gets _.globalVarMap
eval (SetGlobalVarMap m next) = modify (_globalVarMap .~ m) $> next
eval (FindCellParent cid k) = k <$> gets (findParent cid)
eval (GetCellType cid k) = k <$> gets (getCellType cid)

peek :: forall a. ChildF CellSlot CellQueryP a -> NotebookDSL Unit
peek (ChildF (CellSlot cellId) q) =
  coproduct (peekCell cellId) (peekCellInner cellId) q

-- | Peek on the cell component to observe actions from the cell control
-- | buttons.
peekCell :: forall a. CellId -> CellQuery a -> NotebookDSL Unit
peekCell cellId q = case q of
  RunCell _ -> runCell cellId
  RefreshCell _ -> runCell <<< findRoot cellId =<< get
  TrashCell _ -> do
    descendants <- gets (findDescendants cellId)
    modify $ removeCells (S.insert cellId descendants)
    triggerSave unit
  CreateChildCell cellType _ -> do
    Tuple st newCellId <- gets $ addCell' cellType (Just cellId)
    set st
    forceRerender'
    input <- map join $ query (CellSlot cellId) $ left (request GetOutput)
    case input of
      Just input' -> do
        path <- gets notebookPath
        let setupInfo = { notebookPath: path, inputPort: input' }
        void $ query (CellSlot newCellId)
             $ right $ ChildF unit $ left $ action (SetupCell setupInfo)
      Nothing -> pure unit
    when (autorun cellType) $ runCell newCellId
  ShareCell _ -> pure unit
  _ -> pure unit

-- | Peek on the inner cell components to observe `NotifyRunCell`, which is
-- | raised by actions within a cell that should cause the cell to run.
peekCellInner :: forall a. CellId -> ChildF Unit InnerCellQuery a -> NotebookDSL Unit
peekCellInner cellId (ChildF _ q) =
  coproduct (peekEvalCell cellId) (peekAnyCell cellId) q

peekEvalCell :: forall a. CellId -> CellEvalQuery a -> NotebookDSL Unit
peekEvalCell cellId (NotifyRunCell _) = runCell cellId
peekEvalCell _ _ = pure unit

peekAnyCell :: forall a. CellId -> AnyCellQuery a -> NotebookDSL Unit
peekAnyCell cellId q = do
  when (queryShouldRun q) $ runCell cellId
  when (queryShouldSave q) $ triggerSave unit
  pure unit

queryShouldRun :: forall a. AnyCellQuery a -> Boolean
queryShouldRun (VizQuery q) = true
queryShouldRun (JTableQuery q) = JTC.queryShouldRun q
queryShouldRun (MarkdownQuery q) = MDC.queryShouldRun q
queryShouldRun (APIQuery q) = APIC.queryShouldRun q
queryShouldRun _ = false

queryShouldSave  :: forall a. AnyCellQuery a -> Boolean
queryShouldSave (AceQuery q) =
  coproduct evalQueryShouldSave aceQueryShouldSave q
queryShouldSave _ = true

evalQueryShouldSave :: forall a. CellEvalQuery a -> Boolean
evalQueryShouldSave _ = true

aceQueryShouldSave
  :: forall p a. ChildF p Ace.AceQuery a -> Boolean
aceQueryShouldSave (ChildF _ q) =
  case q of
    Ace.TextChanged _ -> true
    _ -> false

-- | Runs all cell that are present in the set of pending cells.
runPendingCells :: Unit -> NotebookDSL Unit
runPendingCells _ = do
  cells <- gets _.pendingCells
  modify (_pendingCells .~ S.empty)
  traverse_ runCell' cells
  where
  runCell' :: CellId -> NotebookDSL Unit
  runCell' cellId = do
    mbParentId <- gets (findParent cellId)
    case mbParentId of
      -- if there's no parent there's no input port value to pass through
      Nothing -> updateCell Nothing cellId
      Just parentId -> do
        value <- map join $ query (CellSlot parentId) $ left (request GetOutput)
        case value of
          -- if there's a parent but no output the parent cell hasn't been evaluated
          -- yet, so we can't run this cell either
          Nothing -> pure unit
          -- if there's a parent and an output, pass it on as this cell's input
          Just p -> updateCell (Just p) cellId
    triggerSave unit

-- | Enqueues the cell with the specified ID in the set of cells that are
-- | pending to run and enqueues a debounced query to trigger the cells to
-- | actually run.
runCell :: CellId -> NotebookDSL Unit
runCell cellId = do
  modify (addPendingCell cellId)
  _runTrigger `fireDebouncedQuery` RunPendingCells

-- | Updates the evaluated value for a cell by running it with the specified
-- | input and then runs any cells that depend on the cell's output with the
-- | new result.
updateCell :: Maybe Port -> CellId -> NotebookDSL Unit
updateCell inputPort cellId = do
  path <- gets notebookPath
  globalVarMap <- gets _.globalVarMap
  let input = { notebookPath: path, inputPort, cellId, globalVarMap }
  result <- join <$> (query (CellSlot cellId) $ left $ request (UpdateCell input))
  maybe (pure unit) (runCellDescendants cellId) result
  where
  runCellDescendants :: CellId -> Port -> NotebookDSL Unit
  runCellDescendants parentId value = do
    children <- gets (findChildren parentId)
    traverse_ (updateCell (Just value)) children

-- | Triggers the query for autosave. This does not immediate perform the save
-- | action, but instead enqueues a debounced query to trigger the actual save.
triggerSave :: Unit -> NotebookDSL Unit
triggerSave _ = _saveTrigger `fireDebouncedQuery` SaveNotebook

-- | Fires the specified debouced query trigger with the passed query. This
-- | function also handles constructing the initial trigger if it has not yet
-- | been created.
fireDebouncedQuery
  :: LensP State (Maybe DebounceTrigger)
  -> Action Query
  -> NotebookDSL Unit
fireDebouncedQuery lens act = do
  t <- gets (view lens) >>= \mbt -> case mbt of
    Just t' -> pure t'
    Nothing -> do
      t' <- debouncedEventSource liftEff subscribe' (Milliseconds 500.0)
      modify (lens ?~ t')
      pure t'
  liftH $ liftH $ t $ action $ act

-- | Saves the notebook as JSON, using the current values present in the state.
saveNotebook :: Unit -> NotebookDSL Unit
saveNotebook _ = do
  st <- get
  for_ st.path \path -> do
    cells <- catMaybes <$> for (List.fromList st.cells) \cell ->
      query (CellSlot cell.id) $ left $ request (SaveCell cell.id cell.ty)

    let json = Model.encode { cells, dependencies: st.dependencies }

    savedName <- case st.name of
      This name -> save path name json
      That name -> do
        newName <- getNewName' path name
        save path newName json
      Both oldName newName -> do
        save path oldName json
        if newName == nameFromDirName oldName
          then pure oldName
          else rename path oldName newName

    modify (_name .~ This savedName)

    -- We need to get the modified version of the notebook state. TODO: is
    -- there a cleaner way to do this?
    mpath <- gets notebookPath
    case mpath of
      Nothing -> pure unit
      Just path' -> do
        let
          notebookHash =
            case st.viewingCell of
              Nothing -> mkNotebookHash path' (NA.Load st.accessType) st.globalVarMap
              Just cid -> mkNotebookCellHash path' cid st.accessType st.globalVarMap
        liftEff $ locationObject >>= Location.setHash notebookHash

  where

  -- Finds a new name for a notebook in the specified parent directory, using
  -- a name value as a basis to start with.
  getNewName' :: DirPath -> String -> NotebookDSL Pathy.DirName
  getNewName' dir name =
    let baseName = name ++ "." ++ Config.notebookExtension
    in liftAff $ Pathy.DirName <$> Quasar.getNewName dir baseName

  -- Saves a notebook and returns the name it was saved as.
  save :: DirPath -> Pathy.DirName -> Json -> NotebookDSL Pathy.DirName
  save dir name json = do
    let notebookPath = dir </> Pathy.dir' name </> Pathy.file "index"
    liftAff $ Quasar.save notebookPath json
    pure name

  -- Renames a notebook and returns the new name it was changed to.
  rename :: DirPath -> Pathy.DirName -> String -> NotebookDSL Pathy.DirName
  rename dir oldName newName = do
    newName' <- getNewName' dir newName
    let oldPath = dir </> Pathy.dir' oldName
        newPath = dir </> Pathy.dir' newName'
    liftAff $ Quasar.move (R.Directory oldPath) (Right newPath)
    pure newName'

-- | Takes a `DirName` for a saved notebook and returns the name part without
-- | the `.slam` extension.
nameFromDirName :: Pathy.DirName -> String
nameFromDirName dirName =
  let name = Pathy.runDirName dirName
  in Str.take (Str.length name - Str.length Config.notebookExtension - 1) name


Adding attempt and apathize to exports

Adding attempt and apathize to exports

module Effect.Promise
  ( Promise
  , promise
  , then_
  , then'
  , resolve
  , catch
  , reject
  , race
  , attempt
  , apathize
  , all
  , delay
  , runPromise
  , module Exports
  ) where

import Prelude

import Control.Monad.Error.Class (class MonadError, class MonadThrow)
import Data.Array as Array
import Data.Either (Either(..))
import Data.Foldable (class Foldable)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn2, runFn3)
import Data.Time.Duration (Milliseconds)
import Data.Unfoldable (class Unfoldable)
import Effect (Effect)
import Effect.Class (class MonadEffect)
import Effect.Exception (Error, throwException)
import Effect.Promise.Unsafe (class Deferred) as Exports
import Effect.Promise.Unsafe (class Deferred, undefer)

-- | A JavaScript promise.
foreign import data Promise :: Type -> Type

foreign import promiseImpl :: forall a b.
  (Fn2 (a -> Effect Unit) (b -> Effect Unit) (Effect Unit)) -> Promise a

-- | Create a promise by supplying a function which takes a success callback and
-- | error callback as arguments, returning an `Effect`.
promise :: forall a. Deferred => ((a -> Effect Unit) -> (Error -> Effect Unit) -> Effect Unit) -> Promise a
promise k = promiseImpl (mkFn2 k)

foreign import thenImpl
  :: forall a b c. Fn3
    (Promise a)
    (a -> Promise b)
    (c -> Promise b)
    (Promise b)

generalThen
  :: forall a b c. (a -> Promise b)
  -> (c -> Promise b)
  -> Promise a
  -> Promise b
generalThen succ err p = runFn3 thenImpl p succ err

-- | Given a promise and a function which uses that promise's resolved value,
-- | create a new promise that resolves to the function's output.
then' :: forall a b. Deferred => (a -> Promise b) -> Promise a -> Promise b
then' = flip generalThen reject

-- | Useful for when you need to transform an error and a resolved value into
-- | the same type.
then_
  :: forall a b. Deferred
  => (a -> Promise b)
  -> (Error -> Promise b)
  -> Promise a
  -> Promise b
then_ = generalThen

foreign import resolveImpl
  :: forall a. a -> Promise a

-- | Create a promise from a value.
resolve :: forall a. a -> Promise a
resolve = resolveImpl

foreign import catchImpl
  :: forall a b c. Fn2
  (Promise a)
  (c -> Promise b)
  (Promise b)

catchAnything
  :: forall a c. Promise a
  -> (c -> Promise a)
  -> Promise a
catchAnything = runFn2 catchImpl

-- | Deals with any errors that may be thrown by the given promise.
catch :: forall a. Deferred => Promise a -> (Error -> Promise a) -> Promise a
catch = catchAnything

foreign import rejectImpl :: forall b c. c -> Promise b

-- | Throw an error into a promise.
reject :: forall b. Deferred => Error -> Promise b
reject = rejectImpl

-- | Same as `try`.
attempt :: forall a. Deferred => Promise a -> Promise (Either Error a)
attempt p = p # then_ (\ a -> resolve (Right a)) (\ err -> resolve (Left err))

apathize :: forall a. Deferred => Promise a -> Promise Unit
apathize p = const unit <$> attempt p

foreign import allImpl :: forall a. Array (Promise a) -> Promise (Array a)

-- | Run all promises in the given `Foldable`, returning a new promise which either
-- | resolves to a collection of all the given promises' results, or rejects with
-- | the first promise to reject.
all :: forall f g a. Deferred => Foldable f => Unfoldable g => f (Promise a) -> Promise (g a)
all = map Array.toUnfoldable <<< allImpl <<< Array.fromFoldable

foreign import raceImpl :: forall a. Array (Promise a) -> Promise a

-- | Note that while promise semantics say that `race xs` resolves to the first
-- | `x` in `xs` to resolve, `race xs` won't terminate until each promise is
-- | settled.
-- | In addition, if `Array.fromFoldable xs` is `[]`, `race xs` will never settle.
race :: forall f a. Deferred => Foldable f => f (Promise a) -> Promise a
race = raceImpl <<< Array.fromFoldable

foreign import delayImpl :: forall a. Fn2 a Milliseconds (Promise a)

-- | Cause a delay in execution, then resolve with the given value.
delay :: forall a. Deferred => Milliseconds -> a -> Promise a
delay = flip (runFn2 delayImpl)

foreign import promiseToEffectImpl
  :: forall a b c. Fn3
  (Promise a)
  (a -> Effect b)
  (c -> Effect b)
  (Effect Unit)

-- | Consume a promise. Note that this is the only standard way to safely
-- | discharge the `Deferred` constraints you are likely to have.
runPromise
  :: forall a b. (a -> Effect b)
  -> (Error -> Effect b)
  -> (Deferred => Promise a)
  -> Effect Unit
runPromise onSucc onErr p = runFn3 promiseToEffectImpl (undefer p) onSucc onErr

yoloPromise :: forall a. (Deferred => Promise a) -> Effect Unit
yoloPromise dp = runPromise (const (pure unit)) throwException dp

instance functorPromise :: Deferred => Functor Promise where
  map :: forall a b. Deferred => (a -> b) -> Promise a -> Promise b
  map f p = p # then' \ a -> resolve (f a)

instance applyPromise :: Deferred => Apply Promise where
  apply :: forall a b. Deferred => Promise (a -> b) -> Promise a -> Promise b
  apply pf pa = pf # then' \ f -> pa # then' \ a -> resolve (f a)

instance applicativePromise :: Deferred => Applicative Promise where
  pure = resolve

instance bindPromise :: Deferred => Bind Promise where
  bind :: forall a b. Deferred => Promise a -> (a -> Promise b) -> Promise b
  bind = flip then'

instance monadPromise :: Deferred => Monad Promise

instance monadThrowPromise :: Deferred => MonadThrow Error Promise where
  throwError :: forall a. Deferred => Error -> Promise a
  throwError = reject

instance monadErrorPromise :: Deferred => MonadError Error Promise where
  catchError :: forall a. Deferred => Promise a -> (Error -> Promise a) -> Promise a
  catchError = catch

instance semigroupPromise :: (Deferred, Semigroup a) => Semigroup (Promise a) where
  append :: forall a. Deferred => Semigroup a => Promise a -> Promise a -> Promise a
  append a b = append <$> a <*> b

instance monoidPromise :: (Deferred, Monoid a) => Monoid (Promise a) where
  mempty :: forall a. Deferred => Monoid a => Promise a
  mempty = resolve mempty

foreign import liftEffectImpl :: forall a. Effect a -> Promise a
instance monadEffectPromise :: Deferred => MonadEffect Promise where
  liftEffect :: forall a. Deferred => Effect a -> Promise a
  liftEffect = liftEffectImpl

module Effect.Promise
  ( Promise
  , promise
  , then_
  , then'
  , resolve
  , catch
  , reject
  , race
  , all
  , delay
  , runPromise
  , module Exports
  ) where

import Prelude

import Control.Monad.Error.Class (class MonadError, class MonadThrow)
import Data.Array as Array
import Data.Either (Either(..))
import Data.Foldable (class Foldable)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn2, runFn3)
import Data.Time.Duration (Milliseconds)
import Data.Unfoldable (class Unfoldable)
import Effect (Effect)
import Effect.Class (class MonadEffect)
import Effect.Exception (Error, throwException)
import Effect.Promise.Unsafe (class Deferred) as Exports
import Effect.Promise.Unsafe (class Deferred, undefer)

-- | A JavaScript promise.
foreign import data Promise :: Type -> Type

foreign import promiseImpl :: forall a b.
  (Fn2 (a -> Effect Unit) (b -> Effect Unit) (Effect Unit)) -> Promise a

-- | Create a promise by supplying a function which takes a success callback and
-- | error callback as arguments, returning an `Effect`.
promise :: forall a. Deferred => ((a -> Effect Unit) -> (Error -> Effect Unit) -> Effect Unit) -> Promise a
promise k = promiseImpl (mkFn2 k)

foreign import thenImpl
  :: forall a b c. Fn3
    (Promise a)
    (a -> Promise b)
    (c -> Promise b)
    (Promise b)

generalThen
  :: forall a b c. (a -> Promise b)
  -> (c -> Promise b)
  -> Promise a
  -> Promise b
generalThen succ err p = runFn3 thenImpl p succ err

-- | Given a promise and a function which uses that promise's resolved value,
-- | create a new promise that resolves to the function's output.
then' :: forall a b. Deferred => (a -> Promise b) -> Promise a -> Promise b
then' = flip generalThen reject

-- | Useful for when you need to transform an error and a resolved value into
-- | the same type.
then_
  :: forall a b. Deferred
  => (a -> Promise b)
  -> (Error -> Promise b)
  -> Promise a
  -> Promise b
then_ = generalThen

foreign import resolveImpl
  :: forall a. a -> Promise a

-- | Create a promise from a value.
resolve :: forall a. a -> Promise a
resolve = resolveImpl

foreign import catchImpl
  :: forall a b c. Fn2
  (Promise a)
  (c -> Promise b)
  (Promise b)

catchAnything
  :: forall a c. Promise a
  -> (c -> Promise a)
  -> Promise a
catchAnything = runFn2 catchImpl

-- | Deals with any errors that may be thrown by the given promise.
catch :: forall a. Deferred => Promise a -> (Error -> Promise a) -> Promise a
catch = catchAnything

foreign import rejectImpl :: forall b c. c -> Promise b

-- | Throw an error into a promise.
reject :: forall b. Deferred => Error -> Promise b
reject = rejectImpl

-- | Same as `try`.
attempt :: forall a. Deferred => Promise a -> Promise (Either Error a)
attempt p = p # then_ (\ a -> resolve (Right a)) (\ err -> resolve (Left err))

apathize :: forall a. Deferred => Promise a -> Promise Unit
apathize p = const unit <$> attempt p

foreign import allImpl :: forall a. Array (Promise a) -> Promise (Array a)

-- | Run all promises in the given `Foldable`, returning a new promise which either
-- | resolves to a collection of all the given promises' results, or rejects with
-- | the first promise to reject.
all :: forall f g a. Deferred => Foldable f => Unfoldable g => f (Promise a) -> Promise (g a)
all = map Array.toUnfoldable <<< allImpl <<< Array.fromFoldable

foreign import raceImpl :: forall a. Array (Promise a) -> Promise a

-- | Note that while promise semantics say that `race xs` resolves to the first
-- | `x` in `xs` to resolve, `race xs` won't terminate until each promise is
-- | settled.
-- | In addition, if `Array.fromFoldable xs` is `[]`, `race xs` will never settle.
race :: forall f a. Deferred => Foldable f => f (Promise a) -> Promise a
race = raceImpl <<< Array.fromFoldable

foreign import delayImpl :: forall a. Fn2 a Milliseconds (Promise a)

-- | Cause a delay in execution, then resolve with the given value.
delay :: forall a. Deferred => Milliseconds -> a -> Promise a
delay = flip (runFn2 delayImpl)

foreign import promiseToEffectImpl
  :: forall a b c. Fn3
  (Promise a)
  (a -> Effect b)
  (c -> Effect b)
  (Effect Unit)

-- | Consume a promise. Note that this is the only standard way to safely
-- | discharge the `Deferred` constraints you are likely to have.
runPromise
  :: forall a b. (a -> Effect b)
  -> (Error -> Effect b)
  -> (Deferred => Promise a)
  -> Effect Unit
runPromise onSucc onErr p = runFn3 promiseToEffectImpl (undefer p) onSucc onErr

yoloPromise :: forall a. (Deferred => Promise a) -> Effect Unit
yoloPromise dp = runPromise (const (pure unit)) throwException dp

instance functorPromise :: Deferred => Functor Promise where
  map :: forall a b. Deferred => (a -> b) -> Promise a -> Promise b
  map f p = p # then' \ a -> resolve (f a)

instance applyPromise :: Deferred => Apply Promise where
  apply :: forall a b. Deferred => Promise (a -> b) -> Promise a -> Promise b
  apply pf pa = pf # then' \ f -> pa # then' \ a -> resolve (f a)

instance applicativePromise :: Deferred => Applicative Promise where
  pure = resolve

instance bindPromise :: Deferred => Bind Promise where
  bind :: forall a b. Deferred => Promise a -> (a -> Promise b) -> Promise b
  bind = flip then'

instance monadPromise :: Deferred => Monad Promise

instance monadThrowPromise :: Deferred => MonadThrow Error Promise where
  throwError :: forall a. Deferred => Error -> Promise a
  throwError = reject

instance monadErrorPromise :: Deferred => MonadError Error Promise where
  catchError :: forall a. Deferred => Promise a -> (Error -> Promise a) -> Promise a
  catchError = catch

instance semigroupPromise :: (Deferred, Semigroup a) => Semigroup (Promise a) where
  append :: forall a. Deferred => Semigroup a => Promise a -> Promise a -> Promise a
  append a b = append <$> a <*> b

instance monoidPromise :: (Deferred, Monoid a) => Monoid (Promise a) where
  mempty :: forall a. Deferred => Monoid a => Promise a
  mempty = resolve mempty

foreign import liftEffectImpl :: forall a. Effect a -> Promise a
instance monadEffectPromise :: Deferred => MonadEffect Promise where
  liftEffect :: forall a. Deferred => Effect a -> Promise a
  liftEffect = liftEffectImpl


Export `minimum` and `maximum` from Semigroup.Foldable

module Data.Semigroup.Foldable
  ( class Foldable1
  , foldMap1
  , fold1
  , traverse1_
  , for1_
  , sequence1_
  , foldMap1Default
  , fold1Default
  , intercalate
  , intercalateMap
  , maximum
  , minimum
  ) where

import Prelude

import Data.Foldable (class Foldable)
import Data.Monoid.Dual (Dual(..))
import Data.Monoid.Multiplicative (Multiplicative(..))
import Data.Newtype (ala)
import Data.Ord.Max (Max(..))
import Data.Ord.Min (Min(..))

-- | `Foldable1` represents data structures with a minimum of one element that can be _folded_.
-- |
-- | - `fold1` folds a structure using a `Semigroup` instance
-- | - `foldMap1` folds a structure by accumulating values in a `Semigroup`
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `fold1Default`
-- | - `foldMap1Default`
-- |
-- | Note: some combinations of the default implementations are unsafe to
-- | use together - causing a non-terminating mutually recursive cycle.
-- | These combinations are documented per function.
class Foldable t <= Foldable1 t where
  foldMap1 :: forall a m. Semigroup m => (a -> m) -> t a -> m
  fold1 :: forall m. Semigroup m => t m -> m

-- | A default implementation of `fold1` using `foldMap1`.
fold1Default :: forall t m. Foldable1 t => Semigroup m => t m -> m
fold1Default = foldMap1 identity

-- | A default implementation of `foldMap1` using `fold1`.
foldMap1Default :: forall t m a. Foldable1 t => Functor t => Semigroup m => (a -> m) -> t a -> m
foldMap1Default f = (map f) >>> fold1

instance foldableDual :: Foldable1 Dual where
  foldMap1 f (Dual x) = f x
  fold1 = fold1Default

instance foldableMultiplicative :: Foldable1 Multiplicative where
  foldMap1 f (Multiplicative x) = f x
  fold1 = fold1Default

newtype Act f a = Act (f a)

getAct :: forall f a. Act f a -> f a
getAct (Act f) = f

instance semigroupAct :: Apply f => Semigroup (Act f a) where
  append (Act a) (Act b) = Act (a *> b)

-- | Traverse a data structure, performing some effects encoded by an
-- | `Apply` instance at each value, ignoring the final result.
traverse1_ :: forall t f a b. Foldable1 t => Apply f => (a -> f b) -> t a -> f Unit
traverse1_ f t = unit <$ getAct (foldMap1 (Act <<< f) t)

-- | A version of `traverse1_` with its arguments flipped.
-- |
-- | This can be useful when running an action written using do notation
-- | for every element in a data structure:
for1_ :: forall t f a b. Foldable1 t => Apply f => t a -> (a -> f b) -> f Unit
for1_ = flip traverse1_

-- | Perform all of the effects in some data structure in the order
-- | given by the `Foldable1` instance, ignoring the final result.
sequence1_ :: forall t f a. Foldable1 t => Apply f => t (f a) -> f Unit
sequence1_ = traverse1_ identity

maximum :: forall f a. Ord a => Foldable1 f => f a -> a
maximum = ala Max foldMap1

minimum :: forall f a. Ord a => Foldable1 f => f a -> a
minimum = ala Min foldMap1

-- | Internal. Used by intercalation functions.
newtype JoinWith a = JoinWith (a -> a)

joinee :: forall a. JoinWith a -> a -> a
joinee (JoinWith x) = x

instance semigroupJoinWith :: Semigroup a => Semigroup (JoinWith a) where
  append (JoinWith a) (JoinWith b) = JoinWith $ \j -> a j <> j <> b j

-- | Fold a data structure using a `Semigroup` instance,
-- | combining adjacent elements using the specified separator.
intercalate :: forall f m. Foldable1 f => Semigroup m => m -> f m -> m
intercalate = flip intercalateMap identity

-- | Fold a data structure, accumulating values in some `Semigroup`,
-- | combining adjacent elements using the specified separator.
intercalateMap
  :: forall f m a
   . Foldable1 f
  => Semigroup m
  => m -> (a -> m) -> f a -> m
intercalateMap j f foldable =
  joinee (foldMap1 (JoinWith <<< const <<< f) foldable) j

module Data.Semigroup.Foldable
  ( class Foldable1
  , foldMap1
  , fold1
  , traverse1_
  , for1_
  , sequence1_
  , foldMap1Default
  , fold1Default
  , intercalate
  , intercalateMap
  ) where

import Prelude

import Data.Foldable (class Foldable)
import Data.Monoid.Dual (Dual(..))
import Data.Monoid.Multiplicative (Multiplicative(..))
import Data.Newtype (ala)
import Data.Ord.Max (Max(..))
import Data.Ord.Min (Min(..))

-- | `Foldable1` represents data structures with a minimum of one element that can be _folded_.
-- |
-- | - `fold1` folds a structure using a `Semigroup` instance
-- | - `foldMap1` folds a structure by accumulating values in a `Semigroup`
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `fold1Default`
-- | - `foldMap1Default`
-- |
-- | Note: some combinations of the default implementations are unsafe to
-- | use together - causing a non-terminating mutually recursive cycle.
-- | These combinations are documented per function.
class Foldable t <= Foldable1 t where
  foldMap1 :: forall a m. Semigroup m => (a -> m) -> t a -> m
  fold1 :: forall m. Semigroup m => t m -> m

-- | A default implementation of `fold1` using `foldMap1`.
fold1Default :: forall t m. Foldable1 t => Semigroup m => t m -> m
fold1Default = foldMap1 identity

-- | A default implementation of `foldMap1` using `fold1`.
foldMap1Default :: forall t m a. Foldable1 t => Functor t => Semigroup m => (a -> m) -> t a -> m
foldMap1Default f = (map f) >>> fold1

instance foldableDual :: Foldable1 Dual where
  foldMap1 f (Dual x) = f x
  fold1 = fold1Default

instance foldableMultiplicative :: Foldable1 Multiplicative where
  foldMap1 f (Multiplicative x) = f x
  fold1 = fold1Default

newtype Act f a = Act (f a)

getAct :: forall f a. Act f a -> f a
getAct (Act f) = f

instance semigroupAct :: Apply f => Semigroup (Act f a) where
  append (Act a) (Act b) = Act (a *> b)

-- | Traverse a data structure, performing some effects encoded by an
-- | `Apply` instance at each value, ignoring the final result.
traverse1_ :: forall t f a b. Foldable1 t => Apply f => (a -> f b) -> t a -> f Unit
traverse1_ f t = unit <$ getAct (foldMap1 (Act <<< f) t)

-- | A version of `traverse1_` with its arguments flipped.
-- |
-- | This can be useful when running an action written using do notation
-- | for every element in a data structure:
for1_ :: forall t f a b. Foldable1 t => Apply f => t a -> (a -> f b) -> f Unit
for1_ = flip traverse1_

-- | Perform all of the effects in some data structure in the order
-- | given by the `Foldable1` instance, ignoring the final result.
sequence1_ :: forall t f a. Foldable1 t => Apply f => t (f a) -> f Unit
sequence1_ = traverse1_ identity

maximum :: forall f a. Ord a => Foldable1 f => f a -> a
maximum = ala Max foldMap1

minimum :: forall f a. Ord a => Foldable1 f => f a -> a
minimum = ala Min foldMap1

-- | Internal. Used by intercalation functions.
newtype JoinWith a = JoinWith (a -> a)

joinee :: forall a. JoinWith a -> a -> a
joinee (JoinWith x) = x

instance semigroupJoinWith :: Semigroup a => Semigroup (JoinWith a) where
  append (JoinWith a) (JoinWith b) = JoinWith $ \j -> a j <> j <> b j

-- | Fold a data structure using a `Semigroup` instance,
-- | combining adjacent elements using the specified separator.
intercalate :: forall f m. Foldable1 f => Semigroup m => m -> f m -> m
intercalate = flip intercalateMap identity

-- | Fold a data structure, accumulating values in some `Semigroup`,
-- | combining adjacent elements using the specified separator.
intercalateMap
  :: forall f m a
   . Foldable1 f
  => Semigroup m
  => m -> (a -> m) -> f a -> m
intercalateMap j f foldable =
  joinee (foldMap1 (JoinWith <<< const <<< f) foldable) j


redefined TypeTree

redefined TypeTree


Added show instance to the anomaly model

-- | Find and fix anomalies in Time Series
module Data.TimeSeries.Anomaly (Model, train, removeOutliers) where

import Prelude
import Data.Array as A
import Data.Maybe (fromMaybe)
import Data.Tuple (Tuple(..))
import Learn.Unsupervised.OutlierDetection as OD
import LinearAlgebra.Matrix as M

import Data.TimeSeries as TS

data Model = Model OD.Model

instance showModel :: Show Model where
  show (Model ds)= show ds

-- | Train Anomaly detection model
train :: TS.Series Number -> Model
train xs = Model $ OD.train ys
  where
    vs = TS.values xs
    ys = fromMaybe (M.zeros 1 1) $ M.fromArray (A.length vs) 1 vs

-- | Remove outliers from the series
-- | If given point has high probability of being outlier then
-- | its value is replaced by value of the previous point.
removeOutliers :: Model -> TS.Series Number -> TS.Series Number
removeOutliers model xs = TS.series (TS.index xs) (A.zipWith f vs ys2)
  where
    vs = TS.values xs
    v = fromMaybe 0.0 $ A.head vs
    ys = predictOutliers model xs
    ys2 = A.zip ys (A.cons v vs)
    f :: Number -> Tuple Number Number -> Number
    f x (Tuple p y) = if p < 0.01 then y else x

-- Find outliers in time series.
-- Return probabilites of being outlier
predictOutliers :: Model -> TS.Series Number -> Array Number
predictOutliers (Model model) xs = OD.predict model vs'
  where
    vs = TS.values xs
    vs' = fromMaybe (M.zeros 1 1) $ M.fromArray (A.length vs) 1 vs

-- | Find and fix anomalies in Time Series
module Data.TimeSeries.Anomaly (Model, train, removeOutliers) where

import Prelude
import Data.Array as A
import Data.Maybe (fromMaybe)
import Data.Tuple (Tuple(..))
import Learn.Unsupervised.OutlierDetection as OD
import LinearAlgebra.Matrix as M

import Data.TimeSeries as TS

data Model = Model OD.Model

-- | Train Anomaly detection model
train :: TS.Series Number -> Model
train xs = Model $ OD.train ys
  where
    vs = TS.values xs
    ys = fromMaybe (M.zeros 1 1) $ M.fromArray (A.length vs) 1 vs

-- | Remove outliers from the series
-- | If given point has high probability of being outlier then
-- | its value is replaced by value of the previous point.
removeOutliers :: Model -> TS.Series Number -> TS.Series Number
removeOutliers model xs = TS.series (TS.index xs) (A.zipWith f vs ys2)
  where
    vs = TS.values xs
    v = fromMaybe 0.0 $ A.head vs
    ys = predictOutliers model xs
    ys2 = A.zip ys (A.cons v vs)
    f :: Number -> Tuple Number Number -> Number
    f x (Tuple p y) = if p < 0.01 then y else x

-- Find outliers in time series.
-- Return probabilites of being outlier
predictOutliers :: Model -> TS.Series Number -> Array Number
predictOutliers (Model model) xs = OD.predict model vs'
  where
    vs = TS.values xs
    vs' = fromMaybe (M.zeros 1 1) $ M.fromArray (A.length vs) 1 vs