Use `parTraverse` in `queryAll`

Use `parTraverse` in `queryAll`

-- | Functions and types used to describe the `HalogenF` algebra used in a
-- | component's `eval` and `peek` functions.
module Halogen.Query
  ( Action
  , action
  , Request
  , request
  , query
  , query'
  , queryAll
  , queryAll'
  , module Exports
  , module Halogen.Query.EventSource
  , module Halogen.Query.HalogenM
  ) where

import Prelude

import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))

import Halogen.Component.ChildPath (ChildPath, injSlot, prjSlot, injQuery, cpI)
import Halogen.Query.EventSource (EventSource, eventSource, eventSource_)
import Halogen.Query.HalogenM (HalogenM(..), HalogenF(..), getSlots, checkSlot, mkQuery)

import Control.Parallel (parTraverse)
import Control.Monad.Aff.Class (liftAff) as Exports
import Control.Monad.Eff.Class (liftEff) as Exports
import Control.Monad.State.Class (get, gets, modify, put) as Exports
import Control.Monad.Trans.Class (lift) as Exports
import Halogen.Query.HalogenM (subscribe, raise) as Exports

-- | Type synonym for an "action" - An action only causes effects and has no
-- | result value.
-- |
-- | In a query algebra, an action is any constructor that carries the algebra's
-- | type variable as a value. For example:
-- |
-- | ``` purescript
-- | data Query a
-- |   = SomeAction a
-- |   | SomeOtherAction String a
-- |   | NotAnAction (Boolean -> a)
-- | ```
-- |
-- | Both `SomeAction` and `SomeOtherAction` have `a` as a value so they are
-- | considered actions, whereas `NotAnAction` has `a` as the result of a
-- | function so is considered to be a "request" ([see below](#Request)).
type Action f = Unit -> f Unit

-- | Takes a data constructor of query algebra `f` and creates an action.
-- |
-- | For example:
-- |
-- | ```purescript
-- | data Query a = Tick a
-- |
-- | sendTick :: forall eff. Driver Query eff -> Aff (HalogenEffects eff) Unit
-- | sendTick driver = driver (action Tick)
-- | ```
action :: forall f. Action f -> f Unit
action act = act unit

-- | Type synonym for an "request" - a request can cause effects as well as
-- | fetching some information from a component.
-- |
-- | In a query algebra, an action is any constructor that carries the algebra's
-- | type variable as the return value of a function. For example:
-- |
-- | ``` purescript
-- | data Query a = SomeRequest (Boolean -> a)
-- | ```
type Request f a = forall i. (a -> i) -> f i

-- | Takes a data constructor of query algebra `f` and creates a request.
-- |
-- | For example:
-- |
-- | ```purescript
-- | data Query a = GetTickCount (Int -> a)
-- |
-- | getTickCount :: forall eff. Driver Query eff -> Aff (HalogenEffects eff) Int
-- | getTickCount driver = driver (request GetTickCount)
-- | ```
request :: forall f a. Request f a -> f a
request req = req id

-- | Sends a query to a child of a component at the specified slot.
query
  :: forall s f g p o m a
   . (Applicative m, Eq p)
  => p
  -> g a
  -> HalogenM s f g p o m (Maybe a)
query p q = checkSlot p >>= if _ then Just <$> mkQuery p q else pure Nothing

-- | Sends a query to a child of a component at the specified slot, using a
-- | `ChildPath` to discriminate the type of child component to query.
query'
  :: forall s f g g' m p p' o a
   . (Applicative m, Eq p')
  => ChildPath g g' p p'
  -> p
  -> g a
  -> HalogenM s f g' p' o m (Maybe a)
query' path p q = query (injSlot path p) (injQuery path q)

-- | Sends a query to all children of a component.
queryAll
  :: forall s f g p o m a
   . (Applicative m, Ord p)
  => g a
  -> HalogenM s f g p o m (M.Map p a)
queryAll = queryAll' cpI

-- | Sends a query to all children of a specific type within a component, using
-- | a `ChildPath` to discriminate the type of child component to query.
queryAll'
  :: forall s f g g' p p' o m a
   . (Applicative m, Ord p, Eq p')
  => ChildPath g g' p p'
  -> g a
  -> HalogenM s f g' p' o m (M.Map p a)
queryAll' path q = do
  slots <- L.mapMaybe (prjSlot path) <$> getSlots
  M.fromFoldable <$>
    parTraverse
      (\p -> map (Tuple p) (mkQuery (injSlot path p) (injQuery path q)))
      slots

-- | Functions and types used to describe the `HalogenF` algebra used in a
-- | component's `eval` and `peek` functions.
module Halogen.Query
  ( Action
  , action
  , Request
  , request
  , query
  , query'
  , queryAll
  , queryAll'
  , module Exports
  , module Halogen.Query.EventSource
  , module Halogen.Query.HalogenM
  ) where

import Prelude

import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))

import Halogen.Component.ChildPath (ChildPath, injSlot, prjSlot, injQuery, cpI)
import Halogen.Query.EventSource (EventSource, eventSource, eventSource_)
import Halogen.Query.HalogenM (HalogenM(..), HalogenF(..), getSlots, checkSlot, mkQuery)

import Control.Monad.Aff.Class (liftAff) as Exports
import Control.Monad.Eff.Class (liftEff) as Exports
import Control.Monad.State.Class (get, gets, modify, put) as Exports
import Control.Monad.Trans.Class (lift) as Exports
import Halogen.Query.HalogenM (subscribe, raise) as Exports

-- | Type synonym for an "action" - An action only causes effects and has no
-- | result value.
-- |
-- | In a query algebra, an action is any constructor that carries the algebra's
-- | type variable as a value. For example:
-- |
-- | ``` purescript
-- | data Query a
-- |   = SomeAction a
-- |   | SomeOtherAction String a
-- |   | NotAnAction (Boolean -> a)
-- | ```
-- |
-- | Both `SomeAction` and `SomeOtherAction` have `a` as a value so they are
-- | considered actions, whereas `NotAnAction` has `a` as the result of a
-- | function so is considered to be a "request" ([see below](#Request)).
type Action f = Unit -> f Unit

-- | Takes a data constructor of query algebra `f` and creates an action.
-- |
-- | For example:
-- |
-- | ```purescript
-- | data Query a = Tick a
-- |
-- | sendTick :: forall eff. Driver Query eff -> Aff (HalogenEffects eff) Unit
-- | sendTick driver = driver (action Tick)
-- | ```
action :: forall f. Action f -> f Unit
action act = act unit

-- | Type synonym for an "request" - a request can cause effects as well as
-- | fetching some information from a component.
-- |
-- | In a query algebra, an action is any constructor that carries the algebra's
-- | type variable as the return value of a function. For example:
-- |
-- | ``` purescript
-- | data Query a = SomeRequest (Boolean -> a)
-- | ```
type Request f a = forall i. (a -> i) -> f i

-- | Takes a data constructor of query algebra `f` and creates a request.
-- |
-- | For example:
-- |
-- | ```purescript
-- | data Query a = GetTickCount (Int -> a)
-- |
-- | getTickCount :: forall eff. Driver Query eff -> Aff (HalogenEffects eff) Int
-- | getTickCount driver = driver (request GetTickCount)
-- | ```
request :: forall f a. Request f a -> f a
request req = req id

-- | Sends a query to a child of a component at the specified slot.
query
  :: forall s f g p o m a
   . (Applicative m, Eq p)
  => p
  -> g a
  -> HalogenM s f g p o m (Maybe a)
query p q = checkSlot p >>= if _ then Just <$> mkQuery p q else pure Nothing

-- | Sends a query to a child of a component at the specified slot, using a
-- | `ChildPath` to discriminate the type of child component to query.
query'
  :: forall s f g g' m p p' o a
   . (Applicative m, Eq p')
  => ChildPath g g' p p'
  -> p
  -> g a
  -> HalogenM s f g' p' o m (Maybe a)
query' path p q = query (injSlot path p) (injQuery path q)

-- | Sends a query to all children of a component.
queryAll
  :: forall s f g p o m a
   . (Applicative m, Ord p)
  => g a
  -> HalogenM s f g p o m (M.Map p a)
queryAll = queryAll' cpI

-- | Sends a query to all children of a specific type within a component, using
-- | a `ChildPath` to discriminate the type of child component to query.
queryAll'
  :: forall s f g g' p p' o m a
   . (Applicative m, Ord p, Eq p')
  => ChildPath g g' p p'
  -> g a
  -> HalogenM s f g' p' o m (M.Map p a)
queryAll' path q = do
  slots <- L.mapMaybe (prjSlot path) <$> getSlots
  M.fromFoldable <$>
    traverse
      (\p -> map (Tuple p) (mkQuery (injSlot path p) (injQuery path q)))
      slots


Ensure default values are sent in queries if needed

module Input.Notebook
  ( CellResultContent(..)
  , Input(..)
  , updateState
  , cellContent
  ) where

import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Bind (join)
import Data.Array (filter, modifyAt, (!!), elemIndex)
import Data.Date (Date(), toEpochMilliseconds)
import Data.Either (Either(..), isRight, either)
import Data.Foldable (intercalate, foldl)
import Data.Function (on)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.String (indexOf)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Model.Notebook
import Model.Resource (Resource())
import Model.Notebook.Cell
import Model.Notebook.Cell.FileInput (_showFiles)
import Model.Notebook.Domain (_cells, addCell, insertCell, _dependencies, Notebook(), trash, ancestors)
import Model.Notebook.Port (Port(..), VarMapValue(), _PortResource, _VarMap)
import Optic.Core (LensP(), (..), (<>~), (%~), (+~), (.~), (^.), (?~), lens)
import Optic.Fold ((^?))
import Optic.Setter (mapped)
import Text.Markdown.SlamDown (SlamDown(..), Block(..), Expr(..), Inline(..), FormField(..), TextBoxType(..), everything)
import Text.Markdown.SlamDown.Html (FormFieldValue(..), SlamDownEvent(..), SlamDownState(..), applySlamDownEvent, initSlamDownState)
import Text.Markdown.SlamDown.Parser (parseMd)
import Utils (elem)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.String.Regex as Rx
import qualified Data.StrMap as SM
import qualified ECharts.Options as EC
import qualified Model.Notebook.Cell.JTableContent as JTC
import qualified Model.Notebook.Cell.Markdown as Ma
import qualified Text.Parsing.StringParser as SP
import qualified Text.Parsing.StringParser.Combinators as SP
import qualified Text.Parsing.StringParser.String as SP
import Model.Path (FilePath(), AnyPath())

data CellResultContent
  = AceContent String
  | JTableContent JTC.JTableContent
  | MarkdownContent

data Input
  = WithState (State -> State)
  | Dropdown Number
  | CloseDropdowns
  | AddCell CellContent
  | TrashCell CellId

  | RequestCellContent Cell
  | ReceiveCellContent Cell
  | ViewCellContent Cell
  | RefreshCell Cell

  | StartRunCell CellId Date
  | StopCell CellId
  | CellResult CellId Date (Either (NEL.NonEmpty FailureMessage) CellResultContent)

  | UpdateCell CellId (Cell -> Cell)
  | CellSlamDownEvent CellId SlamDownEvent
  | InsertCell Cell CellContent
  | SetEChartsOption String EC.Option
  | ResizeECharts String

  | UpdatedOutput CellId Port
  | ForceSave

updateState :: State -> Input -> State

updateState state (WithState f) =
  f state

updateState state (UpdateCell cellId fn) =
  state # _notebook.._cells..mapped %~ onCell cellId fn

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # _dropdowns %~
  (modifyAt i _{visible = visSet}) <<< (_{visible = false} <$>)

updateState state CloseDropdowns =
  state # (_dropdowns %~ (_{visible = false} <$>))
       .. (_notebook .. _cells .. mapped %~ _content .. _FileInput .. _showFiles .~ false)

updateState state (AddCell content) =
  state # _notebook %~ (fst <<< addCell content)

updateState state (InsertCell parent content) =
  state # _notebook %~ (fst <<< insertCell parent content)

updateState state (TrashCell cellId) =
  state # _notebook.._cells %~ filter (not <<< depends (state ^._notebook) cellId)
        # _notebook.._cells %~ filter (not <<< isCell cellId)
        # _notebook.._dependencies %~ trash cellId

updateState state (CellResult cellId date content) =
  let finished d = RunFinished $ on (-) toEpochMilliseconds date d

      fromState (RunningSince d) = cellContent content <<< setRunState (finished d)
      fromState a = setRunState a -- In bad state or cancelled. Leave content.

      f cell = fromState (cell ^. _runState) cell # (_hasRun .~ true)

  in state # _notebook.._cells..mapped %~ onCell cellId f

updateState state (ReceiveCellContent cell) =
  state # _notebook.._cells..mapped %~ onCell (cell ^. _cellId) (const $ setSlamDownStatus cell)

updateState state (StartRunCell cellId date) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState (RunningSince date) <<< (_expandedStatus .~ false))

updateState state (StopCell cellId) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState RunInitial)

updateState state (CellSlamDownEvent cellId event) =
  state # _notebook.._cells..mapped %~ onCell cellId (slamDownOutput <<< runSlamDownEvent event)
        # _notebook.._cells %~ syncParents
        # _requesting <>~ [cellId]

updateState state (UpdatedOutput cid newInput) =
  let depIds = fst <$>
             filter (\x -> snd x == cid) (M.toList (state ^._notebook.._dependencies))
      changed cell = if elemIndex (cell ^._cellId) depIds == -1
                     then cell
                     else cell # _input .~ newInput
  in state # _notebook.._cells..mapped %~ changed

updateState state (RefreshCell cell) =
  let requesting = state ^. _requesting
      cid = cell ^. _cellId
  in if elem cid requesting
     then state
     else state # _refreshing <>~ [cell ^. _cellId]

updateState state i = state

slamDownStateMap :: LensP SlamDownState (SM.StrMap FormFieldValue)
slamDownStateMap = lens (\(SlamDownState m) -> m) (const SlamDownState)

-- TODO: We need a much better solution to this.
syncParents :: [Cell] -> [Cell]
syncParents cells = updateCell <$> cells
  where updateCell cell = fromMaybe cell $ fromParent cell
        fromParent cell = do
          pid <- cell ^. _parent
          parent <- M.lookup pid m
          return (cell # _input .~ (parent ^. _output))
        m = M.fromList $ pair <$> cells
        pair cell = Tuple (cell ^. _cellId) cell

slamDownOutput :: Cell -> Cell
slamDownOutput cell =
  cell # _output .. _VarMap  %~ modifyVarMap
  where
    modifyVarMap m = foldl (\m (Tuple key val) -> SM.insert key val m) m tplLst
    tplLst = maybe [] SM.toList ((fromFormValue <$>) <$> state)
    fromFormValue (SingleValue PlainText s) = quoteString s
    fromFormValue (SingleValue Date s) = "DATE '" ++ s ++ "'"
    fromFormValue (SingleValue Time s) = "TIME '" ++ s ++ "'"
    fromFormValue (SingleValue DateTime s) = "TIMESTAMP '" ++ processTimestamp s ++ "'"
    fromFormValue (MultipleValues s) = "[" <> intercalate ", " (quoteString <$> S.toList s) <> "]" -- TODO: is this anything like we want for multi-values?
    state :: Maybe (SM.StrMap FormFieldValue)
    state = cell ^? _content.._Markdown..Ma._state..slamDownStateMap
    processTimestamp s = s ++ ":00Z"
    quoteString s | isSQLNum s = s
                  | otherwise = "'" ++ Rx.replace rxQuot "''" s ++ "'"
    rxQuot = Rx.regex "'" Rx.noFlags { global = true }
    rxT = Rx.regex "T" Rx.noFlags
    isSQLNum s = isRight $ flip SP.runParser s $ do
      SP.many1 SP.anyDigit
      SP.optional $ SP.string "." *> SP.many SP.anyDigit
      SP.optional $ (SP.string "e" <|> SP.string "E")
                 *> (SP.string "-" <|> SP.string "+")
                 *> SP.many SP.anyDigit

slamDownFields :: SlamDown -> [Tuple String FormField]
slamDownFields = everything (const []) go
  where
  go (FormField s _ ff) = [Tuple s ff]
  go _ = []

-- TODO: Change Port to SlamDownState and use slamDownOutput instead.
initialSlamDownOutput :: [Tuple String FormField] -> Port
initialSlamDownOutput sf = VarMap sm
  where sm :: SM.StrMap VarMapValue
        sm = fromMaybe SM.empty <<< traverse toValue $ SM.fromList sf
        toValue :: FormField -> Maybe VarMapValue
        toValue (TextBox _ (Just (Literal s))) = Just s
        toValue (RadioButtons (Literal s) _) = Just s
        toValue (DropDown _ (Just (Literal s))) = Just s
        toValue (CheckBoxes _ (Literal ss)) = Nothing
        toValue _ = Nothing

setSlamDownStatus :: Cell -> Cell
setSlamDownStatus cell =
  let input' = cell ^? _content.._Markdown..Ma._input
      message = ("Exported fields: " <>) <<< intercalate ", " <<< (fst <$>)
      initial md =
        let fields = slamDownFields md
            updateState (SlamDownState s) | SM.isEmpty s = initSlamDownState md
                                          | otherwise = SlamDownState s
        in cell # _message .~ message fields
                # _output .~ initialSlamDownOutput fields
                # _content .. _Markdown .. Ma._state %~ updateState
  in maybe cell (initial <<< parseMd) input'

runSlamDownEvent :: SlamDownEvent -> Cell -> Cell
runSlamDownEvent event cell =
  cell # _content.._Markdown..Ma._state %~ flip applySlamDownEvent event

cellContent :: Either (NEL.NonEmpty FailureMessage) CellResultContent -> Cell -> Cell
cellContent = either (setFailures <<< NEL.toArray) success
  where
  success :: CellResultContent -> Cell -> Cell
  success (AceContent content) =
    setFailures [ ]
    <<< (_content.._AceContent .~ content)
  success (JTableContent content) =
    setFailures [ ]
    <<< (_content.._JTableContent .~ content)
  success MarkdownContent = setFailures [ ]

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

setFailures :: [FailureMessage] -> Cell -> Cell
setFailures fs (Cell o) = Cell $ o { failures = fs }

setRunState :: RunState -> Cell -> Cell
setRunState = modifyRunState <<< const

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'

depends :: Notebook -> CellId -> Cell -> Boolean
depends notebook cellId cell =
  elemIndex cellId (ancestors (cell ^._cellId) (notebook ^._dependencies)) /= -1

module Input.Notebook
  ( CellResultContent(..)
  , Input(..)
  , updateState
  , cellContent
  ) where

import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Bind (join)
import Data.Array (filter, modifyAt, (!!), elemIndex)
import Data.Date (Date(), toEpochMilliseconds)
import Data.Either (Either(..), isRight, either)
import Data.Foldable (intercalate, foldl)
import Data.Function (on)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.String (indexOf)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Model.Notebook
import Model.Resource (Resource())
import Model.Notebook.Cell
import Model.Notebook.Cell.FileInput (_showFiles)
import Model.Notebook.Domain (_cells, addCell, insertCell, _dependencies, Notebook(), trash, ancestors)
import Model.Notebook.Port (Port(..), VarMapValue(), _PortResource, _VarMap)
import Optic.Core (LensP(), (..), (<>~), (%~), (+~), (.~), (^.), (?~), lens)
import Optic.Fold ((^?))
import Optic.Setter (mapped)
import Text.Markdown.SlamDown (SlamDown(..), Block(..), Expr(..), Inline(..), FormField(..), TextBoxType(..))
import Text.Markdown.SlamDown.Html (FormFieldValue(..), SlamDownEvent(..), SlamDownState(..), applySlamDownEvent)
import Text.Markdown.SlamDown.Parser (parseMd)
import Utils (elem)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.String.Regex as Rx
import qualified Data.StrMap as SM
import qualified ECharts.Options as EC
import qualified Model.Notebook.Cell.JTableContent as JTC
import qualified Model.Notebook.Cell.Markdown as Ma
import qualified Text.Parsing.StringParser as SP
import qualified Text.Parsing.StringParser.Combinators as SP
import qualified Text.Parsing.StringParser.String as SP
import Model.Path (FilePath(), AnyPath())

data CellResultContent
  = AceContent String
  | JTableContent JTC.JTableContent
  | MarkdownContent

data Input
  = WithState (State -> State)
  | Dropdown Number
  | CloseDropdowns
  | AddCell CellContent
  | TrashCell CellId

  | RequestCellContent Cell
  | ReceiveCellContent Cell
  | ViewCellContent Cell
  | RefreshCell Cell

  | StartRunCell CellId Date
  | StopCell CellId
  | CellResult CellId Date (Either (NEL.NonEmpty FailureMessage) CellResultContent)

  | UpdateCell CellId (Cell -> Cell)
  | CellSlamDownEvent CellId SlamDownEvent
  | InsertCell Cell CellContent
  | SetEChartsOption String EC.Option
  | ResizeECharts String

  | UpdatedOutput CellId Port
  | ForceSave

updateState :: State -> Input -> State

updateState state (WithState f) =
  f state

updateState state (UpdateCell cellId fn) =
  state # _notebook.._cells..mapped %~ onCell cellId fn

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # _dropdowns %~
  (modifyAt i _{visible = visSet}) <<< (_{visible = false} <$>)

updateState state CloseDropdowns =
  state # (_dropdowns %~ (_{visible = false} <$>))
       .. (_notebook .. _cells .. mapped %~ _content .. _FileInput .. _showFiles .~ false)

updateState state (AddCell content) =
  state # _notebook %~ (fst <<< addCell content)

updateState state (InsertCell parent content) =
  state # _notebook %~ (fst <<< insertCell parent content)

updateState state (TrashCell cellId) =
  state # _notebook.._cells %~ filter (not <<< depends (state ^._notebook) cellId)
        # _notebook.._cells %~ filter (not <<< isCell cellId)
        # _notebook.._dependencies %~ trash cellId

updateState state (CellResult cellId date content) =
  let finished d = RunFinished $ on (-) toEpochMilliseconds date d

      fromState (RunningSince d) = cellContent content <<< setRunState (finished d)
      fromState a = setRunState a -- In bad state or cancelled. Leave content.

      f cell = fromState (cell ^. _runState) cell # (_hasRun .~ true)

  in state # _notebook.._cells..mapped %~ onCell cellId f

updateState state (ReceiveCellContent cell) =
  state # _notebook.._cells..mapped %~ onCell (cell ^. _cellId) (const $  setSlamDownStatus cell)

updateState state (StartRunCell cellId date) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState (RunningSince date) <<< (_expandedStatus .~ false))

updateState state (StopCell cellId) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState RunInitial)

updateState state (CellSlamDownEvent cellId event) =
  state # _notebook.._cells..mapped %~ onCell cellId (slamDownOutput <<< runSlamDownEvent event)
        # _notebook.._cells %~ syncParents
        # _requesting <>~ [cellId]

updateState state (UpdatedOutput cid newInput) =
  let depIds = fst <$>
             filter (\x -> snd x == cid) (M.toList (state ^._notebook.._dependencies))
      changed cell = if elemIndex (cell ^._cellId) depIds == -1
                     then cell
                     else cell # _input .~ newInput
  in state # _notebook.._cells..mapped %~ changed

updateState state (RefreshCell cell) =
  let requesting = state ^. _requesting
      cid = cell ^. _cellId
  in if elem cid requesting
     then state
     else state # _refreshing <>~ [cell ^. _cellId]

updateState state i = state

slamDownStateMap :: LensP SlamDownState (SM.StrMap FormFieldValue)
slamDownStateMap = lens (\(SlamDownState m) -> m) (const SlamDownState)

-- TODO: We need a much better solution to this.
syncParents :: [Cell] -> [Cell]
syncParents cells = updateCell <$> cells
  where updateCell cell = fromMaybe cell $ fromParent cell
        fromParent cell = do
          pid <- cell ^. _parent
          parent <- M.lookup pid m
          return (cell # _input .~ (parent ^. _output))
        m = M.fromList $ pair <$> cells
        pair cell = Tuple (cell ^. _cellId) cell

slamDownOutput :: Cell -> Cell
slamDownOutput cell =
  cell # _output .. _VarMap  %~ modifyVarMap
  where
    modifyVarMap m = foldl (\m (Tuple key val) -> SM.insert key val m) m tplLst
    tplLst = maybe [] SM.toList ((fromFormValue <$>) <$> state)
    fromFormValue (SingleValue PlainText s) = quoteString s
    fromFormValue (SingleValue Date s) = "DATE '" ++ s ++ "'"
    fromFormValue (SingleValue Time s) = "TIME '" ++ s ++ "'"
    fromFormValue (SingleValue DateTime s) = "TIMESTAMP '" ++ processTimestamp s ++ "'"
    fromFormValue (MultipleValues s) = "[" <> intercalate ", " (quoteString <$> S.toList s) <> "]" -- TODO: is this anything like we want for multi-values?
    state = cell ^? _content.._Markdown..Ma._state..slamDownStateMap
    processTimestamp s = s ++ ":00Z"
    quoteString s | isSQLNum s = s
                  | otherwise = "'" ++ Rx.replace rxQuot "''" s ++ "'"
    rxQuot = Rx.regex "'" Rx.noFlags { global = true }
    rxT = Rx.regex "T" Rx.noFlags
    isSQLNum s = isRight $ flip SP.runParser s $ do
      SP.many1 SP.anyDigit
      SP.optional $ SP.string "." *> SP.many SP.anyDigit
      SP.optional $ (SP.string "e" <|> SP.string "E")
                 *> (SP.string "-" <|> SP.string "+")
                 *> SP.many SP.anyDigit

-- TODO: This should probably live in purescript-markdown
slamDownFields :: String -> [Tuple String FormField]
slamDownFields s =
  case parseMd s of
    SlamDown bs -> bs >>= block
  where
    block (Paragraph is) = is >>= inline
    block (Header _ is) = is >>= inline
    block (Blockquote bs) = bs >>= block
    block (List _ bss) = join bss >>= block
    block _ = []
    inline (Emph is) = is >>= inline
    inline (Strong is) = is >>= inline
    inline (Link is _) = is >>= inline
    inline (Image is _) = is >>= inline
    inline (FormField s _ ff) = [Tuple s ff]
    inline _ = []

-- TODO: Change Port to SlamDownState and use slamDownOutput instead.
initialSlamDownOutput :: [Tuple String FormField] -> Port
initialSlamDownOutput sf = VarMap sm
  where sm :: SM.StrMap VarMapValue
        sm = fromMaybe SM.empty <<< traverse toValue $ SM.fromList sf
        toValue :: FormField -> Maybe VarMapValue
        toValue (TextBox _ (Just (Literal s))) = Just s
        toValue (RadioButtons (Literal s) _) = Just s
        toValue (DropDown _ (Just (Literal s))) = Just s
        toValue (CheckBoxes _ (Literal ss)) = Nothing
        toValue _ = Nothing

setSlamDownStatus :: Cell -> Cell
setSlamDownStatus cell =
  let input' = cell ^? _content.._Markdown..Ma._input
      message = ("Exported fields: " <>) <<< intercalate ", " <<< (fst <$>)
      initial fields = cell # _message .~ message fields
                            # _output .~ initialSlamDownOutput fields
  in maybe cell (initial <<< slamDownFields) input'

runSlamDownEvent :: SlamDownEvent -> Cell -> Cell
runSlamDownEvent event cell =
  cell # _content.._Markdown..Ma._state %~ flip applySlamDownEvent event

cellContent :: Either (NEL.NonEmpty FailureMessage) CellResultContent -> Cell -> Cell
cellContent = either (setFailures <<< NEL.toArray) success
  where
  success :: CellResultContent -> Cell -> Cell
  success (AceContent content) =
    setFailures [ ]
    <<< (_content.._AceContent .~ content)
  success (JTableContent content) =
    setFailures [ ]
    <<< (_content.._JTableContent .~ content)
  success MarkdownContent = setFailures [ ]

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

setFailures :: [FailureMessage] -> Cell -> Cell
setFailures fs (Cell o) = Cell $ o { failures = fs }

setRunState :: RunState -> Cell -> Cell
setRunState = modifyRunState <<< const

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'

depends :: Notebook -> CellId -> Cell -> Boolean
depends notebook cellId cell =
  elemIndex cellId (ancestors (cell ^._cellId) (notebook ^._dependencies)) /= -1


Faster array equality

Faster array equality

module Prelude
  ( flip
  , const
  , asTypeOf
  , Semigroupoid, (<<<), (>>>)
  , Category, id
  , ($), (#)
  , (:), cons
  , Show, show
  , Functor, (<$>), void
  , Apply, (<*>)
  , Applicative, pure, liftA1
  , Alternative, empty, (<|>)
  , Bind, (>>=)
  , Monad, return, liftM1, ap
  , Num, (+), (-), (*), (/), (%)
  , negate
  , Eq, (==), (/=), refEq, refIneq
  , Ord, Ordering(..), compare, (<), (>), (<=), (>=)
  , Bits, (&), (|), (^), shl, shr, zshr, complement
  , BoolLike, (&&), (||)
  , not
  , Semigroup, (<>), (++)
  , Unit(..), unit
  ) where

  flip :: forall a b c. (a -> b -> c) -> b -> a -> c
  flip f b a = f a b

  const :: forall a b. a -> b -> a
  const a _ = a

  asTypeOf :: forall a. a -> a -> a
  asTypeOf x _ = x

  infixr 9 >>>
  infixr 9 <<<

  class Semigroupoid a where
    (<<<) :: forall b c d. a c d -> a b c -> a b d

  instance semigroupoidArr :: Semigroupoid (->) where
    (<<<) f g x = f (g x)

  (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
  (>>>) f g = g <<< f

  class (Semigroupoid a) <= Category a where
    id :: forall t. a t t

  instance categoryArr :: Category (->) where
    id x = x

  infixr 0 $
  infixl 0 #

  ($) :: forall a b. (a -> b) -> a -> b
  ($) f x = f x

  (#) :: forall a b. a -> (a -> b) -> b
  (#) x f = f x

  infixr 6 :

  (:) :: forall a. a -> [a] -> [a]
  (:) = cons

  foreign import cons
    "function cons(e) {\
    \  return function (l) {\
    \    return [e].concat(l);\
    \  };\
    \}" :: forall a. a -> [a] -> [a]

  class Show a where
    show :: a -> String

  foreign import showStringImpl
    "function showStringImpl(s) {\
    \  return JSON.stringify(s);\
    \}" :: String -> String

  instance showUnit :: Show Unit where
    show (Unit {}) = "Unit {}"

  instance showString :: Show String where
    show = showStringImpl

  instance showBoolean :: Show Boolean where
    show true = "true"
    show false = "false"

  foreign import showNumberImpl "function showNumberImpl(n) {\
                                \  return n.toString();\
                                \}" :: Number -> String

  instance showNumber :: Show Number where
    show = showNumberImpl

  foreign import showArrayImpl
    "function showArrayImpl (f) {\
    \  return function (xs) {\
    \    var ss = [];\
    \    for (var i = 0, l = xs.length; i < l; i++) {\
    \      ss[i] = f(xs[i]);\
    \    }\
    \    return '[' + ss.join(',') + ']';\
    \  };\
    \}" :: forall a. (a -> String) -> [a] -> String

  instance showArray :: (Show a) => Show [a] where
    show = showArrayImpl show

  infixl 4 <$>

  class Functor f where
    (<$>) :: forall a b. (a -> b) -> f a -> f b

  void :: forall f a. (Functor f) => f a -> f Unit
  void fa = const unit <$> fa

  infixl 4 <*>

  class (Functor f) <= Apply f where
    (<*>) :: forall a b. f (a -> b) -> f a -> f b

  class (Apply f) <= Applicative f where
    pure :: forall a. a -> f a

  liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
  liftA1 f a = pure f <*> a

  infixl 3 <|>

  class Alternative f where
    empty :: forall a. f a
    (<|>) :: forall a. f a -> f a -> f a

  infixl 1 >>=

  class (Apply m) <= Bind m where
    (>>=) :: forall a b. m a -> (a -> m b) -> m b

  class (Applicative m, Bind m) <= Monad m

  return :: forall m a. (Monad m) => a -> m a
  return = pure

  liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
  liftM1 f a = do
    a' <- a
    return (f a')

  ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
  ap f a = do
    f' <- f
    a' <- a
    return (f' a')

  instance functorArr :: Functor ((->) r) where
    (<$>) = (<<<)

  instance applyArr :: Apply ((->) r) where
    (<*>) f g x = f x (g x)

  instance applicativeArr :: Applicative ((->) r) where
    pure = const

  instance bindArr :: Bind ((->) r) where
    (>>=) m f x = f (m x) x

  instance monadArr :: Monad ((->) r)

  infixl 7 *
  infixl 7 /
  infixl 7 %

  infixl 6 -
  infixl 6 +

  class Num a where
    (+) :: a -> a -> a
    (-) :: a -> a -> a
    (*) :: a -> a -> a
    (/) :: a -> a -> a
    (%) :: a -> a -> a
    negate :: a -> a

  foreign import numAdd "function numAdd(n1) {\
                        \  return function(n2) {\
                        \    return n1 + n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numSub "function numSub(n1) {\
                        \  return function(n2) {\
                        \    return n1 - n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMul "function numMul(n1) {\
                        \  return function(n2) {\
                        \    return n1 * n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numDiv "function numDiv(n1) {\
                        \  return function(n2) {\
                        \    return n1 / n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMod "function numMod(n1) {\
                        \  return function(n2) {\
                        \    return n1 % n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numNegate "function numNegate(n) {\
                           \  return -n;\
                           \}" :: Number -> Number

  instance numNumber :: Num Number where
    (+) = numAdd
    (-) = numSub
    (*) = numMul
    (/) = numDiv
    (%) = numMod
    negate = numNegate

  data Unit = Unit {}

  unit :: Unit
  unit = Unit {}

  infix 4 ==
  infix 4 /=

  class Eq a where
    (==) :: a -> a -> Boolean
    (/=) :: a -> a -> Boolean

  foreign import refEq
    "function refEq(r1) {\
    \  return function(r2) {\
    \    return r1 === r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  foreign import refIneq
    "function refIneq(r1) {\
    \  return function(r2) {\
    \    return r1 !== r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  instance eqUnit :: Eq Unit where
    (==) (Unit {}) (Unit {}) = true
    (/=) (Unit {}) (Unit {}) = false

  instance eqString :: Eq String where
    (==) = refEq
    (/=) = refIneq

  instance eqNumber :: Eq Number where
    (==) = refEq
    (/=) = refIneq

  instance eqBoolean :: Eq Boolean where
    (==) = refEq
    (/=) = refIneq

  foreign import eqArrayImpl
    "function eqArrayImpl(f) {\
    \  return function(xs) {\
    \    return function(ys) {\
    \      if (xs.length !== ys.length) return false;\
    \      for (var i = 0; i < xs.length; i++) {\
    \        if (!f(xs[i])(ys[i])) return false;\
    \      }\
    \      return true;\
    \    };\
    \  };\
    \}" :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> Boolean

  instance eqArray :: (Eq a) => Eq [a] where
    (==) xs ys = eqArrayImpl (==) xs ys
    (/=) xs ys = not (xs == ys)

  data Ordering = LT | GT | EQ

  instance eqOrdering :: Eq Ordering where
    (==) LT LT = true
    (==) GT GT = true
    (==) EQ EQ = true
    (==) _  _  = false
    (/=) x y = not (x == y)

  instance showOrdering :: Show Ordering where
    show LT = "LT"
    show GT = "GT"
    show EQ = "EQ"

  class (Eq a) <= Ord a where
    compare :: a -> a -> Ordering

  infixl 4 <

  (<) :: forall a. (Ord a) => a -> a -> Boolean
  (<) a1 a2 = case a1 `compare` a2 of
    LT -> true
    _ -> false

  infixl 4 >

  (>) :: forall a. (Ord a) => a -> a -> Boolean
  (>) a1 a2 = case a1 `compare` a2 of
    GT -> true
    _ -> false

  infixl 4 <=

  (<=) :: forall a. (Ord a) => a -> a -> Boolean
  (<=) a1 a2 = case a1 `compare` a2 of
    GT -> false
    _ -> true

  infixl 4 >=

  (>=) :: forall a. (Ord a) => a -> a -> Boolean
  (>=) a1 a2 = case a1 `compare` a2 of
    LT -> false
    _ -> true

  foreign import unsafeCompare
    "function unsafeCompare(n1) {\
    \  return function(n2) {\
    \    return n1 < n2 ? LT : n1 > n2 ? GT : EQ;\
    \  };\
    \}" :: forall a. a -> a -> Ordering

  instance ordUnit :: Ord Unit where
    compare (Unit {}) (Unit {}) = EQ

  instance ordBoolean :: Ord Boolean where
    compare false false = EQ
    compare false true  = LT
    compare true  true  = EQ
    compare true  false = GT

  instance ordNumber :: Ord Number where
    compare = unsafeCompare

  instance ordString :: Ord String where
    compare = unsafeCompare

  instance ordArray :: (Ord a) => Ord [a] where
    compare [] [] = EQ
    compare [] _ = LT
    compare _ [] = GT
    compare (x:xs) (y:ys) = case compare x y of
      EQ -> compare xs ys
      other -> other

  infixl 10 &
  infixl 10 |
  infixl 10 ^

  class Bits b where
    (&) :: b -> b -> b
    (|) :: b -> b -> b
    (^) :: b -> b -> b
    shl :: b -> Number -> b
    shr :: b -> Number -> b
    zshr :: b -> Number -> b
    complement :: b -> b

  foreign import numShl "function numShl(n1) {\
                        \  return function(n2) {\
                        \    return n1 << n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numShr "function numShr(n1) {\
                        \  return function(n2) {\
                        \    return n1 >> n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numZshr "function numZshr(n1) {\
                          \  return function(n2) {\
                          \    return n1 >>> n2;\
                          \  };\
                          \}" :: Number -> Number -> Number

  foreign import numAnd "function numAnd(n1) {\
                        \  return function(n2) {\
                        \    return n1 & n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numOr "function numOr(n1) {\
                       \  return function(n2) {\
                       \    return n1 | n2;\
                       \  };\
                       \}" :: Number -> Number -> Number

  foreign import numXor "function numXor(n1) {\
                        \  return function(n2) {\
                        \    return n1 ^ n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numComplement "function numComplement(n) {\
                               \  return ~n;\
                               \}" :: Number -> Number

  instance bitsNumber :: Bits Number where
    (&) = numAnd
    (|) = numOr
    (^) = numXor
    shl = numShl
    shr = numShr
    zshr = numZshr
    complement = numComplement

  infixr 2 ||
  infixr 3 &&

  class BoolLike b where
    (&&) :: b -> b -> b
    (||) :: b -> b -> b
    not :: b -> b

  foreign import boolAnd "function boolAnd(b1) {\
                         \  return function(b2) {\
                         \    return b1 && b2;\
                         \  };\
                         \}"  :: Boolean -> Boolean -> Boolean

  foreign import boolOr "function boolOr(b1) {\
                        \  return function(b2) {\
                        \    return b1 || b2;\
                        \  };\
                        \}" :: Boolean -> Boolean -> Boolean

  foreign import boolNot "function boolNot(b) {\
                         \  return !b;\
                         \}" :: Boolean -> Boolean

  instance boolLikeBoolean :: BoolLike Boolean where
    (&&) = boolAnd
    (||) = boolOr
    not = boolNot

  infixr 5 <>

  class Semigroup a where
    (<>) :: a -> a -> a

  foreign import concatString
    "function concatString(s1) {\
    \  return function(s2) {\
    \    return s1 + s2;\
    \  };\
    \}" :: String -> String -> String

  instance semigroupUnit :: Semigroup Unit where
    (<>) (Unit {}) (Unit {}) = Unit {}

  instance semigroupString :: Semigroup String where
    (<>) = concatString

  instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where
    (<>) f g = \x -> f x <> g x

  infixr 5 ++

  (++) :: forall s. (Semigroup s) => s -> s -> s
  (++) = (<>)

module Data.Function where

  on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
  on f g x y = g x `f` g y

  foreign import data Fn0 :: * -> *
  foreign import data Fn1 :: * -> * -> *
  foreign import data Fn2 :: * -> * -> * -> *
  foreign import data Fn3 :: * -> * -> * -> * -> *
  foreign import data Fn4 :: * -> * -> * -> * -> * -> *
  foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *

  foreign import mkFn0
    "function mkFn0(f) {\
    \  return function() {\
    \    return f({});\
    \  };\
    \}" :: forall a. (Unit -> a) -> Fn0 a

  foreign import mkFn1
    "function mkFn1(f) {\
    \  return function(a) {\
    \    return f(a);\
    \  };\
    \}" :: forall a b. (a -> b) -> Fn1 a b

  foreign import mkFn2
    "function mkFn2(f) {\
    \  return function(a, b) {\
    \    return f(a)(b);\
    \  };\
    \}" :: forall a b c. (a -> b -> c) -> Fn2 a b c

  foreign import mkFn3
    "function mkFn3(f) {\
    \  return function(a, b, c) {\
    \    return f(a)(b)(c);\
    \  };\
    \}" :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d

  foreign import mkFn4
    "function mkFn4(f) {\
    \  return function(a, b, c, d) {\
    \    return f(a)(b)(c)(d);\
    \  };\
    \}" :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e

  foreign import mkFn5
    "function mkFn5(f) {\
    \  return function(a, b, c, d, e) {\
    \    return f(a)(b)(c)(d)(e);\
    \  };\
    \}" :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f

  foreign import runFn0
    "function runFn0(f) {\
    \  return f();\
    \}" :: forall a. Fn0 a -> a

  foreign import runFn1
    "function runFn1(f) {\
    \  return function(a) {\
    \    return f(a);\
    \  };\
    \}" :: forall a b. Fn1 a b -> a -> b

  foreign import runFn2
    "function runFn2(f) {\
    \  return function(a) {\
    \    return function(b) {\
    \      return f(a, b);\
    \    };\
    \  };\
    \}" :: forall a b c. Fn2 a b c -> a -> b -> c

  foreign import runFn3
    "function runFn3(f) {\
    \  return function(a) {\
    \    return function(b) {\
    \      return function(c) {\
    \        return f(a, b, c);\
    \      };\
    \    };\
    \  };\
    \}" :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d

  foreign import runFn4
    "function runFn4(f) {\
    \  return function(a) {\
    \    return function(b) {\
    \      return function(c) {\
    \        return function(d) {\
    \          return f(a, b, c, d);\
    \        };\
    \      };\
    \    };\
    \  };\
    \}" :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e

  foreign import runFn5
    "function runFn5(f) {\
    \  return function(a) {\
    \    return function(b) {\
    \      return function(c) {\
    \        return function(d) {\
    \          return function(e) {\
    \            return f(a, b, c, d, e);\
    \          };\
    \        };\
    \      };\
    \    };\
    \  };\
    \}" :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f

module Data.Eq where

  data Ref a = Ref a

  liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
  liftRef f (Ref x) (Ref y) = f x y

  instance eqRef :: Eq (Ref a) where
    (==) = liftRef refEq
    (/=) = liftRef refIneq

module Prelude.Unsafe where

  foreign import unsafeIndex
    "function unsafeIndex(xs) {\
    \  return function(n) {\
    \    return xs[n];\
    \  };\
    \}" :: forall a. [a] -> Number -> a

module Control.Monad.Eff where

  foreign import data Eff :: # ! -> * -> *

  foreign import returnE "function returnE(a) {\
                         \  return function() {\
                         \    return a;\
                         \  };\
                         \}" :: forall e a. a -> Eff e a

  foreign import bindE "function bindE(a) {\
                       \  return function(f) {\
                       \    return function() {\
                       \      return f(a())();\
                       \    };\
                       \  };\
                       \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

  type Pure a = forall e. Eff e a

  foreign import runPure "function runPure(f) {\
                         \  return f();\
                         \}" :: forall a. Pure a -> a

  instance functorEff :: Functor (Eff e) where
    (<$>) = liftA1

  instance applyEff :: Apply (Eff e) where
    (<*>) = ap

  instance applicativeEff :: Applicative (Eff e) where
    pure = returnE

  instance bindEff :: Bind (Eff e) where
    (>>=) = bindE

  instance monadEff :: Monad (Eff e)

  foreign import untilE "function untilE(f) {\
                        \  return function() {\
                        \    while (!f()) { }\
                        \    return {};\
                        \  };\
                        \}" :: forall e. Eff e Boolean -> Eff e Unit

  foreign import whileE "function whileE(f) {\
                        \  return function(a) {\
                        \    return function() {\
                        \      while (f()) {\
                        \        a();\
                        \      }\
                        \      return {};\
                        \    };\
                        \  };\
                        \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit

  foreign import forE "function forE(lo) {\
                      \  return function(hi) {\
                      \    return function(f) {\
                      \      return function() {\
                      \        for (var i = lo; i < hi; i++) {\
                      \          f(i)();\
                      \        }\
                      \      };\
                      \    };\
                      \  };\
                      \}" :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit

  foreign import foreachE "function foreachE(as) {\
                          \  return function(f) {\
                          \    for (var i = 0; i < as.length; i++) {\
                          \      f(as[i])();\
                          \    }\
                          \  };\
                          \}" :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit

module Control.Monad.Eff.Unsafe where

  import Control.Monad.Eff

  foreign import unsafeInterleaveEff
    "function unsafeInterleaveEff(f) {\
    \  return f;\
    \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a

module Debug.Trace where

  import Control.Monad.Eff

  foreign import data Trace :: !

  foreign import trace "function trace(s) {\
                       \  return function() {\
                       \    console.log(s);\
                       \    return {};\
                       \  };\
                       \}" :: forall r. String -> Eff (trace :: Trace | r) Unit

  print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit
  print o = trace (show o)

module Control.Monad.ST where

  import Control.Monad.Eff

  foreign import data ST :: * -> !

  foreign import data STRef :: * -> * -> *

  foreign import data STArray :: * -> * -> *

  foreign import newSTRef "function newSTRef(val) {\
                          \  return function () {\
                          \    return { value: val };\
                          \  };\
                          \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

  foreign import readSTRef "function readSTRef(ref) {\
                           \  return function() {\
                           \    return ref.value;\
                           \  };\
                           \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

  foreign import modifySTRef "function modifySTRef(ref) {\
                             \  return function(f) {\
                             \    return function() {\
                             \      return ref.value = f(ref.value);\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

  foreign import writeSTRef "function writeSTRef(ref) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      return ref.value = a;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

  foreign import newSTArray "function newSTArray(len) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      var arr = [];\
                            \      for (var i = 0; i < len; i++) {\
                            \        arr[i] = a;\
                            \      };\
                            \      return arr;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)

  foreign import peekSTArray "function peekSTArray(arr) {\
                             \  return function(i) {\
                             \    return function() {\
                             \      return arr[i];\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Eff (st :: ST h | r) a

  foreign import pokeSTArray "function pokeSTArray(arr) {\
                             \  return function(i) {\
                             \    return function(a) {\
                             \      return function() {\
                             \        return arr[i] = a;\
                             \      };\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a

  foreign import runST "function runST(f) {\
                       \  return f;\
                       \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

  foreign import runSTArray "function runSTArray(f) {\
                            \  return f;\
                            \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]

module Prelude
  ( flip
  , const
  , asTypeOf
  , Semigroupoid, (<<<), (>>>)
  , Category, id
  , ($), (#)
  , (:), cons
  , Show, show
  , Functor, (<$>), void
  , Apply, (<*>)
  , Applicative, pure, liftA1
  , Alternative, empty, (<|>)
  , Bind, (>>=)
  , Monad, return, liftM1, ap
  , Num, (+), (-), (*), (/), (%)
  , negate
  , Eq, (==), (/=), refEq, refIneq
  , Ord, Ordering(..), compare, (<), (>), (<=), (>=)
  , Bits, (&), (|), (^), shl, shr, zshr, complement
  , BoolLike, (&&), (||)
  , not
  , Semigroup, (<>), (++)
  , Unit(..), unit
  ) where

  flip :: forall a b c. (a -> b -> c) -> b -> a -> c
  flip f b a = f a b

  const :: forall a b. a -> b -> a
  const a _ = a

  asTypeOf :: forall a. a -> a -> a
  asTypeOf x _ = x

  infixr 9 >>>
  infixr 9 <<<

  class Semigroupoid a where
    (<<<) :: forall b c d. a c d -> a b c -> a b d

  instance semigroupoidArr :: Semigroupoid (->) where
    (<<<) f g x = f (g x)

  (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
  (>>>) f g = g <<< f

  class (Semigroupoid a) <= Category a where
    id :: forall t. a t t

  instance categoryArr :: Category (->) where
    id x = x

  infixr 0 $
  infixl 0 #

  ($) :: forall a b. (a -> b) -> a -> b
  ($) f x = f x

  (#) :: forall a b. a -> (a -> b) -> b
  (#) x f = f x

  infixr 6 :

  (:) :: forall a. a -> [a] -> [a]
  (:) = cons

  foreign import cons
    "function cons(e) {\
    \  return function (l) {\
    \    return [e].concat(l);\
    \  };\
    \}" :: forall a. a -> [a] -> [a]

  class Show a where
    show :: a -> String

  foreign import showStringImpl
    "function showStringImpl(s) {\
    \  return JSON.stringify(s);\
    \}" :: String -> String

  instance showUnit :: Show Unit where
    show (Unit {}) = "Unit {}"

  instance showString :: Show String where
    show = showStringImpl

  instance showBoolean :: Show Boolean where
    show true = "true"
    show false = "false"

  foreign import showNumberImpl "function showNumberImpl(n) {\
                                \  return n.toString();\
                                \}" :: Number -> String

  instance showNumber :: Show Number where
    show = showNumberImpl

  foreign import showArrayImpl
    "function showArrayImpl (f) {\
    \  return function (xs) {\
    \    var ss = [];\
    \    for (var i = 0, l = xs.length; i < l; i++) {\
    \      ss[i] = f(xs[i]);\
    \    }\
    \    return '[' + ss.join(',') + ']';\
    \  };\
    \}" :: forall a. (a -> String) -> [a] -> String

  instance showArray :: (Show a) => Show [a] where
    show = showArrayImpl show

  infixl 4 <$>

  class Functor f where
    (<$>) :: forall a b. (a -> b) -> f a -> f b

  void :: forall f a. (Functor f) => f a -> f Unit
  void fa = const unit <$> fa

  infixl 4 <*>

  class (Functor f) <= Apply f where
    (<*>) :: forall a b. f (a -> b) -> f a -> f b

  class (Apply f) <= Applicative f where
    pure :: forall a. a -> f a

  liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
  liftA1 f a = pure f <*> a

  infixl 3 <|>

  class Alternative f where
    empty :: forall a. f a
    (<|>) :: forall a. f a -> f a -> f a

  infixl 1 >>=

  class (Apply m) <= Bind m where
    (>>=) :: forall a b. m a -> (a -> m b) -> m b

  class (Applicative m, Bind m) <= Monad m

  return :: forall m a. (Monad m) => a -> m a
  return = pure

  liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
  liftM1 f a = do
    a' <- a
    return (f a')

  ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
  ap f a = do
    f' <- f
    a' <- a
    return (f' a')

  instance functorArr :: Functor ((->) r) where
    (<$>) = (<<<)

  instance applyArr :: Apply ((->) r) where
    (<*>) f g x = f x (g x)

  instance applicativeArr :: Applicative ((->) r) where
    pure = const

  instance bindArr :: Bind ((->) r) where
    (>>=) m f x = f (m x) x

  instance monadArr :: Monad ((->) r)

  infixl 7 *
  infixl 7 /
  infixl 7 %

  infixl 6 -
  infixl 6 +

  class Num a where
    (+) :: a -> a -> a
    (-) :: a -> a -> a
    (*) :: a -> a -> a
    (/) :: a -> a -> a
    (%) :: a -> a -> a
    negate :: a -> a

  foreign import numAdd "function numAdd(n1) {\
                        \  return function(n2) {\
                        \    return n1 + n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numSub "function numSub(n1) {\
                        \  return function(n2) {\
                        \    return n1 - n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMul "function numMul(n1) {\
                        \  return function(n2) {\
                        \    return n1 * n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numDiv "function numDiv(n1) {\
                        \  return function(n2) {\
                        \    return n1 / n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMod "function numMod(n1) {\
                        \  return function(n2) {\
                        \    return n1 % n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numNegate "function numNegate(n) {\
                           \  return -n;\
                           \}" :: Number -> Number

  instance numNumber :: Num Number where
    (+) = numAdd
    (-) = numSub
    (*) = numMul
    (/) = numDiv
    (%) = numMod
    negate = numNegate

  data Unit = Unit {}

  unit :: Unit
  unit = Unit {}

  infix 4 ==
  infix 4 /=

  class Eq a where
    (==) :: a -> a -> Boolean
    (/=) :: a -> a -> Boolean

  foreign import refEq
    "function refEq(r1) {\
    \  return function(r2) {\
    \    return r1 === r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  foreign import refIneq
    "function refIneq(r1) {\
    \  return function(r2) {\
    \    return r1 !== r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  instance eqUnit :: Eq Unit where
    (==) (Unit {}) (Unit {}) = true
    (/=) (Unit {}) (Unit {}) = false

  instance eqString :: Eq String where
    (==) = refEq
    (/=) = refIneq

  instance eqNumber :: Eq Number where
    (==) = refEq
    (/=) = refIneq

  instance eqBoolean :: Eq Boolean where
    (==) = refEq
    (/=) = refIneq

  instance eqArray :: (Eq a) => Eq [a] where
    (==) [] [] = true
    (==) (x:xs) (y:ys) = x == y && xs == ys
    (==) _ _ = false
    (/=) xs ys = not (xs == ys)

  data Ordering = LT | GT | EQ

  instance eqOrdering :: Eq Ordering where
    (==) LT LT = true
    (==) GT GT = true
    (==) EQ EQ = true
    (==) _  _  = false
    (/=) x y = not (x == y)

  instance showOrdering :: Show Ordering where
    show LT = "LT"
    show GT = "GT"
    show EQ = "EQ"

  class (Eq a) <= Ord a where
    compare :: a -> a -> Ordering

  infixl 4 <

  (<) :: forall a. (Ord a) => a -> a -> Boolean
  (<) a1 a2 = case a1 `compare` a2 of
    LT -> true
    _ -> false

  infixl 4 >

  (>) :: forall a. (Ord a) => a -> a -> Boolean
  (>) a1 a2 = case a1 `compare` a2 of
    GT -> true
    _ -> false

  infixl 4 <=

  (<=) :: forall a. (Ord a) => a -> a -> Boolean
  (<=) a1 a2 = case a1 `compare` a2 of
    GT -> false
    _ -> true

  infixl 4 >=

  (>=) :: forall a. (Ord a) => a -> a -> Boolean
  (>=) a1 a2 = case a1 `compare` a2 of
    LT -> false
    _ -> true

  foreign import unsafeCompare
    "function unsafeCompare(n1) {\
    \  return function(n2) {\
    \    return n1 < n2 ? LT : n1 > n2 ? GT : EQ;\
    \  };\
    \}" :: forall a. a -> a -> Ordering

  instance ordUnit :: Ord Unit where
    compare (Unit {}) (Unit {}) = EQ

  instance ordBoolean :: Ord Boolean where
    compare false false = EQ
    compare false true  = LT
    compare true  true  = EQ
    compare true  false = GT

  instance ordNumber :: Ord Number where
    compare = unsafeCompare

  instance ordString :: Ord String where
    compare = unsafeCompare

  instance ordArray :: (Ord a) => Ord [a] where
    compare [] [] = EQ
    compare [] _ = LT
    compare _ [] = GT
    compare (x:xs) (y:ys) = case compare x y of
      EQ -> compare xs ys
      other -> other

  infixl 10 &
  infixl 10 |
  infixl 10 ^

  class Bits b where
    (&) :: b -> b -> b
    (|) :: b -> b -> b
    (^) :: b -> b -> b
    shl :: b -> Number -> b
    shr :: b -> Number -> b
    zshr :: b -> Number -> b
    complement :: b -> b

  foreign import numShl "function numShl(n1) {\
                        \  return function(n2) {\
                        \    return n1 << n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numShr "function numShr(n1) {\
                        \  return function(n2) {\
                        \    return n1 >> n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numZshr "function numZshr(n1) {\
                          \  return function(n2) {\
                          \    return n1 >>> n2;\
                          \  };\
                          \}" :: Number -> Number -> Number

  foreign import numAnd "function numAnd(n1) {\
                        \  return function(n2) {\
                        \    return n1 & n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numOr "function numOr(n1) {\
                       \  return function(n2) {\
                       \    return n1 | n2;\
                       \  };\
                       \}" :: Number -> Number -> Number

  foreign import numXor "function numXor(n1) {\
                        \  return function(n2) {\
                        \    return n1 ^ n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numComplement "function numComplement(n) {\
                               \  return ~n;\
                               \}" :: Number -> Number

  instance bitsNumber :: Bits Number where
    (&) = numAnd
    (|) = numOr
    (^) = numXor
    shl = numShl
    shr = numShr
    zshr = numZshr
    complement = numComplement

  infixr 2 ||
  infixr 3 &&

  class BoolLike b where
    (&&) :: b -> b -> b
    (||) :: b -> b -> b
    not :: b -> b

  foreign import boolAnd "function boolAnd(b1) {\
                         \  return function(b2) {\
                         \    return b1 && b2;\
                         \  };\
                         \}"  :: Boolean -> Boolean -> Boolean

  foreign import boolOr "function boolOr(b1) {\
                        \  return function(b2) {\
                        \    return b1 || b2;\
                        \  };\
                        \}" :: Boolean -> Boolean -> Boolean

  foreign import boolNot "function boolNot(b) {\
                         \  return !b;\
                         \}" :: Boolean -> Boolean

  instance boolLikeBoolean :: BoolLike Boolean where
    (&&) = boolAnd
    (||) = boolOr
    not = boolNot

  infixr 5 <>

  class Semigroup a where
    (<>) :: a -> a -> a

  foreign import concatString
    "function concatString(s1) {\
    \  return function(s2) {\
    \    return s1 + s2;\
    \  };\
    \}" :: String -> String -> String

  instance semigroupUnit :: Semigroup Unit where
    (<>) (Unit {}) (Unit {}) = Unit {}

  instance semigroupString :: Semigroup String where
    (<>) = concatString

  instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where
    (<>) f g = \x -> f x <> g x

  infixr 5 ++

  (++) :: forall s. (Semigroup s) => s -> s -> s
  (++) = (<>)

module Data.Function where

  on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
  on f g x y = g x `f` g y

  foreign import data Fn0 :: * -> *
  foreign import data Fn1 :: * -> * -> *
  foreign import data Fn2 :: * -> * -> * -> *
  foreign import data Fn3 :: * -> * -> * -> * -> *
  foreign import data Fn4 :: * -> * -> * -> * -> * -> *
  foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *

  foreign import mkFn0
    "function mkFn0(f) {\
    \  return function() {\
    \    return f({});\
    \  };\
    \}" :: forall a. (Unit -> a) -> Fn0 a

  foreign import mkFn1
    "function mkFn1(f) {\
    \  return function(a) {\
    \    return f(a);\
    \  };\
    \}" :: forall a b. (a -> b) -> Fn1 a b

  foreign import mkFn2
    "function mkFn2(f) {\
    \  return function(a, b) {\
    \    return f(a)(b);\
    \  };\
    \}" :: forall a b c. (a -> b -> c) -> Fn2 a b c

  foreign import mkFn3
    "function mkFn3(f) {\
    \  return function(a, b, c) {\
    \    return f(a)(b)(c);\
    \  };\
    \}" :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d

  foreign import mkFn4
    "function mkFn4(f) {\
    \  return function(a, b, c, d) {\
    \    return f(a)(b)(c)(d);\
    \  };\
    \}" :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e

  foreign import mkFn5
    "function mkFn5(f) {\
    \  return function(a, b, c, d, e) {\
    \    return f(a)(b)(c)(d)(e);\
    \  };\
    \}" :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f

  foreign import runFn0
    "function runFn0(f) {\
    \  return f();\
    \}" :: forall a. Fn0 a -> a

  foreign import runFn1
    "function runFn1(f) {\
    \  return function(a) {\
    \    return f(a);\
    \  };\
    \}" :: forall a b. Fn1 a b -> a -> b

  foreign import runFn2
    "function runFn2(f) {\
    \  return function(a) {\
    \    return function(b) {\
    \      return f(a, b);\
    \    };\
    \  };\
    \}" :: forall a b c. Fn2 a b c -> a -> b -> c

  foreign import runFn3
    "function runFn3(f) {\
    \  return function(a) {\
    \    return function(b) {\
    \      return function(c) {\
    \        return f(a, b, c);\
    \      };\
    \    };\
    \  };\
    \}" :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d

  foreign import runFn4
    "function runFn4(f) {\
    \  return function(a) {\
    \    return function(b) {\
    \      return function(c) {\
    \        return function(d) {\
    \          return f(a, b, c, d);\
    \        };\
    \      };\
    \    };\
    \  };\
    \}" :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e

  foreign import runFn5
    "function runFn5(f) {\
    \  return function(a) {\
    \    return function(b) {\
    \      return function(c) {\
    \        return function(d) {\
    \          return function(e) {\
    \            return f(a, b, c, d, e);\
    \          };\
    \        };\
    \      };\
    \    };\
    \  };\
    \}" :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f

module Data.Eq where

  data Ref a = Ref a

  liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
  liftRef f (Ref x) (Ref y) = f x y

  instance eqRef :: Eq (Ref a) where
    (==) = liftRef refEq
    (/=) = liftRef refIneq

module Prelude.Unsafe where

  foreign import unsafeIndex
    "function unsafeIndex(xs) {\
    \  return function(n) {\
    \    return xs[n];\
    \  };\
    \}" :: forall a. [a] -> Number -> a

module Control.Monad.Eff where

  foreign import data Eff :: # ! -> * -> *

  foreign import returnE "function returnE(a) {\
                         \  return function() {\
                         \    return a;\
                         \  };\
                         \}" :: forall e a. a -> Eff e a

  foreign import bindE "function bindE(a) {\
                       \  return function(f) {\
                       \    return function() {\
                       \      return f(a())();\
                       \    };\
                       \  };\
                       \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

  type Pure a = forall e. Eff e a

  foreign import runPure "function runPure(f) {\
                         \  return f();\
                         \}" :: forall a. Pure a -> a

  instance functorEff :: Functor (Eff e) where
    (<$>) = liftA1

  instance applyEff :: Apply (Eff e) where
    (<*>) = ap

  instance applicativeEff :: Applicative (Eff e) where
    pure = returnE

  instance bindEff :: Bind (Eff e) where
    (>>=) = bindE

  instance monadEff :: Monad (Eff e)

  foreign import untilE "function untilE(f) {\
                        \  return function() {\
                        \    while (!f()) { }\
                        \    return {};\
                        \  };\
                        \}" :: forall e. Eff e Boolean -> Eff e Unit

  foreign import whileE "function whileE(f) {\
                        \  return function(a) {\
                        \    return function() {\
                        \      while (f()) {\
                        \        a();\
                        \      }\
                        \      return {};\
                        \    };\
                        \  };\
                        \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit

  foreign import forE "function forE(lo) {\
                      \  return function(hi) {\
                      \    return function(f) {\
                      \      return function() {\
                      \        for (var i = lo; i < hi; i++) {\
                      \          f(i)();\
                      \        }\
                      \      };\
                      \    };\
                      \  };\
                      \}" :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit

  foreign import foreachE "function foreachE(as) {\
                          \  return function(f) {\
                          \    for (var i = 0; i < as.length; i++) {\
                          \      f(as[i])();\
                          \    }\
                          \  };\
                          \}" :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit

module Control.Monad.Eff.Unsafe where

  import Control.Monad.Eff

  foreign import unsafeInterleaveEff
    "function unsafeInterleaveEff(f) {\
    \  return f;\
    \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a

module Debug.Trace where

  import Control.Monad.Eff

  foreign import data Trace :: !

  foreign import trace "function trace(s) {\
                       \  return function() {\
                       \    console.log(s);\
                       \    return {};\
                       \  };\
                       \}" :: forall r. String -> Eff (trace :: Trace | r) Unit

  print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit
  print o = trace (show o)

module Control.Monad.ST where

  import Control.Monad.Eff

  foreign import data ST :: * -> !

  foreign import data STRef :: * -> * -> *

  foreign import data STArray :: * -> * -> *

  foreign import newSTRef "function newSTRef(val) {\
                          \  return function () {\
                          \    return { value: val };\
                          \  };\
                          \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

  foreign import readSTRef "function readSTRef(ref) {\
                           \  return function() {\
                           \    return ref.value;\
                           \  };\
                           \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

  foreign import modifySTRef "function modifySTRef(ref) {\
                             \  return function(f) {\
                             \    return function() {\
                             \      return ref.value = f(ref.value);\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

  foreign import writeSTRef "function writeSTRef(ref) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      return ref.value = a;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

  foreign import newSTArray "function newSTArray(len) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      var arr = [];\
                            \      for (var i = 0; i < len; i++) {\
                            \        arr[i] = a;\
                            \      };\
                            \      return arr;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)

  foreign import peekSTArray "function peekSTArray(arr) {\
                             \  return function(i) {\
                             \    return function() {\
                             \      return arr[i];\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Eff (st :: ST h | r) a

  foreign import pokeSTArray "function pokeSTArray(arr) {\
                             \  return function(i) {\
                             \    return function(a) {\
                             \      return function() {\
                             \        return arr[i] = a;\
                             \      };\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a

  foreign import runST "function runST(f) {\
                       \  return f;\
                       \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

  foreign import runSTArray "function runSTArray(f) {\
                            \  return f;\
                            \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]


8.7.4 Verify that the monad laws hold for the Monad instance for the Maybe type, as defined in the purescript-maybe package.

module Solution where

import Prelude
import Data.Maybe
import Data.Array

-- 8.7.1
-- Look up the types of the head and tail functions from the Data.Array module in the purescript-arrays package.
-- Use do notation with the Maybe monad to combine these functions
-- into a function third which returns the third element of an array with three or more elements.
-- Your function should return an appropriate Maybe type.

third :: forall a. Array a -> Maybe a
third as = do
  tail1 <- tail as
  tail2 <- tail tail1
  head tail2

-- 8.7.1
-- Write a function sums which uses foldM to determine all possible totals that could be made using a set of coins.
-- The coins will be specified as an array which contains the value of each coin
-- Hint: This function can be written as a one-liner using foldM.
-- You might want to use the nub and sort functions to remove duplicates and sort the result respectively.
-- https://wiki.haskell.org/All_About_Monads

sums :: Array Int -> Array Int
sums =
  foldM (\a b -> [a, a+b, b]) 0
  >>> nub
  >>> sort

-- 8.7.3
-- Confirm that the ap function and the apply operator agree for the Maybe monad

-- class (Functor f) <= Apply f where
--   apply :: forall a b. f (a -> b) -> f a -> f b
--
-- instance applyMaybe :: Apply Maybe where
--   apply (Just fn) x = fn <$> x
--   apply Nothing   _ = Nothing
--
--
-- ap :: forall m. (Monad m) => m (a -> b) -> m a -> m b
-- ap mf ma = do
--  f <- mf -- "early return" if mf is Nothing
--  a <- ma -- "early return" if ma is Nothing
--  return (f a) -- f <$> ma == map f ma

-- 8.7.3 Verify that the monad laws hold for the Monad instance for the Maybe type, as defined in the purescript-maybe package.

-- class (Functor f) <= Apply f where
--   apply :: forall a b. f (a -> b) -> f a -> f b
--
-- class (Apply f) <= Applicative f where
--   pure :: forall a. a -> f a
--
-- class (Apply m) <= Bind m where
--   bind :: forall a b. m a -> (a -> m b) -> m b
--
-- class (Applicative m, Bind m) <= Monad m
--
-- instance applicativeMaybe :: Applicative Maybe where
--   pure = Just
--
-- instance bindMaybe :: Bind Maybe where
--   bind (Just x) k = k x
--   bind Nothing  _ = Nothing
--
-- -- Right identity law
--
-- rightIdentity monad = do -- == monad
--   x <- monad
--   return x
--
-- rightIdentity2 Nothing = Nothing
-- rightIdentity2 Just a = Just a
--
-- -- Left identity law
--
-- leftIdentity next = do  -- == next
--   x <- return y
--   next
--
-- leftIdentity2 next = bind (Just a) (\x -> next) -- = next
--
--
-- -- Associativity law.
--
-- c1 = do
--   y <- do
--     x <- m1
--     m2
--   m3
-- c1' = bind (bind m1 m2) m3
--
-- c2 = do
--   x <- m1
--   y <- m2
--   m3
-- c2' = bind m1 (bind m2 m3)
--
-- -- c1 == c2
--
-- c3 = do
--   x <- m1
--   do
--     y <- m2
--     m3
--
-- c3' = bind m1 (bind m2  m3)
--
-- -- c1 == c2 == c3


imports

imports

module Example.FourPrime where

import Prelude
import Data.Either
import Data.Functor.Coproduct
import Data.Array (filter)
import Control.Plus (Plus)

import Halogen
import qualified Halogen.HTML.Indexed as H
import qualified Halogen.HTML.Events.Indexed as E

import qualified Example.CounterRemPrime as Counter
import qualified Example.RemGeneric as Rem
import Example.Two (CounterSlot(..))
import Example.Three (State(), addCounter, initialState)

data Input a = AddCounter a

listRemUI :: forall g p. (Functor g)
          => ParentComponentP State (Counter.State g p) Input Counter.Query g CounterSlot p
listRemUI = component' render eval peek
    where
        render :: Render State Input CounterSlot
        render state =
            H.div_ [ H.h1_ [ H.text "Counters" ]
                   , H.ul_ (map (H.slot <<< CounterSlot) state.counterArray)
                   , H.button [ E.onClick $ E.input_ AddCounter ]
                              [ H.text "Add Counter" ]
                   ]

        eval :: EvalP Input State _ Input _ g CounterSlot p
        eval (AddCounter next) = do
            modify addCounter
            pure next

        peek :: Peek State _ Input _ g CounterSlot p
        peek (ChildF counterSlot (Coproduct queryAction)) =
            case queryAction of
                 Left (Rem.Remove _) ->
                     modify (removeCounter counterSlot)
                 _ ->
                     pure unit

removeCounter :: CounterSlot -> State -> State
removeCounter (CounterSlot index) state =
    state { counterArray = filter (/= index) state.counterArray }

ui :: forall g p. (Plus g)
   => InstalledComponent State (Counter.State g p) Input Counter.Query g CounterSlot p
ui = install' listRemUI mkCounter
    where
        mkCounter (CounterSlot _) =
            createChild Counter.ui (installedState unit)

module Example.FourPrime where

import Prelude
import Data.Tuple
import Data.Either
import Data.Functor.Coproduct
import Data.Array
import Control.Plus (Plus)

import Halogen
import qualified Halogen.HTML.Indexed as H
import qualified Halogen.HTML.Events.Indexed as E

import qualified Example.CounterRemPrime as Counter
import qualified Example.RemGeneric as Rem
import Example.Two (CounterSlot(..))
import Example.Three (State(), addCounter, initialState)

data Input a = AddCounter a

listRemUI :: forall g p. (Functor g)
          => ParentComponentP State (Counter.State g p) Input Counter.Query g CounterSlot p
listRemUI = component' render eval peek
    where
        render :: Render State Input CounterSlot
        render state =
            H.div_ [ H.h1_ [ H.text "Counters" ]
                   , H.ul_ (map (H.slot <<< CounterSlot) state.counterArray)
                   , H.button [ E.onClick $ E.input_ AddCounter ]
                              [ H.text "Add Counter" ]
                   ]

        eval :: EvalP Input State _ Input _ g CounterSlot p
        eval (AddCounter next) = do
            modify addCounter
            pure next

        peek :: Peek State _ Input _ g CounterSlot p
        peek (ChildF counterSlot (Coproduct queryAction)) =
            case queryAction of
                 Left (Rem.Remove _) ->
                     modify (removeCounter counterSlot)
                 _ ->
                     pure unit

removeCounter :: CounterSlot -> State -> State
removeCounter (CounterSlot index) state =
    state { counterArray = filter (/= index) state.counterArray }

ui :: forall g p. (Plus g)
   => InstalledComponent State (Counter.State g p) Input Counter.Query g CounterSlot p
ui = install' listRemUI mkCounter
    where
        mkCounter (CounterSlot _) =
            createChild Counter.ui (installedState unit)


removed unused test module

removed unused test module

module Test.Main where

import Debug.Trace

main = do
  trace "You should add some tests."


Depth first

Depth first

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Draftboard.Pane
  ( Pane(..)
  , Locator(..)
  , Cursor
  , wrap
  , children
  , rootLocator
  , walkWithCursor
  , walkWithLocator
  , runCursorWithLocator
  , runCursor
  , getAt
  , getAtWithLocator
  , getValueAt
  , modifyAt
  , toList
  , traverseWithCursor
  , withCursor
  ) where

import SlamData.Prelude

import Data.List (List(..), (:))
import Data.List as List
import Data.Rational (Rational)

import SlamData.Workspace.Card.Draftboard.Orientation (Orientation(..))

data Pane a
  = Split Orientation (List (Rational × Pane a))
  | Cell a

data Locator
  = Locator Cursor Rational Rational Rational Rational Rational Rational
  --               x        y        width    height   offset   ratio

type Cursor = List Int

-- | Wraps a Pane in a Split.
wrap ∷ ∀ a. Orientation → Pane a → Pane a
wrap orn pane = Split orn (List.singleton (one × pane))

-- | Gets the immediate children of a Pane. Cells have no children.
children ∷ ∀ a. Pane a → List (Pane a)
children = case _ of
  Cell _ → List.Nil
  Split _ as → map snd as

-- | A root locator represents 100% of the available space.
rootLocator ∷ Locator
rootLocator = Locator Nil zero zero one one zero one

-- | Fold over every node with it's cursor
walkWithCursor
  ∷ ∀ a r
  . (Cursor → r → Pane a → r)
  → r
  → Pane a
  → r
walkWithCursor f = go Nil
  where
  go c acc p =
    case p of
      Cell a → f c acc p
      Split _ ps →
        goIx c 0 acc ps

  goIx c ix acc ps =
    case ps of
      Nil → acc
      (_ × p) : ps' →
        goIx c (ix + 1) (go (ix : c) acc p) ps'

-- | Fold over every node with it's location.
walkWithLocator
  ∷ ∀ a r
  . (Locator → r → Pane a → r)
  → r
  → Pane a
  → r
walkWithLocator f = go rootLocator
  where
  go loc@(Locator c x y w h _ _) acc p =
    let
      acc' =
        case p of
          Cell _ → acc
          Split orn ps →
            goIx x y w h zero 0 orn acc ps
    in
      f loc acc' p

    where
    goIx x y w h off ix orn acc ps =
      case ps of
        Nil → acc
        (r × p) : ps' →
          case orn of
            Horizontal →
              goIx (r * w + x) y w h (off + r) (ix + 1) orn
                (go (Locator (ix : c) x y (r * w) h off r) acc p) ps'
            Vertical →
              goIx x (r * h + y) w h (off + r) (ix + 1) orn
                (go (Locator (ix : c) x y w (r * h) off r) acc p) ps'

-- | Fold over a cursor (leaf to root).
runCursor
  ∷ ∀ a r
  . (Pane a → r)
  → (Orientation → List (Rational × Pane a) → Int → r → r)
  → Cursor
  → Pane a
  → Maybe r
runCursor f g = foldl go (Just ∘ f)
  where
  go h ix p =
    case p of
      Cell _ → Nothing
      Split orn ps → do
        p' ← snd <$> List.index ps ix
        g orn ps ix <$> h p'

-- | Fold over a cursor (leaf to root) with a location for each node.
runCursorWithLocator
  ∷ ∀ a r
  . (Locator → Pane a → r)
  → (Locator → Orientation → List (Rational × Pane a) → Int → r → r)
  → Cursor
  → Pane a
  → Maybe r
runCursorWithLocator f g = go rootLocator <<< List.reverse
  where
  go loc@(Locator c x y w h _ _) cursor pane =
    case cursor of
      Nil → Just (f loc pane)
      ix : cs →
        case pane of
          Cell a → Nothing
          Split orn ps →
            g loc orn ps ix <$> goIx zero 0 ix orn cs ps
    where
    goIx off i ix orn cs ps =
      case ps of
        (r × p) : ps' | i == ix →
          case orn of
            Horizontal →
              go (Locator (ix : c) (off * w + x) y (r * w) h off r) cs p
            Vertical →
              go (Locator (ix : c) x (off * h + y) w (r * h) off r) cs p
        (r × p) : ps' →
          goIx (off + r) (i + 1) ix orn cs ps'
        _ → Nothing

-- | Retrieves a Pane represented by a cursor.
getAt ∷ ∀ a . Cursor → Pane a → Maybe (Pane a)
getAt = runCursor id (\_ _ _ r → r)

getAtWithLocator ∷ ∀ a. Cursor → Pane a → Maybe (Locator × Pane a)
getAtWithLocator = runCursorWithLocator Tuple (\_ _ _ _ r → r)

-- | Retrieves a Cell value represented by a cursor. Splits have no value.
getValueAt ∷ ∀ a . Cursor → Pane a → Maybe a
getValueAt c p =
  getAt c p >>= case _ of
    Cell a → pure a
    _      → Nothing

-- | Modifies a Pane represented by a cursor.
modifyAt ∷ ∀ a. (Pane a → Pane a) → Cursor → Pane a → Maybe (Pane a)
modifyAt = flip runCursor go
  where
  go orn ps ix r =
    Split orn (fromMaybe ps (List.modifyAt ix (map (const r)) ps))

instance eqPane ∷ Eq a ⇒ Eq (Pane a) where
  eq (Cell a) (Cell b) = eq a b
  eq (Split orn1 ps1) (Split orn2 ps2) = eq orn1 orn2 && eq ps1 ps2
  eq _ _ = false

instance functorPane ∷ Functor Pane where
  map f (Cell a) = Cell (f a)
  map f (Split orn as) = Split orn (map (map (map f)) as)

instance foldablePane ∷ Foldable Pane where
  foldMap f (Cell a) = f a
  foldMap f (Split orn as) = foldMap (foldMap f <<< snd) as

  foldl f acc (Cell a) = f acc a
  foldl f acc (Split orn as) = foldl (\acc' p → foldl f acc' (snd p)) acc as

  foldr f acc (Cell a) = f a acc
  foldr f acc (Split orn as) = foldr (\p acc' → foldr f acc' (snd p)) acc as

instance traversablePane ∷ Traversable Pane where
  traverse f (Cell a) = Cell <$> f a
  traverse f (Split orn as) = Split orn <$> traverse (traverse (traverse f)) as

  sequence (Cell a) = Cell <$> a
  sequence (Split orn as) = Split orn <$> traverse (traverse sequence) as

toList ∷ ∀ a. Pane a → List a
toList = walkWithCursor go Nil
  where
  go _ r (Cell a) = a : r
  go _ r _ = r

traverseWithCursor
  ∷ ∀ f a b
  . Applicative f
  ⇒ (Cursor → a → f b)
  → Pane a
  → f (Pane b)
traverseWithCursor = go Nil
  where
  go c f (Cell a) = Cell <$> f c a
  go c f (Split orn as) = Split orn <$> sequence (goIx c f 0 Nil as)

  goIx c f i acc Nil = List.reverse acc
  goIx c f i acc (a : as) = goIx c f (i + 1) (traverse (go (i : c) f) a : acc) as

withCursor
  ∷ ∀ a
  . Pane a
  → List (Cursor × a)
withCursor = walkWithCursor go Nil
  where
  go c r (Cell a) = (c × a) : r
  go _ r _ = r

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Draftboard.Pane
  ( Pane(..)
  , Locator(..)
  , Cursor
  , wrap
  , children
  , rootLocator
  , walkWithCursor
  , walkWithLocator
  , runCursorWithLocator
  , runCursor
  , getAt
  , getAtWithLocator
  , getValueAt
  , modifyAt
  , toList
  , traverseWithCursor
  , withCursor
  ) where

import SlamData.Prelude

import Data.List (List(..), (:))
import Data.List as List
import Data.Rational (Rational)

import SlamData.Workspace.Card.Draftboard.Orientation (Orientation(..))

data Pane a
  = Split Orientation (List (Rational × Pane a))
  | Cell a

data Locator
  = Locator Cursor Rational Rational Rational Rational Rational Rational
  --               x        y        width    height   offset   ratio

type Cursor = List Int

-- | Wraps a Pane in a Split.
wrap ∷ ∀ a. Orientation → Pane a → Pane a
wrap orn pane = Split orn (List.singleton (one × pane))

-- | Gets the immediate children of a Pane. Cells have no children.
children ∷ ∀ a. Pane a → List (Pane a)
children = case _ of
  Cell _ → List.Nil
  Split _ as → map snd as

-- | A root locator represents 100% of the available space.
rootLocator ∷ Locator
rootLocator = Locator Nil zero zero one one zero one

-- | Fold over every node with it's cursor
walkWithCursor
  ∷ ∀ a r
  . (Cursor → r → Pane a → r)
  → r
  → Pane a
  → r
walkWithCursor f = go Nil
  where
  go c acc p =
    case p of
      Cell a → f c acc p
      Split _ ps →
        goIx c 0 acc ps

  goIx c ix acc ps =
    case ps of
      Nil → acc
      (_ × p) : ps' →
        goIx c (ix + 1) (go (ix : c) acc p) ps'

-- | Fold over every node with it's location.
walkWithLocator
  ∷ ∀ a r
  . (Locator → r → Pane a → r)
  → r
  → Pane a
  → r
walkWithLocator f = go rootLocator
  where
  go loc@(Locator c x y w h _ _) acc p =
    let acc' = f loc acc p in
    case p of
      Cell _ → acc'
      Split orn ps →
        goIx x y w h zero 0 orn acc' ps

    where
    goIx x y w h off ix orn acc ps =
      case ps of
        Nil → acc
        (r × p) : ps' →
          case orn of
            Horizontal →
              goIx (r * w + x) y w h (off + r) (ix + 1) orn
                (go (Locator (ix : c) x y (r * w) h off r) acc p) ps'
            Vertical →
              goIx x (r * h + y) w h (off + r) (ix + 1) orn
                (go (Locator (ix : c) x y w (r * h) off r) acc p) ps'

-- | Fold over a cursor (leaf to root).
runCursor
  ∷ ∀ a r
  . (Pane a → r)
  → (Orientation → List (Rational × Pane a) → Int → r → r)
  → Cursor
  → Pane a
  → Maybe r
runCursor f g = foldl go (Just ∘ f)
  where
  go h ix p =
    case p of
      Cell _ → Nothing
      Split orn ps → do
        p' ← snd <$> List.index ps ix
        g orn ps ix <$> h p'

-- | Fold over a cursor (leaf to root) with a location for each node.
runCursorWithLocator
  ∷ ∀ a r
  . (Locator → Pane a → r)
  → (Locator → Orientation → List (Rational × Pane a) → Int → r → r)
  → Cursor
  → Pane a
  → Maybe r
runCursorWithLocator f g = go rootLocator <<< List.reverse
  where
  go loc@(Locator c x y w h _ _) cursor pane =
    case cursor of
      Nil → Just (f loc pane)
      ix : cs →
        case pane of
          Cell a → Nothing
          Split orn ps →
            g loc orn ps ix <$> goIx zero 0 ix orn cs ps
    where
    goIx off i ix orn cs ps =
      case ps of
        (r × p) : ps' | i == ix →
          case orn of
            Horizontal →
              go (Locator (ix : c) (off * w + x) y (r * w) h off r) cs p
            Vertical →
              go (Locator (ix : c) x (off * h + y) w (r * h) off r) cs p
        (r × p) : ps' →
          goIx (off + r) (i + 1) ix orn cs ps'
        _ → Nothing

-- | Retrieves a Pane represented by a cursor.
getAt ∷ ∀ a . Cursor → Pane a → Maybe (Pane a)
getAt = runCursor id (\_ _ _ r → r)

getAtWithLocator ∷ ∀ a. Cursor → Pane a → Maybe (Locator × Pane a)
getAtWithLocator = runCursorWithLocator Tuple (\_ _ _ _ r → r)

-- | Retrieves a Cell value represented by a cursor. Splits have no value.
getValueAt ∷ ∀ a . Cursor → Pane a → Maybe a
getValueAt c p =
  getAt c p >>= case _ of
    Cell a → pure a
    _      → Nothing

-- | Modifies a Pane represented by a cursor.
modifyAt ∷ ∀ a. (Pane a → Pane a) → Cursor → Pane a → Maybe (Pane a)
modifyAt = flip runCursor go
  where
  go orn ps ix r =
    Split orn (fromMaybe ps (List.modifyAt ix (map (const r)) ps))

instance eqPane ∷ Eq a ⇒ Eq (Pane a) where
  eq (Cell a) (Cell b) = eq a b
  eq (Split orn1 ps1) (Split orn2 ps2) = eq orn1 orn2 && eq ps1 ps2
  eq _ _ = false

instance functorPane ∷ Functor Pane where
  map f (Cell a) = Cell (f a)
  map f (Split orn as) = Split orn (map (map (map f)) as)

instance foldablePane ∷ Foldable Pane where
  foldMap f (Cell a) = f a
  foldMap f (Split orn as) = foldMap (foldMap f <<< snd) as

  foldl f acc (Cell a) = f acc a
  foldl f acc (Split orn as) = foldl (\acc' p → foldl f acc' (snd p)) acc as

  foldr f acc (Cell a) = f a acc
  foldr f acc (Split orn as) = foldr (\p acc' → foldr f acc' (snd p)) acc as

instance traversablePane ∷ Traversable Pane where
  traverse f (Cell a) = Cell <$> f a
  traverse f (Split orn as) = Split orn <$> traverse (traverse (traverse f)) as

  sequence (Cell a) = Cell <$> a
  sequence (Split orn as) = Split orn <$> traverse (traverse sequence) as

toList ∷ ∀ a. Pane a → List a
toList = walkWithCursor go Nil
  where
  go _ r (Cell a) = a : r
  go _ r _ = r

traverseWithCursor
  ∷ ∀ f a b
  . Applicative f
  ⇒ (Cursor → a → f b)
  → Pane a
  → f (Pane b)
traverseWithCursor = go Nil
  where
  go c f (Cell a) = Cell <$> f c a
  go c f (Split orn as) = Split orn <$> sequence (goIx c f 0 Nil as)

  goIx c f i acc Nil = List.reverse acc
  goIx c f i acc (a : as) = goIx c f (i + 1) (traverse (go (i : c) f) a : acc) as

withCursor
  ∷ ∀ a
  . Pane a
  → List (Cursor × a)
withCursor = walkWithCursor go Nil
  where
  go c r (Cell a) = (c × a) : r
  go _ r _ = r


I'm an idiot sandwich

I'm an idiot sandwich

module Control.Monad.ST.Internal where

import Prelude

import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Partial.Unsafe (unsafePartial)

-- | `ST` is concerned with _restricted_ mutation. Mutation is restricted to a
-- | _region_ of mutable references. This kind is inhabited by phantom types
-- | which represent regions in the type system.
foreign import kind Region

-- | The `ST` type constructor allows _local mutation_, i.e. mutation which
-- | does not "escape" into the surrounding computation.
-- |
-- | An `ST` computation is parameterized by a phantom type which is used to
-- | restrict the set of reference cells it is allowed to access.
-- |
-- | The `run` function can be used to run a computation in the `ST` monad.
foreign import data ST :: Region -> Type -> Type

foreign import map_ :: forall r a b. (a -> b) -> ST r a -> ST r b

foreign import pure_ :: forall r a. a -> ST r a

foreign import bind_ :: forall r a b. ST r a -> (a -> ST r b) -> ST r b

instance functorST :: Functor (ST r) where
  map = map_

instance applyST :: Apply (ST r) where
  apply = ap

instance applicativeST :: Applicative (ST r) where
  pure = pure_

instance bindST :: Bind (ST r) where
  bind = bind_

instance monadST :: Monad (ST r)

instance monadRecST :: MonadRec (ST r) where
  tailRecM f a = do
    r <- new =<< f a
    while (isLooping <$> read r) do
      read r >>= case _ of
        Loop a' -> do
          e <- f a'
          void (write e r)
        Done b -> pure unit
    fromDone <$> read r
    where
      fromDone :: forall a b. Step a b -> b
      fromDone = unsafePartial \(Done b) -> b

      isLooping = case _ of
        Loop _ -> true
        _ -> false

-- | Run an `ST` computation.
-- |
-- | Note: the type of `run` uses a rank-2 type to constrain the phantom
-- | type `h`, such that the computation must not leak any mutable references
-- | to the surrounding computation. It may cause problems to apply this
-- | function using the `$` operator. The recommended approach is to use
-- | parentheses instead.
foreign import run :: forall a. (forall r. ST r a) -> a

-- | Loop while a condition is `true`.
-- |
-- | `while b m` is ST computation which runs the ST computation `b`. If its
-- | result is `true`, it runs the ST computation `m` and loops. If not, the
-- | computation ends.
foreign import while :: forall r a. ST r Boolean -> ST r a -> ST r Unit

-- | The type `STRef r a` represents a mutable reference holding a value of
-- | type `a`, which can be used with the `ST r` effect.
foreign import data STRef :: Region -> Type -> Type

-- | Create a new mutable reference.
foreign import new :: forall a r. a -> ST r (STRef r a)

-- | Read the current value of a mutable reference.
foreign import read :: forall a r. STRef r a -> ST r a

-- | Update the value of a mutable reference by applying a function
-- | to the current value, computing a new state value for the reference and
-- | a return value.
foreign import modify' :: forall r a b. (a -> { state :: a, value :: b }) -> STRef r a -> ST r b

-- | Modify the value of a mutable reference by applying a function to the
-- | current value.
modify :: forall r a. (a -> a) -> STRef r a -> ST r Unit
modify f = modify' (\s -> { state: f s, value: unit })

-- | Set the value of a mutable reference.
foreign import write :: forall a r. a -> STRef r a -> ST r a

module Control.Monad.ST.Internal where

import Prelude

import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Partial.Unsafe (unsafePartial)

-- | `ST` is concerned with _restricted_ mutation. Mutation is restricted to a
-- | _region_ of mutable references. This kind is inhabited by phantom types
-- | which represent regions in the type system.
foreign import kind Region

-- | The `ST` type constructor allows _local mutation_, i.e. mutation which
-- | does not "escape" into the surrounding computation.
-- |
-- | An `ST` computation is parameterized by a phantom type which is used to
-- | restrict the set of reference cells it is allowed to access.
-- |
-- | The `run` function can be used to run a computation in the `ST` monad.
foreign import data ST :: Region -> Type -> Type

foreign import map_ :: forall r a b. (a -> b) -> ST r a -> ST r b

foreign import pure_ :: forall r a. a -> ST r a

foreign import bind_ :: forall r a b. ST r a -> (a -> ST r b) -> ST r b

instance functorST :: Functor (ST r) where
  map = map_

instance applyST :: Apply (ST r) where
  apply = ap

instance applicativeST :: Applicative (ST r) where
  pure = pure_

instance bindST :: Bind (ST r) where
  bind = bind_

instance monadST :: Monad (ST r)

instance monadRecST :: MonadRec (ST r) where
  tailRecM f a = do
    r <- new =<< f a
    while (isDone <$> read r) do
      read r >>= case _ of
        Loop a' -> do
          e <- f a'
          void (write e r)
        Done b -> pure unit
    fromDone <$> read r
    where
      fromDone :: forall a b. Step a b -> b
      fromDone = unsafePartial \(Done b) -> b

      isDone = case _ of
        Done _ -> true
        _ -> false

-- | Run an `ST` computation.
-- |
-- | Note: the type of `run` uses a rank-2 type to constrain the phantom
-- | type `h`, such that the computation must not leak any mutable references
-- | to the surrounding computation. It may cause problems to apply this
-- | function using the `$` operator. The recommended approach is to use
-- | parentheses instead.
foreign import run :: forall a. (forall r. ST r a) -> a

-- | Loop while a condition is `true`.
-- |
-- | `while b m` is ST computation which runs the ST computation `b`. If its
-- | result is `true`, it runs the ST computation `m` and loops. If not, the
-- | computation ends.
foreign import while :: forall r a. ST r Boolean -> ST r a -> ST r Unit

-- | The type `STRef r a` represents a mutable reference holding a value of
-- | type `a`, which can be used with the `ST r` effect.
foreign import data STRef :: Region -> Type -> Type

-- | Create a new mutable reference.
foreign import new :: forall a r. a -> ST r (STRef r a)

-- | Read the current value of a mutable reference.
foreign import read :: forall a r. STRef r a -> ST r a

-- | Update the value of a mutable reference by applying a function
-- | to the current value, computing a new state value for the reference and
-- | a return value.
foreign import modify' :: forall r a b. (a -> { state :: a, value :: b }) -> STRef r a -> ST r b

-- | Modify the value of a mutable reference by applying a function to the
-- | current value.
modify :: forall r a. (a -> a) -> STRef r a -> ST r Unit
modify f = modify' (\s -> { state: f s, value: unit })

-- | Set the value of a mutable reference.
foreign import write :: forall a r. a -> STRef r a -> ST r a