Fix returned cellId for addCell' with parent cells

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Notebook.Component.State
  ( NotebookState()
  , CellDef()
  , CellConstructor()
  , DebounceTrigger()
  , initialNotebook
  , _fresh
  , _accessType
  , _cells
  , _dependencies
  , _activeCellId
  , _name
  , _isAddingCell
  , _browserFeatures
  , _viewingCell
  , _path
  , _saveTrigger
  , _globalVarMap
  , _runTrigger
  , addCell
  , addCell'
  , removeCells
  , findRoot
  , findParent
  , findChildren
  , findDescendants
  , addPendingCell
  , fromModel
  , notebookPath
  ) where

import Prelude

import Data.Array as A
import Data.Array.Unsafe as U
import Data.BrowserFeatures (BrowserFeatures())
import Data.Foldable (foldMap, foldr, maximum, any)
import Data.Lens (LensP(), lens)
import Data.List (List(..))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.Set as S
import Data.StrMap as SM
import Data.These (These(..), theseLeft)
import Data.Tuple (Tuple(..), fst)

import Halogen

import Model.AccessType (AccessType(..))
import Notebook.Cell.CellId (CellId(..), runCellId)
import Notebook.Cell.CellType (CellType(..), AceMode(..), linkedCellType)
import Notebook.Cell.Port.VarMap as Port
import Notebook.Cell.Model as Cell
import Notebook.Model as M

import Notebook.Component.Query (NotebookQuery())
import Notebook.Cell.Ace.Component (AceEvaluator(), aceComponent)
import Notebook.Cell.Chart.Component (chartComponent)
import Notebook.Cell.Component (CellComponent(), CellState(), CellStateP(), CellQueryP(), initEditorCellState, initResultsCellState)
import Notebook.Cell.Explore.Component (exploreComponent)
import Notebook.Cell.JTable.Component (jtableComponent)
import Notebook.Cell.Markdown.Component (markdownComponent)
import Notebook.Cell.Markdown.Eval (markdownEval)
import Notebook.Cell.Query.Eval (queryEval)
import Notebook.Cell.Search.Component (searchComponent)
import Notebook.Cell.Viz.Component (vizComponent)
import Notebook.Cell.API.Component (apiComponent)
import Notebook.Cell.APIResults.Component (apiResultsComponent)
import Notebook.CellSlot (CellSlot(..))
import Notebook.Common (Slam())

import Utils.Path as P

-- | The notebook state. See the corresponding lenses for descriptions of
-- | the fields.
type NotebookState =
  { fresh :: Int
  , accessType :: AccessType
  , cells :: List CellDef
  , dependencies :: M.Map CellId CellId
  , activeCellId :: Maybe CellId
  , name :: These P.DirName String
  , path :: Maybe P.DirPath
  , isAddingCell :: Boolean
  , browserFeatures :: BrowserFeatures
  , viewingCell :: Maybe CellId
  , saveTrigger :: Maybe (NotebookQuery Unit -> Slam Unit)
  , runTrigger :: Maybe DebounceTrigger
  , pendingCells :: S.Set CellId
  , globalVarMap :: Port.VarMap
  }

-- | A record used to represent cell definitions in the notebook.
type CellDef = { id :: CellId, ty :: CellType, ctor :: CellConstructor }

-- | The specific `SlotConstructor` type for cells in the notebook.
type CellConstructor = SlotConstructor CellStateP CellQueryP Slam CellSlot

-- | The type of functions used to trigger a debounced query.
type DebounceTrigger = NotebookQuery Unit -> Slam Unit

-- | Constructs a default `NotebookState` value.
initialNotebook :: BrowserFeatures -> NotebookState
initialNotebook browserFeatures =
  { fresh: 0
  , accessType: Editable
  , cells: mempty
  , dependencies: M.empty
  , activeCellId: Nothing
  , name: That Config.newNotebookName
  , isAddingCell: false
  , browserFeatures
  , viewingCell: Nothing
  , path: Nothing
  , saveTrigger: Nothing
  , globalVarMap: SM.empty
  , runTrigger: Nothing
  , pendingCells: S.empty
  }

-- | A counter used to generate `CellId` values.
_fresh :: LensP NotebookState Int
_fresh = lens _.fresh _{fresh = _}

-- | Determines whether the notebook is editable.
_accessType :: LensP NotebookState AccessType
_accessType = lens _.accessType _{accessType = _}

-- | The list of cells currently in the notebook.
_cells :: LensP NotebookState (List CellDef)
_cells = lens _.cells _{cells = _}

-- | A map of the edges in the dependency tree, where each key/value pair
-- | represents a child/parent relation.
_dependencies :: LensP NotebookState (M.Map CellId CellId)
_dependencies = lens _.dependencies _{dependencies = _}

-- | The `CellId` for the currently focused cell.
_activeCellId :: LensP NotebookState (Maybe CellId)
_activeCellId = lens _.activeCellId _{activeCellId = _}

-- | The current notebook name. When the value is `This` is has yet to be saved.
-- | When the value is `That` it has been saved. When the value is `Both` a new
-- | name has been entered but it has not yet been saved with the new name.
_name :: LensP NotebookState (These P.DirName String)
_name = lens _.name _{name = _}

-- | The path to the notebook in the filesystem
_path :: LensP NotebookState (Maybe P.DirPath)
_path = lens _.path _{path = _}

-- | Toggles the display of the new cell menu.
_isAddingCell :: LensP NotebookState Boolean
_isAddingCell = lens _.isAddingCell _{isAddingCell = _}

-- | The available browser features - passed through to markdown results cells
-- | as they need this information to render the output HTML.
_browserFeatures :: LensP NotebookState BrowserFeatures
_browserFeatures = lens _.browserFeatures _{browserFeatures = _}

-- | The currently focused cell when viewing an individual cell within a
-- | notebook.
_viewingCell :: LensP NotebookState (Maybe CellId)
_viewingCell = lens _.viewingCell _{viewingCell = _}

-- | The debounced trigger for notebook save actions.
_saveTrigger :: LensP NotebookState (Maybe DebounceTrigger)
_saveTrigger = lens _.saveTrigger _{saveTrigger = _}

_globalVarMap :: LensP NotebookState Port.VarMap
_globalVarMap = lens _.globalVarMap _{globalVarMap = _}

-- | The debounced trigger for running all cells that are pending.
_runTrigger :: LensP NotebookState (Maybe DebounceTrigger)
_runTrigger = lens _.runTrigger _{runTrigger = _}

-- | Adds a new cell to the notebook.
-- |
-- | Takes the current notebook state, the type of cell to add, and an optional
-- | parent cell ID.
addCell :: CellType -> Maybe CellId -> NotebookState -> NotebookState
addCell cellType parent st = fst $ addCellChain cellType (maybe [] pure parent) st

-- | Adds a new cell to the notebook.
-- |
-- | Takes the current notebook state, the type of cell to add, and an optional
-- | parent cell ID and returns the modified notebook state and the new cell ID.
addCell' :: CellType -> Maybe CellId -> NotebookState -> Tuple NotebookState CellId
addCell' cellType parent st =
  extractNewId <$> addCellChain cellType (maybe [] pure parent) st
  where
  extractNewId :: forall a. Array a -> a
  extractNewId = flip U.unsafeIndex (maybe 0 (const 1) parent)

addCellChain :: CellType -> Array CellId -> NotebookState -> Tuple NotebookState (Array CellId)
addCellChain cellType parents st =
  let cellId = CellId st.fresh
      parent = A.last parents
      parents' = parents `A.snoc` cellId
      newState = st
        { fresh = st.fresh + 1
        , cells = st.cells `L.snoc` mkCellDef cellType cellId
        , dependencies = maybe st.dependencies (flip (M.insert cellId) st.dependencies) parent
        , isAddingCell = false
        }
  in case linkedCellType cellType of
      Nothing -> Tuple newState parents'
      Just nextCellType -> addCellChain nextCellType parents' newState
  where

  mkCellDef :: CellType -> CellId -> CellDef
  mkCellDef cellType cellId =
    let component = cellTypeComponent cellType cellId st.browserFeatures
        initialState = installedState (cellTypeInitialState cellType) { accessType = st.accessType }
    in { id: cellId
       , ty: cellType
       , ctor: SlotConstructor (CellSlot cellId) \_ -> { component, initialState }
       }

cellTypeComponent :: CellType -> CellId -> BrowserFeatures -> CellComponent
cellTypeComponent (Ace at) _ _ = aceComponent at (aceEvalMode at)
cellTypeComponent Explore _ _ = exploreComponent
cellTypeComponent Search _ _ = searchComponent
cellTypeComponent Viz _ _ = vizComponent
cellTypeComponent Chart _ _ = chartComponent
cellTypeComponent Markdown cellId bf = markdownComponent cellId bf
cellTypeComponent JTable _ _ = jtableComponent
cellTypeComponent API _ _ = apiComponent
cellTypeComponent APIResults _ _ = apiResultsComponent

cellTypeInitialState :: CellType -> CellState
cellTypeInitialState (Ace SQLMode) = initEditorCellState { cachingEnabled = Just false }
cellTypeInitialState (Ace _) = initEditorCellState
cellTypeInitialState Explore = initEditorCellState
cellTypeInitialState Search = initEditorCellState { cachingEnabled = Just false }
cellTypeInitialState Viz = initEditorCellState
cellTypeInitialState Chart = initResultsCellState
cellTypeInitialState Markdown = initResultsCellState
cellTypeInitialState JTable = initResultsCellState
cellTypeInitialState API = initEditorCellState
cellTypeInitialState APIResults = initResultsCellState

aceEvalMode :: AceMode -> AceEvaluator
aceEvalMode MarkdownMode = markdownEval
aceEvalMode SQLMode = queryEval

-- | Removes a set of cells from the notebook. Any cells that depend on a cell
-- | in the set of provided cells will also be removed.
-- |
-- | Takes the set of IDs for the cells to remove and the current notebook
-- | state.
removeCells :: S.Set CellId -> NotebookState -> NotebookState
removeCells cellIds st = st
    { cells = L.filter f st.cells
    , dependencies = M.fromList $ L.filter g $ M.toList st.dependencies
    , pendingCells = S.difference st.pendingCells cellIds
    }
  where
  cellIds' :: S.Set CellId
  cellIds' = cellIds <> foldMap (flip findDescendants st) cellIds
  f :: CellDef -> Boolean
  f = not <<< flip S.member cellIds' <<< _.id
  g :: Tuple CellId CellId -> Boolean
  g (Tuple kId vId) = not $ S.member kId cellIds' || S.member vId cellIds'

-- | Finds the root in a chain of dependencies starting at the specified cell.
-- | A cell can be its own root if it depends on no other cells.
-- |
-- | Takes the ID of the cell to start searching from and the current notebook
-- | state.
findRoot :: CellId -> NotebookState -> CellId
findRoot cellId st = case findParent cellId st of
  Nothing -> cellId
  Just parentId -> findRoot parentId st

-- | Finds the parent of a cell. If the cell is a root it has no parent, and
-- | the result will be `Nothing`.
-- |
-- | Takes the ID of the cell to find the parent of and the current notebook
-- | state.
findParent :: CellId -> NotebookState -> Maybe CellId
findParent cellId st = M.lookup cellId st.dependencies

-- | Finds the immediate dependencies of a cell.
-- |
-- | Takes the ID of the cell to find the children of and the current notebook
-- | state.
findChildren :: CellId -> NotebookState -> S.Set CellId
findChildren parentId st =
  S.fromList $ map fst $ L.filter f $ M.toList st.dependencies
  where
  f :: Tuple CellId CellId -> Boolean
  f (Tuple _ cellId) = cellId == parentId

-- | Finds all the dependencies of a cell: the children, children's children,
-- | and so on until the leaves of the tree are reached.
-- |
-- | Takes the ID of the cell to find the descendants of and the current
-- | notebook state.
findDescendants :: CellId -> NotebookState -> S.Set CellId
findDescendants cellId st =
  let children = findChildren cellId st
  in children <> foldMap (flip findDescendants st) children

-- | Adds a cell to the set of cells that are enqueued to run.
-- |
-- | If the cell is a descendant of an cell that has already been enqueued this
-- | will have no effect, as in this case the cell is already pending by
-- | implication: all cells under the queued ancestor will be evaluated as
-- | changes propagate through the subgraph.
-- |
-- | If the cell is an ancestor of cells that have already been enqueued they
-- | will be removed when this cell is added, for the same reasoning as above.
addPendingCell :: CellId -> NotebookState -> NotebookState
addPendingCell cellId st@{ pendingCells } =
  if cellId `S.member` pendingCells || any isAncestor pendingCells
  then st
  else st { pendingCells = S.insert cellId (removeDescendants pendingCells) }
  where
  isAncestor :: CellId -> Boolean
  isAncestor otherId = cellId `S.member` findDescendants otherId st
  removeDescendants :: S.Set CellId -> S.Set CellId
  removeDescendants = flip S.difference (findDescendants cellId st)

-- | Finds the current notebook path, if the notebook has been saved.
notebookPath :: NotebookState -> Maybe P.DirPath
notebookPath state = do
  path <- state.path
  name <- theseLeft state.name
  pure $ path </> P.dir' name

-- | Reconstructs a notebook state from a notebook model.
fromModel
  :: BrowserFeatures
  -> Maybe P.DirPath
  -> Maybe P.DirName
  -> M.Notebook
  -> Tuple (Array Cell.Model) NotebookState
fromModel browserFeatures path name { cells, dependencies } =
  Tuple
    cells
    ({ fresh: maybe 0 (+ 1) $ maximum $ map (runCellId <<< _.cellId) cells
    , accessType: ReadOnly
    , cells: foldr (Cons <<< cellDefFromModel) Nil cells
    , dependencies
    , activeCellId: Nothing
    , name: maybe (That Config.newNotebookName) This name
    , isAddingCell: false
    , browserFeatures
    , viewingCell: Nothing
    , path
    , saveTrigger: Nothing
    , globalVarMap: SM.empty
    , runTrigger: Nothing
    , pendingCells: S.empty
    } :: NotebookState)
  where
  cellDefFromModel :: Cell.Model -> CellDef
  cellDefFromModel { cellId, cellType } =
    let component = cellTypeComponent cellType cellId browserFeatures
        initialState = installedState (cellTypeInitialState cellType)
    in { id: cellId
       , ty: cellType
       , ctor: SlotConstructor (CellSlot cellId) \_ -> { component, initialState }
       }

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Notebook.Component.State
  ( NotebookState()
  , CellDef()
  , CellConstructor()
  , DebounceTrigger()
  , initialNotebook
  , _fresh
  , _accessType
  , _cells
  , _dependencies
  , _activeCellId
  , _name
  , _isAddingCell
  , _browserFeatures
  , _viewingCell
  , _path
  , _saveTrigger
  , _globalVarMap
  , _runTrigger
  , addCell
  , addCell'
  , removeCells
  , findRoot
  , findParent
  , findChildren
  , findDescendants
  , addPendingCell
  , fromModel
  , notebookPath
  ) where

import Prelude

import Data.Array as A
import Data.Array.Unsafe as U
import Data.BrowserFeatures (BrowserFeatures())
import Data.Foldable (foldMap, foldr, maximum, any)
import Data.Lens (LensP(), lens)
import Data.List (List(..))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.Set as S
import Data.StrMap as SM
import Data.These (These(..), theseLeft)
import Data.Tuple (Tuple(..), fst)

import Halogen

import Model.AccessType (AccessType(..))
import Notebook.Cell.CellId (CellId(..), runCellId)
import Notebook.Cell.CellType (CellType(..), AceMode(..), linkedCellType)
import Notebook.Cell.Port.VarMap as Port
import Notebook.Cell.Model as Cell
import Notebook.Model as M

import Notebook.Component.Query (NotebookQuery())
import Notebook.Cell.Ace.Component (AceEvaluator(), aceComponent)
import Notebook.Cell.Chart.Component (chartComponent)
import Notebook.Cell.Component (CellComponent(), CellState(), CellStateP(), CellQueryP(), initEditorCellState, initResultsCellState)
import Notebook.Cell.Explore.Component (exploreComponent)
import Notebook.Cell.JTable.Component (jtableComponent)
import Notebook.Cell.Markdown.Component (markdownComponent)
import Notebook.Cell.Markdown.Eval (markdownEval)
import Notebook.Cell.Query.Eval (queryEval)
import Notebook.Cell.Search.Component (searchComponent)
import Notebook.Cell.Viz.Component (vizComponent)
import Notebook.Cell.API.Component (apiComponent)
import Notebook.Cell.APIResults.Component (apiResultsComponent)
import Notebook.CellSlot (CellSlot(..))
import Notebook.Common (Slam())

import Utils.Path as P

-- | The notebook state. See the corresponding lenses for descriptions of
-- | the fields.
type NotebookState =
  { fresh :: Int
  , accessType :: AccessType
  , cells :: List CellDef
  , dependencies :: M.Map CellId CellId
  , activeCellId :: Maybe CellId
  , name :: These P.DirName String
  , path :: Maybe P.DirPath
  , isAddingCell :: Boolean
  , browserFeatures :: BrowserFeatures
  , viewingCell :: Maybe CellId
  , saveTrigger :: Maybe (NotebookQuery Unit -> Slam Unit)
  , runTrigger :: Maybe DebounceTrigger
  , pendingCells :: S.Set CellId
  , globalVarMap :: Port.VarMap
  }

-- | A record used to represent cell definitions in the notebook.
type CellDef = { id :: CellId, ty :: CellType, ctor :: CellConstructor }

-- | The specific `SlotConstructor` type for cells in the notebook.
type CellConstructor = SlotConstructor CellStateP CellQueryP Slam CellSlot

-- | The type of functions used to trigger a debounced query.
type DebounceTrigger = NotebookQuery Unit -> Slam Unit

-- | Constructs a default `NotebookState` value.
initialNotebook :: BrowserFeatures -> NotebookState
initialNotebook browserFeatures =
  { fresh: 0
  , accessType: Editable
  , cells: mempty
  , dependencies: M.empty
  , activeCellId: Nothing
  , name: That Config.newNotebookName
  , isAddingCell: false
  , browserFeatures
  , viewingCell: Nothing
  , path: Nothing
  , saveTrigger: Nothing
  , globalVarMap: SM.empty
  , runTrigger: Nothing
  , pendingCells: S.empty
  }

-- | A counter used to generate `CellId` values.
_fresh :: LensP NotebookState Int
_fresh = lens _.fresh _{fresh = _}

-- | Determines whether the notebook is editable.
_accessType :: LensP NotebookState AccessType
_accessType = lens _.accessType _{accessType = _}

-- | The list of cells currently in the notebook.
_cells :: LensP NotebookState (List CellDef)
_cells = lens _.cells _{cells = _}

-- | A map of the edges in the dependency tree, where each key/value pair
-- | represents a child/parent relation.
_dependencies :: LensP NotebookState (M.Map CellId CellId)
_dependencies = lens _.dependencies _{dependencies = _}

-- | The `CellId` for the currently focused cell.
_activeCellId :: LensP NotebookState (Maybe CellId)
_activeCellId = lens _.activeCellId _{activeCellId = _}

-- | The current notebook name. When the value is `This` is has yet to be saved.
-- | When the value is `That` it has been saved. When the value is `Both` a new
-- | name has been entered but it has not yet been saved with the new name.
_name :: LensP NotebookState (These P.DirName String)
_name = lens _.name _{name = _}

-- | The path to the notebook in the filesystem
_path :: LensP NotebookState (Maybe P.DirPath)
_path = lens _.path _{path = _}

-- | Toggles the display of the new cell menu.
_isAddingCell :: LensP NotebookState Boolean
_isAddingCell = lens _.isAddingCell _{isAddingCell = _}

-- | The available browser features - passed through to markdown results cells
-- | as they need this information to render the output HTML.
_browserFeatures :: LensP NotebookState BrowserFeatures
_browserFeatures = lens _.browserFeatures _{browserFeatures = _}

-- | The currently focused cell when viewing an individual cell within a
-- | notebook.
_viewingCell :: LensP NotebookState (Maybe CellId)
_viewingCell = lens _.viewingCell _{viewingCell = _}

-- | The debounced trigger for notebook save actions.
_saveTrigger :: LensP NotebookState (Maybe DebounceTrigger)
_saveTrigger = lens _.saveTrigger _{saveTrigger = _}

_globalVarMap :: LensP NotebookState Port.VarMap
_globalVarMap = lens _.globalVarMap _{globalVarMap = _}

-- | The debounced trigger for running all cells that are pending.
_runTrigger :: LensP NotebookState (Maybe DebounceTrigger)
_runTrigger = lens _.runTrigger _{runTrigger = _}

-- | Adds a new cell to the notebook.
-- |
-- | Takes the current notebook state, the type of cell to add, and an optional
-- | parent cell ID.
addCell :: CellType -> Maybe CellId -> NotebookState -> NotebookState
addCell cellType parent st = fst $ addCellChain cellType (maybe [] pure parent) st

-- | Adds a new cell to the notebook.
-- |
-- | Takes the current notebook state, the type of cell to add, and an optional
-- | parent cell ID and returns the modified notebook state and the new cell ID.
addCell' :: CellType -> Maybe CellId -> NotebookState -> Tuple NotebookState CellId
addCell' cellType parent st =
  U.head <$> addCellChain cellType (maybe [] pure parent) st

addCellChain :: CellType -> Array CellId -> NotebookState -> Tuple NotebookState (Array CellId)
addCellChain cellType parents st =
  let cellId = CellId st.fresh
      parent = A.last parents
      parents' = parents `A.snoc` cellId
      newState = st
        { fresh = st.fresh + 1
        , cells = st.cells `L.snoc` mkCellDef cellType cellId
        , dependencies = maybe st.dependencies (flip (M.insert cellId) st.dependencies) parent
        , isAddingCell = false
        }
  in case linkedCellType cellType of
      Nothing -> Tuple newState parents'
      Just nextCellType -> addCellChain nextCellType parents' newState
  where

  mkCellDef :: CellType -> CellId -> CellDef
  mkCellDef cellType cellId =
    let component = cellTypeComponent cellType cellId st.browserFeatures
        initialState = installedState (cellTypeInitialState cellType) { accessType = st.accessType }
    in { id: cellId
       , ty: cellType
       , ctor: SlotConstructor (CellSlot cellId) \_ -> { component, initialState }
       }

cellTypeComponent :: CellType -> CellId -> BrowserFeatures -> CellComponent
cellTypeComponent (Ace at) _ _ = aceComponent at (aceEvalMode at)
cellTypeComponent Explore _ _ = exploreComponent
cellTypeComponent Search _ _ = searchComponent
cellTypeComponent Viz _ _ = vizComponent
cellTypeComponent Chart _ _ = chartComponent
cellTypeComponent Markdown cellId bf = markdownComponent cellId bf
cellTypeComponent JTable _ _ = jtableComponent
cellTypeComponent API _ _ = apiComponent
cellTypeComponent APIResults _ _ = apiResultsComponent

cellTypeInitialState :: CellType -> CellState
cellTypeInitialState (Ace SQLMode) = initEditorCellState { cachingEnabled = Just false }
cellTypeInitialState (Ace _) = initEditorCellState
cellTypeInitialState Explore = initEditorCellState
cellTypeInitialState Search = initEditorCellState { cachingEnabled = Just false }
cellTypeInitialState Viz = initEditorCellState
cellTypeInitialState Chart = initResultsCellState
cellTypeInitialState Markdown = initResultsCellState
cellTypeInitialState JTable = initResultsCellState
cellTypeInitialState API = initEditorCellState
cellTypeInitialState APIResults = initResultsCellState

aceEvalMode :: AceMode -> AceEvaluator
aceEvalMode MarkdownMode = markdownEval
aceEvalMode SQLMode = queryEval

-- | Removes a set of cells from the notebook. Any cells that depend on a cell
-- | in the set of provided cells will also be removed.
-- |
-- | Takes the set of IDs for the cells to remove and the current notebook
-- | state.
removeCells :: S.Set CellId -> NotebookState -> NotebookState
removeCells cellIds st = st
    { cells = L.filter f st.cells
    , dependencies = M.fromList $ L.filter g $ M.toList st.dependencies
    , pendingCells = S.difference st.pendingCells cellIds
    }
  where
  cellIds' :: S.Set CellId
  cellIds' = cellIds <> foldMap (flip findDescendants st) cellIds
  f :: CellDef -> Boolean
  f = not <<< flip S.member cellIds' <<< _.id
  g :: Tuple CellId CellId -> Boolean
  g (Tuple kId vId) = not $ S.member kId cellIds' || S.member vId cellIds'

-- | Finds the root in a chain of dependencies starting at the specified cell.
-- | A cell can be its own root if it depends on no other cells.
-- |
-- | Takes the ID of the cell to start searching from and the current notebook
-- | state.
findRoot :: CellId -> NotebookState -> CellId
findRoot cellId st = case findParent cellId st of
  Nothing -> cellId
  Just parentId -> findRoot parentId st

-- | Finds the parent of a cell. If the cell is a root it has no parent, and
-- | the result will be `Nothing`.
-- |
-- | Takes the ID of the cell to find the parent of and the current notebook
-- | state.
findParent :: CellId -> NotebookState -> Maybe CellId
findParent cellId st = M.lookup cellId st.dependencies

-- | Finds the immediate dependencies of a cell.
-- |
-- | Takes the ID of the cell to find the children of and the current notebook
-- | state.
findChildren :: CellId -> NotebookState -> S.Set CellId
findChildren parentId st =
  S.fromList $ map fst $ L.filter f $ M.toList st.dependencies
  where
  f :: Tuple CellId CellId -> Boolean
  f (Tuple _ cellId) = cellId == parentId

-- | Finds all the dependencies of a cell: the children, children's children,
-- | and so on until the leaves of the tree are reached.
-- |
-- | Takes the ID of the cell to find the descendants of and the current
-- | notebook state.
findDescendants :: CellId -> NotebookState -> S.Set CellId
findDescendants cellId st =
  let children = findChildren cellId st
  in children <> foldMap (flip findDescendants st) children

-- | Adds a cell to the set of cells that are enqueued to run.
-- |
-- | If the cell is a descendant of an cell that has already been enqueued this
-- | will have no effect, as in this case the cell is already pending by
-- | implication: all cells under the queued ancestor will be evaluated as
-- | changes propagate through the subgraph.
-- |
-- | If the cell is an ancestor of cells that have already been enqueued they
-- | will be removed when this cell is added, for the same reasoning as above.
addPendingCell :: CellId -> NotebookState -> NotebookState
addPendingCell cellId st@{ pendingCells } =
  if cellId `S.member` pendingCells || any isAncestor pendingCells
  then st
  else st { pendingCells = S.insert cellId (removeDescendants pendingCells) }
  where
  isAncestor :: CellId -> Boolean
  isAncestor otherId = cellId `S.member` findDescendants otherId st
  removeDescendants :: S.Set CellId -> S.Set CellId
  removeDescendants = flip S.difference (findDescendants cellId st)

-- | Finds the current notebook path, if the notebook has been saved.
notebookPath :: NotebookState -> Maybe P.DirPath
notebookPath state = do
  path <- state.path
  name <- theseLeft state.name
  pure $ path </> P.dir' name

-- | Reconstructs a notebook state from a notebook model.
fromModel
  :: BrowserFeatures
  -> Maybe P.DirPath
  -> Maybe P.DirName
  -> M.Notebook
  -> Tuple (Array Cell.Model) NotebookState
fromModel browserFeatures path name { cells, dependencies } =
  Tuple
    cells
    ({ fresh: maybe 0 runCellId $ (map (+ one) <<< maximum) $ map _.cellId cells
    , accessType: ReadOnly
    , cells: foldr (Cons <<< cellDefFromModel) Nil cells
    , dependencies
    , activeCellId: Nothing
    , name: maybe (That Config.newNotebookName) This name
    , isAddingCell: false
    , browserFeatures
    , viewingCell: Nothing
    , path
    , saveTrigger: Nothing
    , globalVarMap: SM.empty
    , runTrigger: Nothing
    , pendingCells: S.empty
    } :: NotebookState)
  where
  cellDefFromModel :: Cell.Model -> CellDef
  cellDefFromModel { cellId, cellType } =
    let component = cellTypeComponent cellType cellId browserFeatures
        initialState = installedState (cellTypeInitialState cellType)
    in { id: cellId
       , ty: cellType
       , ctor: SlotConstructor (CellSlot cellId) \_ -> { component, initialState }
       }


upgrade to purescript 0.9.1

upgrade to purescript 0.9.1

module Examples.MotionStretch where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console
import Control.Monad.Eff.Ref
import DOM
import Graphics.Three.Renderer    as Renderer
import Graphics.Three.Scene       as Scene
import Graphics.Three.Material    as Material
import Graphics.Three.Geometry    as Geometry
import Graphics.Three.Camera      as Camera
import Graphics.Three.Object3D    as Object3D
import Graphics.Three.Math.Vector as Vector
import Graphics.Three.Types
import Math (pi)

import Examples.Common

radius = 40.0

initUniforms ::  { delta :: { "type" :: String, value :: Vector.Vector3 }
                 , radius :: { "type" :: String, value :: Number }
                 , drag :: { "type" :: String, value :: Number }
                 }
initUniforms = {
        delta: {
             "type": "v3"
            , value: Vector.createVec3 0.0 0.0 0.0
        },
        radius: {
             "type" : "f"
            , value : radius
        },
        drag: {
             "type" : "f"
            , value : 0.33
        }
    }

vertexShader :: String
vertexShader = """
    #ifdef GL_ES
    precision highp float;
    #endif

    uniform vec3 delta;
    uniform float radius;
    uniform float drag;

    void main() {
        vec3 pos = position;
        float p = distance(position, delta) / radius;

        vec3 temp = delta * p;
        pos += (position - temp) * drag;

        gl_Position = projectionMatrix * modelViewMatrix * vec4(pos, 1.0);
    }
"""

fragmentShader :: String
fragmentShader = """
    #ifdef GL_ES
    precision highp float;
    #endif

    void main() {
        gl_FragColor = vec4(1.0,0.0,0.0,1.0);
    }
"""

shapeMotion :: Object3D.Mesh -> Number -> Pos -> Pos -> ThreeEff Unit
shapeMotion me f (Pos p1) (Pos p2) = do
    mat <- Object3D.getMaterial me

    Object3D.setPosition me p1.x p1.y 0.0
    Material.setUniform mat "delta" $ Vector.createVec3 dx dy 0.0

    pure unit
    where
        dx = p2.x - p1.x
        dy = p2.y - p1.y

render :: forall eff. Ref StateRef -> Context -> Object3D.Mesh ->
                 Eff ( trace :: CONSOLE, ref :: REF, three :: Three | eff) Unit
render state context me = do

    modifyRef state $ \(StateRef s) -> stateRef (s.frame + 1.0) s.pos s.prev
    s'@(StateRef s) <- readRef state

    shapeMotion me s.frame s.pos s.prev

    renderContext context

onMouseMove :: forall eff. Context -> Ref StateRef -> Event -> Eff (three :: Three, ref :: REF, trace :: CONSOLE, dom :: DOM | eff) Unit
onMouseMove (Context c) state e = do
    canvas <- getElementsByTagName "canvas"
    dims   <- nodeDimensions canvas

    let x =  e.x - (dims.width / 2.0)
        y = -e.y + (dims.height / 2.0)

    modifyRef state $ \(StateRef s) ->
        stateRef s.frame (pos x y) s.pos

    pure unit

main :: forall eff.Eff(trace :: CONSOLE, dom :: DOM, three :: Three, ref :: REF | eff) Unit
main = do
    ctx@(Context c) <- initContext Camera.Orthographic
    state           <- newRef initStateRef
    material        <- Material.createShader {
                            uniforms: initUniforms
                            , vertexShader:   vertexShader
                            , fragmentShader: fragmentShader
                        }
    circle          <- Geometry.createCircle radius 32.0 0.0 (2.0 * pi)
    mesh            <- Object3D.createMesh circle material

    Scene.addObject c.scene mesh

    canvas <- getElementsByTagName "canvas"
    addEventListener canvas "mousemove" $ onMouseMove ctx state

    doAnimation $ render state ctx mesh

module Examples.MotionStretch where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.Eff.Ref
import DOM
import Graphics.Three.Renderer    as Renderer
import Graphics.Three.Scene       as Scene
import Graphics.Three.Material    as Material
import Graphics.Three.Geometry    as Geometry
import Graphics.Three.Camera      as Camera
import Graphics.Three.Object3D    as Object3D
import Graphics.Three.Math.Vector as Vector
import Graphics.Three.Types
import Math (pi)

import Examples.Common

radius = 40.0

initUniforms = {
        delta: {
             "type": "v3"
            , value: Vector.createVec3 0.0 0.0 0.0
        },
        radius: {
             "type" : "f"
            , value : radius
        },
        drag: {
             "type" : "f"
            , value : 0.33
        }
    }

vertexShader :: String
vertexShader = """
    #ifdef GL_ES
    precision highp float;
    #endif

    uniform vec3 delta;
    uniform float radius;
    uniform float drag;

    void main() {
        vec3 pos = position;
        float p = distance(position, delta) / radius;

        vec3 temp = delta * p;
        pos += (position - temp) * drag;

        gl_Position = projectionMatrix * modelViewMatrix * vec4(pos, 1.0);
    }
"""

fragmentShader :: String
fragmentShader = """
    #ifdef GL_ES
    precision highp float;
    #endif

    void main() {
        gl_FragColor = vec4(1.0,0.0,0.0,1.0);
    }
"""

shapeMotion :: Object3D.Mesh -> Number -> Pos -> Pos -> ThreeEff Unit
shapeMotion me f (Pos p1) (Pos p2) = do
    mat <- Object3D.getMaterial me

    Object3D.setPosition me p1.x p1.y 0.0
    Material.setUniform mat "delta" $ Vector.createVec3 dx dy 0.0

    pure unit
    where
        dx = p2.x - p1.x
        dy = p2.y - p1.y

render :: forall eff. Ref StateRef -> Context -> Object3D.Mesh ->
                 Eff ( trace :: CONSOLE, ref :: REF, three :: Three | eff) Unit
render state context me = do

    modifyRef state $ \(StateRef s) -> stateRef (s.frame + 1.0) s.pos s.prev
    s'@(StateRef s) <- readRef state

    shapeMotion me s.frame s.pos s.prev

    renderContext context

onMouseMove :: forall eff. Context -> Ref StateRef -> Event -> Eff (three :: Three, ref :: REF, trace :: CONSOLE, dom :: DOM | eff) Unit
onMouseMove (Context c) state e = do
    canvas <- getElementsByTagName "canvas"
    dims   <- nodeDimensions canvas

    let x =  e.x - (dims.width / 2.0)
        y = -e.y + (dims.height / 2.0)

    modifyRef state $ \(StateRef s) ->
        stateRef s.frame (pos x y) s.pos

    pure unit

main = do
    ctx@(Context c) <- initContext Camera.Orthographic
    state           <- newRef initStateRef
    material        <- Material.createShader {
                            uniforms: initUniforms
                            , vertexShader:   vertexShader
                            , fragmentShader: fragmentShader
                        }
    circle          <- Geometry.createCircle radius 32.0 0.0 (2.0 * pi)
    mesh            <- Object3D.createMesh circle material

    Scene.addObject c.scene mesh

    canvas <- getElementsByTagName "canvas"
    addEventListener canvas "mousemove" $ onMouseMove ctx state

    doAnimation $ render state ctx mesh


Rename fixture

Rename fixture

module Main where

import Data.Array
import Test.Spec
import Test.Spec.Node
import Test.Spec.Assertions
import qualified Test.Spec.Reporter as R

successTest =
  describe "a" do
    describe "b" do
      it "works" do
        1 `shouldEqual` 1

sharedDescribeTest =
  describe "a" do
    describe "b" do
      it "works" do
        1 `shouldEqual` 1
    describe "c" do
      it "also works" do
        1 `shouldEqual` 1

main = runNode $
  describe "Test" do
    describe "Spec" do
      describe "Runner" do
        it "collects \"it\" and \"pending\" in Describe groups" do
          results <- collect successTest
          results `shouldEqual` [Describe "a" [Describe "b" [It "works" Success]]]
        it "collects \"it\" and \"pending\" with shared Describes" do
          results <- collect sharedDescribeTest
          results `shouldEqual` [Describe "a" [Describe "b" [It "works" Success],
                                               Describe "c" [It "also works" Success]]]
      describe "Reporter" do
        it "collapses groups into entries with names" do
          results <- collect successTest
          concatMap R.collapse results `shouldEqual` [
              R.Describe ["a", "b"],
              R.It "works" Success
            ]
        it "collapses groups into entries with shared describes" do
          results <- collect sharedDescribeTest
          concatMap R.collapse results `shouldEqual` [
              R.Describe ["a", "b"],
              R.It "works" Success,
              R.Describe ["a", "c"],
              R.It "also works" Success
            ]
        pending "reports errors"
        pending "reports pending"

module Main where

import Data.Array
import Test.Spec
import Test.Spec.Node
import Test.Spec.Assertions
import qualified Test.Spec.Reporter as R

successTest =
  describe "a" do
    describe "b" do
      it "works" do
        1 `shouldEqual` 1

successSharedDescribeTest =
  describe "a" do
    describe "b" do
      it "works" do
        1 `shouldEqual` 1
    describe "c" do
      it "also works" do
        1 `shouldEqual` 1

main = runNode $
  describe "Test" do
    describe "Spec" do
      describe "Runner" do
        it "collects \"it\" and \"pending\" in Describe groups" do
          results <- collect successTest
          results `shouldEqual` [Describe "a" [Describe "b" [It "works" Success]]]
        it "collects \"it\" and \"pending\" with shared Describes" do
          results <- collect successSharedDescribeTest
          results `shouldEqual` [Describe "a" [Describe "b" [It "works" Success],
                                               Describe "c" [It "also works" Success]]]
      describe "Reporter" do
        it "collapses groups into entries with names" do
          results <- collect successTest
          concatMap R.collapse results `shouldEqual` [
              R.Describe ["a", "b"],
              R.It "works" Success
            ]
        it "collapses groups into entries with shared describes" do
          results <- collect successSharedDescribeTest
          concatMap R.collapse results `shouldEqual` [
              R.Describe ["a", "b"],
              R.It "works" Success,
              R.Describe ["a", "c"],
              R.It "also works" Success
            ]
        pending "reports errors"
        pending "reports pending"


Update tests

Update tests

module Test.Main where

import Prelude

import Data.Either (Either(..))
import Node.Buffer as Buffer
import Node.Encoding
import Node.Stream
import Node.Stream.StdIO

import Control.Monad.Eff
import Control.Monad.Eff.Console

import Test.Assert

assertEqual :: forall e a. (Show a, Eq a) => a -> a -> Eff (assert :: ASSERT | e) Unit
assertEqual x y =
  assert' (show x <> " did not equal " <> show y) (x == y)

foreign import data STREAM_BUFFER :: !

foreign import writableStreamBuffer :: forall eff. Eff (sb :: STREAM_BUFFER | eff) (Writable () (sb :: STREAM_BUFFER | eff))

foreign import getContentsAsString :: forall r eff. Writable r (sb :: STREAM_BUFFER | eff) -> Eff (sb :: STREAM_BUFFER | eff) String

foreign import readableStreamBuffer :: forall eff. Eff (sb :: STREAM_BUFFER | eff) (Readable () (sb :: STREAM_BUFFER | eff))

foreign import putImpl :: forall r eff. String -> String -> Readable r (sb :: STREAM_BUFFER | eff) -> Eff (sb :: STREAM_BUFFER | eff) Unit

put :: forall r eff. String -> Encoding -> Readable r (sb :: STREAM_BUFFER | eff) -> Eff (sb :: STREAM_BUFFER | eff) Unit
put str enc = putImpl str (show enc)

main = do
  log "setDefaultEncoding should not affect writing"
  testSetDefaultEncoding

  log "setEncoding should not affect reading"
  testSetEncoding

testString :: String
testString = "üöß💡"

testSetDefaultEncoding = do
  w1 <- writableStreamBuffer
  check w1

  w2 <- writableStreamBuffer
  setDefaultEncoding w2 UCS2
  check w2

  where
  check w = do
    writeString w UTF8 testString do
      c <- getContentsAsString w
      assertEqual testString c

testSetEncoding = do
  check UTF8
  check UTF16LE
  check UCS2
  where
  check enc = do
    r1 <- readableStreamBuffer
    put testString enc r1

    r2 <- readableStreamBuffer
    put testString enc r2
    setEncoding r2 enc

    onData r1 \buf -> do
      onDataEither r2 \(Left str) -> do
        assertEqual <$> Buffer.toString UTF8 buf <*> pure testString
        assertEqual str testString

module Test.Main where

import Prelude

import Node.Buffer as Buffer
import Node.Encoding
import Node.Stream
import Node.Stream.StdIO

import Control.Monad.Eff
import Control.Monad.Eff.Console

import Test.Assert

assertEqual :: forall e a. (Show a, Eq a) => a -> a -> Eff (assert :: ASSERT | e) Unit
assertEqual x y =
  assert' (show x <> " did not equal " <> show y) (x == y)

foreign import data STREAM_BUFFER :: !

foreign import writableStreamBuffer :: forall eff. Eff (sb :: STREAM_BUFFER | eff) (Writable () (sb :: STREAM_BUFFER | eff))

foreign import getContentsAsString :: forall r eff. Writable r (sb :: STREAM_BUFFER | eff) -> Eff (sb :: STREAM_BUFFER | eff) String

foreign import readableStreamBuffer :: forall eff. Eff (sb :: STREAM_BUFFER | eff) (Readable () (sb :: STREAM_BUFFER | eff))

foreign import putImpl :: forall r eff. String -> String -> Readable r (sb :: STREAM_BUFFER | eff) -> Eff (sb :: STREAM_BUFFER | eff) Unit

put :: forall r eff. String -> Encoding -> Readable r (sb :: STREAM_BUFFER | eff) -> Eff (sb :: STREAM_BUFFER | eff) Unit
put str enc = putImpl str (show enc)

main = do
  log "setDefaultEncoding should not affect writing"
  testSetDefaultEncoding

  log "setEncoding should not affect reading"
  testSetEncoding

testString :: String
testString = "Liebe Grüße\nBergentrückung\n💡"

testSetDefaultEncoding = do
  w1 <- writableStreamBuffer
  check w1

  w2 <- writableStreamBuffer
  setDefaultEncoding w2 UCS2
  check w2

  where
  check w = do
    writeString w UTF8 testString do
      c <- getContentsAsString w
      assertEqual testString c

testSetEncoding = do
  check readableStreamBuffer

  check do
    r2 <- readableStreamBuffer
    setEncoding r2 UTF8
    pure r2

  check do
    r3 <- readableStreamBuffer
    setEncoding r3 UCS2
    pure r3

  where
  check makeR = do
    r1 <- makeR
    put testString UTF8 r1

    r2 <- makeR
    put testString UTF8 r2

    onData r1 \buf -> do
      onDataString r2 UTF8 \str -> do
        assertEqual <$> Buffer.toString UTF8 buf <*> pure testString
        assertEqual str testString
        log "ok."


provide JSON data (not strings)

provide JSON data (not strings)

module Daedalus.ClientApi where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Promise (Promise, fromAff)
import Daedalus.BackendApi as B
import Data.Tuple (Tuple)
import Data.Argonaut (Json)
import Network.HTTP.Affjax (AJAX)
import Daedalus.Types (mkCAddress, mkCoin, CAddress, Coin, CWallet, CTx, mkCWalletMeta)
import Data.Argonaut.Generic.Aeson (encodeJson)

getWallets :: forall eff. Eff(ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWallets

getWallet :: forall eff. String -> Eff(ajax :: AJAX | eff) (Promise Json)
getWallet = fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress

getHistory :: forall eff. String -> Eff(ajax :: AJAX | eff) (Promise Json)
getHistory = fromAff <<< map encodeJson <<< B.getHistory <<< mkCAddress

send :: forall eff. String -> String -> Int -> Eff(ajax :: AJAX | eff) (Promise Json)
send addrFrom addrTo amount = fromAff <<< map encodeJson $
    B.send
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCoin amount)

newWallet :: forall eff. String -> String -> String -> Eff(ajax :: AJAX | eff) (Promise Json)
newWallet wType wCurrency wName = fromAff <<< map encodeJson <<< B.newWallet $ mkCWalletMeta wType wCurrency wName

updateWallet :: forall eff. String -> String -> String -> String -> Eff(ajax :: AJAX | eff) (Promise Json)
updateWallet addr wType wCurrency wName = fromAff <<< map encodeJson <<<
    B.updateWallet
        (mkCAddress addr)
        $ mkCWalletMeta wType wCurrency wName
--
-- updateTransaction :: forall eff. String -> String -> String -> String -> String -> NominalDateTime -> Eff(ajax :: AJAX | eff) (Promise CWallet)
-- updateTransaction addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate = fromAff <<<
--     B.updateTransaction
--         (mkCAddress addr)
--         (mkCTxId ctxId)
--         $ mkCWalletMeta wType wCurrency wName
--
deleteWallet :: forall eff. String -> Eff(ajax :: AJAX | eff) (Promise Unit)
deleteWallet = fromAff <<< B.deleteWallet <<< mkCAddress

module Daedalus.ClientApi where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Promise (Promise, fromAff)
import Daedalus.BackendApi as B
import Data.Tuple (Tuple)
import Network.HTTP.Affjax (AJAX)
import Daedalus.Types (mkCAddress, mkCoin, CAddress, Coin, CWallet, CTx, mkCWalletMeta)
import Data.Argonaut.Generic.Aeson (encodeJson)

getWallets :: forall eff. Eff(ajax :: AJAX | eff) (Promise String)
getWallets = fromAff $ map (show <<< encodeJson) B.getWallets

getWallet :: forall eff. String -> Eff(ajax :: AJAX | eff) (Promise String)
getWallet = fromAff <<< map (show <<< encodeJson) <<< B.getWallet <<< mkCAddress

getHistory :: forall eff. String -> Eff(ajax :: AJAX | eff) (Promise String)
getHistory = fromAff <<< map (show <<< encodeJson) <<< B.getHistory <<< mkCAddress

send :: forall eff. String -> String -> Int -> Eff(ajax :: AJAX | eff) (Promise String)
send addrFrom addrTo amount = fromAff <<< map (show <<< encodeJson) $
    B.send
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCoin amount)

newWallet :: forall eff. String -> String -> String -> Eff(ajax :: AJAX | eff) (Promise String)
newWallet wType wCurrency wName = fromAff <<< map (show <<< encodeJson) <<< B.newWallet $ mkCWalletMeta wType wCurrency wName

updateWallet :: forall eff. String -> String -> String -> String -> Eff(ajax :: AJAX | eff) (Promise String)
updateWallet addr wType wCurrency wName = fromAff <<< map (show <<< encodeJson) <<<
    B.updateWallet
        (mkCAddress addr)
        $ mkCWalletMeta wType wCurrency wName
--
-- updateTransaction :: forall eff. String -> String -> String -> String -> String -> NominalDateTime -> Eff(ajax :: AJAX | eff) (Promise CWallet)
-- updateTransaction addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate = fromAff <<<
--     B.updateTransaction
--         (mkCAddress addr)
--         (mkCTxId ctxId)
--         $ mkCWalletMeta wType wCurrency wName
--
deleteWallet :: forall eff. String -> Eff(ajax :: AJAX | eff) (Promise Unit)
deleteWallet = fromAff <<< B.deleteWallet <<< mkCAddress


add documentation to IDBKeyRange

add documentation to IDBKeyRange

-- | A key has an associated type which is one of: number, date, string, binary, or array.
module Database.IndexedDB.IDBKeyRange
  ( class IDBKeyRange, includes
  , only
  , lowerBound
  , upperBound
  , bound
  , lower
  , upper
  , lowerOpen
  , upperOpen
  ) where

import Prelude

import Data.Foreign                       (Foreign)
import Data.Function.Uncurried             as Fn
import Data.Function.Uncurried            (Fn2, Fn4)
import Data.Maybe                         (Maybe)
import Data.Nullable                      (Nullable, toMaybe)

import Database.IndexedDB.Core            (KeyRange)
import Database.IndexedDB.IDBKey.Internal (class IDBKey, Key(..), toKey, extractForeign)

--------------------
-- INTERFACES
--
-- | The IDBKeyRange interface represents a key range.
class IDBKeyRange range where
  -- | Returns true if key is included in the range, and false otherwise.
  includes :: range -> Key -> Boolean

-- | Type alias for open
type Open = Boolean

-- | Returns a new IDBKeyRange spanning only key.
only
    :: forall a. (IDBKey a)
    => a
    -> KeyRange
only key =
  _only (extractForeign $ toKey key)

-- | Returns a new IDBKeyRange starting at key with no upper bound.
-- | If `Open` is `true`, key is not included in the range.
lowerBound
    :: forall a. (IDBKey a)
    => a
    -> Open
    -> KeyRange
lowerBound key open =
  Fn.runFn2 _lowerBound (extractForeign $ toKey key) open

-- | Returns a new IDBKeyRange with no lower bound and ending at key.
-- | If `Open` is `true`, key is not included in the range.
upperBound
    :: forall a. (IDBKey a)
    => a
    -> Open
    -> KeyRange
upperBound key open =
  Fn.runFn2 _upperBound (extractForeign $ toKey key) open

-- | Returns a new IDBKeyRange spanning from `lower` to `upper`.
-- | If `lowerOpen` is `true`, `lower` is not included in the range.
-- | If `upperOpen` is `true`, `upper` is not included in the range.
-- |
-- | It throws a `DataError` if the bound is invalid.
bound
    :: forall a. (IDBKey a)
    => { lower :: a, upper :: a, lowerOpen :: Boolean, upperOpen :: Boolean }
    -> Maybe KeyRange
bound { lower: key1, upper: key2, lowerOpen: open1, upperOpen: open2 } =
  toMaybe
  $ Fn.runFn4 _bound (extractForeign $ toKey key1) (extractForeign $ toKey key2) open1 open2

--------------------
-- ATTRIBUTES
--
-- | Returns lower bound if any.
lower
    :: KeyRange
    -> Maybe Key
lower =
  _lower >>> toMaybe >>> map Key

-- | Returns upper bound if any.
upper
    :: KeyRange
    -> Maybe Key
upper =
  _upper >>> toMaybe >>> map Key

-- | Returns true if the lower open flag is set, false otherwise.
lowerOpen
    :: KeyRange
    -> Boolean
lowerOpen =
  _lowerOpen

-- | Returns true if the upper open flag is set, false otherwise.
upperOpen
    :: KeyRange
    -> Boolean
upperOpen =
  _upperOpen

--------------------
-- INSTANCES
--
instance idbKeyRangeKeyRange :: IDBKeyRange KeyRange where
  includes range =
    extractForeign >>> Fn.runFn2 _includes range

--------------------
-- FFI
--
foreign import _bound :: Fn4 Foreign Foreign Boolean Boolean (Nullable KeyRange)

foreign import _includes :: forall range. Fn2 range Foreign Boolean

foreign import _lower :: KeyRange -> Nullable Foreign

foreign import _lowerBound :: Fn2 Foreign Boolean KeyRange

foreign import _lowerOpen :: KeyRange -> Boolean

foreign import _only :: Foreign -> KeyRange

foreign import _upper :: KeyRange -> Nullable Foreign

foreign import _upperBound :: Fn2 Foreign Boolean KeyRange

foreign import _upperOpen :: KeyRange -> Boolean

module Database.IndexedDB.IDBKeyRange
  ( class IDBKeyRange, includes
  , only
  , lowerBound
  , upperBound
  , bound
  , lower
  , upper
  , lowerOpen
  , upperOpen
  ) where

import Prelude

import Data.Foreign                       (Foreign)
import Data.Function.Uncurried             as Fn
import Data.Function.Uncurried            (Fn2, Fn4)
import Data.Maybe                         (Maybe)
import Data.Nullable                      (Nullable, toMaybe)

import Database.IndexedDB.Core            (KeyRange)
import Database.IndexedDB.IDBKey.Internal (class IDBKey, Key(..), toKey, extractForeign)

--------------------
-- INTERFACES
--
class IDBKeyRange range where
  includes :: range -> Key -> Boolean

only :: forall a. (IDBKey a) => a -> KeyRange
only key =
  _only (extractForeign $ toKey key)

lowerBound :: forall a. (IDBKey a) => a -> Boolean -> KeyRange
lowerBound key open =
  Fn.runFn2 _lowerBound (extractForeign $ toKey key) open

upperBound :: forall a. (IDBKey a) => a -> Boolean -> KeyRange
upperBound key open =
  Fn.runFn2 _upperBound (extractForeign $ toKey key) open

bound :: forall a. (IDBKey a) => { lower :: a, upper :: a, lowerOpen :: Boolean, upperOpen :: Boolean } -> Maybe KeyRange
bound { lower: key1, upper: key2, lowerOpen: open1, upperOpen: open2 } =
  toMaybe
  $ Fn.runFn4 _bound (extractForeign $ toKey key1) (extractForeign $ toKey key2) open1 open2

--------------------
-- ATTRIBUTES
--
lower :: KeyRange -> Maybe Key
lower =
  _lower >>> toMaybe >>> map Key

upper :: KeyRange -> Maybe Key
upper =
  _upper >>> toMaybe >>> map Key

lowerOpen :: KeyRange -> Boolean
lowerOpen =
  _lowerOpen

upperOpen :: KeyRange -> Boolean
upperOpen =
  _upperOpen

--------------------
-- INSTANCES
--
instance idbKeyRangeKeyRange :: IDBKeyRange KeyRange where
  includes range =
    extractForeign >>> Fn.runFn2 _includes range

--------------------
-- FFI
--
foreign import _bound :: Fn4 Foreign Foreign Boolean Boolean (Nullable KeyRange)

foreign import _includes :: forall range. Fn2 range Foreign Boolean

foreign import _lower :: KeyRange -> Nullable Foreign

foreign import _lowerBound :: Fn2 Foreign Boolean KeyRange

foreign import _lowerOpen :: KeyRange -> Boolean

foreign import _only :: Foreign -> KeyRange

foreign import _upper :: KeyRange -> Nullable Foreign

foreign import _upperBound :: Fn2 Foreign Boolean KeyRange

foreign import _upperOpen :: KeyRange -> Boolean


Fix power grouping

Fix power grouping

Signed-off-by: Ricky Elrod <3de8762d49a778edd8b1aa9f381ea5a9ccb62944@elrod.me>

module Lookangle where

import Math

type Latitude  = Number
type Longitude = Number
type Altitude  = Number
data Coordinate = Coordinate Latitude Longitude Altitude
data AzElCord   = AzElCord { azimuth :: Number, elevation :: Number, range :: Number }

instance showCoordinate :: Show Coordinate where
  show (Coordinate lat lon alt) = "Coordinate " ++ show lat ++ " " ++ show lon ++ " " ++ show alt

instance showAzElCord :: Show AzElCord where
  show (AzElCord a) = show a.azimuth ++ ", " ++ show a.elevation ++ ", " ++ show a.range

-- | Given a source and destination coordinate, return the look angle and
-- range to the object.
lookAngle ::
  Coordinate    -- ^ Source coordinate
  -> Coordinate -- ^ Destination coordinate
  -> AzElCord
lookAngle (Coordinate gLat gLon gAlt) (Coordinate pLat pLon pAlt) =
  AzElCord {
    azimuth: azimuth',
    elevation: elevation',
    range: range'
  }
  where
    earthRadius  = 6378137
    groundRadius = earthRadius + gAlt
    pointRadius  = earthRadius + pAlt
    gLat'        = (pi / 180) * gLat
    gLon'        = (pi / 180) * gLon
    pLat'        = (pi / 180) * pLat
    pLon'        = (pi / 180) * pLon

    -- WGS84-specific
    wgs84F   = 1 / 298.257223563
    wgs84Ecc = 8.1819190842621E-2
    wgs84N   = earthRadius / sqrt (1 - (pow wgs84Ecc 2) * (pow (sin gLat') 2))

    -- WGS84 -> ECR
    gX = (wgs84N + gAlt) * cos gLat' * cos gLon'
    gY = (wgs84N + gAlt) * cos gLat' * sin gLon'
    gZ = (wgs84N * (1 - (pow wgs84Ecc 2)) + gAlt) * sin gLat'

    pX = (wgs84N + pAlt) * cos pLat' * cos pLon'
    pY = (wgs84N + pAlt) * cos pLat' * sin pLon'
    pZ = (wgs84N * (1 - (pow wgs84Ecc 2)) + pAlt) * sin pLat'

    rangeX = pX - gX
    rangeY = pY - gY
    rangeZ = pZ - gZ

    -- Topocentric Horizon
    rotS = sin gLat' * cos gLon' * rangeX + sin gLat' * sin gLon' * rangeY - cos gLat' * rangeZ
    rotE = -(sin gLon' * rangeX) + cos gLon' * rangeY
    rotZ = cos gLat' * cos gLon' * rangeX + cos gLat' * sin gLon' * rangeY + sin gLat' * rangeZ

    range' = sqrt $ (pow rotS 2) + (pow rotE 2) + (pow rotZ 2)

    elRad = if range' == 0
             then pi / 2
             else asin (rotZ / range')

    azRad = if rotS > 0
            then atan (-(rotE / rotS)) + pi
            else if rotS < 0
                 then atan (-(rotE / rotS)) + (2 * pi)
                 else pi / 2

    elevation' = elRad * (180 / pi)
    azimuth'   = azRad * (180 / pi)

module Lookangle where

import Math

type Latitude  = Number
type Longitude = Number
type Altitude  = Number
data Coordinate = Coordinate Latitude Longitude Altitude
data AzElCord   = AzElCord { azimuth :: Number, elevation :: Number, range :: Number }

instance showCoordinate :: Show Coordinate where
  show (Coordinate lat lon alt) = "Coordinate " ++ show lat ++ " " ++ show lon ++ " " ++ show alt

instance showAzElCord :: Show AzElCord where
  show (AzElCord a) = show a.azimuth ++ ", " ++ show a.elevation ++ ", " ++ show a.range

-- | Given a source and destination coordinate, return the look angle and
-- range to the object.
lookAngle ::
  Coordinate    -- ^ Source coordinate
  -> Coordinate -- ^ Destination coordinate
  -> AzElCord
lookAngle (Coordinate gLat gLon gAlt) (Coordinate pLat pLon pAlt) =
  AzElCord {
    azimuth: azimuth',
    elevation: elevation',
    range: range'
  }
  where
    earthRadius  = 6378137
    groundRadius = earthRadius + gAlt
    pointRadius  = earthRadius + pAlt
    gLat'        = (pi / 180) * gLat
    gLon'        = (pi / 180) * gLon
    pLat'        = (pi / 180) * pLat
    pLon'        = (pi / 180) * pLon

    -- WGS84-specific
    wgs84F   = 1 / 298.257223563
    wgs84Ecc = 8.1819190842621E-2
    wgs84N   = earthRadius / sqrt (1 - (pow wgs84Ecc 2) * (pow (sin gLat') 2))

    -- WGS84 -> ECR
    gX = (wgs84N + gAlt) * cos gLat' * cos gLon'
    gY = (wgs84N + gAlt) * cos gLat' * sin gLon'
    gZ = (wgs84N * (pow (1 - wgs84Ecc) 2) + gAlt) * sin gLat'

    pX = (wgs84N + pAlt) * cos pLat' * cos pLon'
    pY = (wgs84N + pAlt) * cos pLat' * sin pLon'
    pZ = (wgs84N * (pow (1 - wgs84Ecc) 2) + pAlt) * sin pLat'

    rangeX = pX - gX
    rangeY = pY - gY
    rangeZ = pZ - gZ

    -- Topocentric Horizon
    rotS = sin gLat' * cos gLon' * rangeX + sin gLat' * sin gLon' * rangeY - cos gLat' * rangeZ
    rotE = -(sin gLon' * rangeX) + cos gLon' * rangeY
    rotZ = cos gLat' * cos gLon' * rangeX + cos gLat' * sin gLon' * rangeY + sin gLat' * rangeZ

    range' = sqrt $ (pow rotS 2) + (pow rotE 2) + (pow rotZ 2)

    elRad = if range' == 0
             then pi / 2
             else asin (rotZ / range')

    azRad = if rotS > 0
            then atan (-(rotE / rotS)) + pi
            else if rotS < 0
                 then atan (-(rotE / rotS)) + (2 * pi)
                 else pi / 2

    elevation' = elRad * (180 / pi)
    azimuth'   = azRad * (180 / pi)


Tweak `stopAt` tests a little

Tweak `stopAt` tests a little

module Test.Spec.CompilerSpec (parserGenSpec) where

import Prelude
import Debug.Trace
import Data.Tuple (Tuple(..))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Either (Either(..), either)
import Data.List (List(..), toList, length, fromList, singleton)
import Data.Map (Map(..))
import Data.StrMap as StrMap
import Data.StrMap (StrMap())
import Data.Tuple (uncurry)
import Data.Map as Map
import Data.Array as A
import Data.Foldable (for_, intercalate)
import Control.Monad.Eff.Exception (error, throwException)
import Text.Parsing.Parser as P

import Test.Assert (assert)
import Test.Spec (describe, it, Spec())
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff)
import Test.Support.Arguments

import Language.Docopt (parseDocopt)
import Language.Docopt.Errors
import Language.Docopt.Argument
import Language.Docopt.Value
import Language.Docopt.Usage
import Language.Docopt.Env (Env())
import Language.Docopt.Compiler (genParser, runParser)
import Language.Docopt.Argument   as D
import Language.Docopt.Env        as Env
import Language.Docopt.Trans.Flat as T
import Test.Support.Docopt        as D

type Options =  { stopAt       :: Array String
                , optionsFirst :: Boolean
                }

type Test = { help  :: String
            , cases :: Array Case
            }

type Case = { argv     :: Array String
            , env      :: Array (Tuple String String)
            , expected :: Either String (StrMap Value)
            , options  :: Maybe Options
            }

test :: String     -- ^ The help text
     -> Array Case -- ^ The array of test cases to cover
     -> Test
test help ks = { help: help, cases: ks }

pass ::  Maybe Options                -- ^ The options
      -> Array String                 -- ^ ARGV
      -> (Array (Tuple String Value)) -- ^ The expected output
      -> Case
pass opts i o = { argv:     i
                , env:      []
                , options:  opts
                , expected: Right $ StrMap.fromList $ toList o
                }

pass' :: Maybe Options                 -- ^ The options
      -> Array String                  -- ^ ARGV
      -> (Array (Tuple String String)) -- ^ The environment
      -> (Array (Tuple String Value))  -- ^ The expected output
      -> Case
pass' opts i e o = { argv:     i
                   , env:      e
                   , options:  opts
                   , expected: Right $ StrMap.fromList $ toList o
                   }

fail :: Array String -- ^ ARGV
      -> String      -- ^ The expected error message
      -> Case
fail i e = { argv: i, env: [],  expected: Left e, options: Nothing }

fail' :: Array String                  -- ^ ARGV
      -> (Array (Tuple String String)) -- ^ The environment
      -> String                        -- ^ The expected error message
      -> Case
fail' i e err = { argv: i, env: e, expected: Left err, options: Nothing }

(:>) = Tuple
infixr 0 :>

parserGenSpec = \_ -> describe "The parser generator" do
  it "" do
    pure unit

  -- Some options that will be used for these tests
  let testCases = [
      test
        "usage: prog <qux>..."
        [ pass Nothing
            [ "a", "b", "c" ]
            [ "<qux>" :> D.array [ D.str "a", D.str "b", D.str "c" ]
            ]
        , fail [ "--foo", "baz" ]
            "Expected <qux>..., but got --foo"
        , fail
            [ "a", "--foo", "-f=10" ]
            "Unmatched option: --foo"
        ]

    , test
        "usage: prog <qux>... --"
        [ pass Nothing
            [ "a", "b", "c", "--" ]
            [ "<qux>" :> D.array [ D.str "a", D.str "b", D.str "c" ]
            , "--"    :> D.array []
            ]
        , pass Nothing
            [ "a", "b", "c", "--", "--", "--" ]
            [ "<qux>" :> D.array [ D.str "a", D.str "b", D.str "c" ]
            , "--"    :> D.array [ D.str "--" , D.str "--" ]
            ]
        ]

    , test
        """
        usage: prog [options]
        options:
          -h, --host <host[:port]> [default: "http://localhost:3000"]
        """
        [ pass
            Nothing
            [ "-hhttp://localhost:5000" ]
            [ "-h"     :> D.str "http://localhost:5000"
            , "--host" :> D.str "http://localhost:5000"
            ]
        ]

    , test
        """
        usage: prog [options]
        options:
          -h, --host FOO [default: BAR] [env: HOST]
        """
        [ pass'
            Nothing
            []
            [ "HOST" :> "HOME" ]
            [ "-h"     :> D.str "HOME"
            , "--host" :> D.str "HOME"
            ]
        ]

    , test
        """
        usage: prog (-iFILE)
        options:
          -i, --input FILE
        """
        [ fail [] "Expected option(s): -i|--input=FILE"
        , pass Nothing
            [ "-i", "bar" ]
            [ "-i"      :> D.str "bar"
            , "--input" :> D.str "bar" ]
        ]

    , test
        """
        usage: prog (-iFILE) -oFILE
        options:
          -i, --input FILE
          -o, --output FILE
        """
        [ fail []
          $ "Expected option(s): -i|--input=FILE, -o|--output=FILE"

        , fail [ "-i", "bar" ]
          $ "Expected option(s): -o|--output=FILE"

        , pass Nothing
            [ "-i", "bar", "-o", "bar" ]
            [ "--input"  :> D.str "bar"
            , "-i"       :> D.str "bar"
            , "--output" :> D.str "bar"
            , "-o"       :> D.str "bar" ]

          -- group should be interchangable if it's only of options:
        , pass Nothing
            [ "-o", "bar", "-i", "bar" ]
            [ "--input"  :> D.str "bar"
            , "-i"       :> D.str "bar"
            , "--output" :> D.str "bar"
            , "-o"       :> D.str "bar" ]
        ]

    , test
        """
        usage: prog ((-iFILE) -rFILE) -oFILE
        options:
          -i, --input FILE
          -o, --output FILE
          -r, --redirect FILE [env: QUX]
        """
        [ fail []
          $ "Expected option(s): -i|--input=FILE -r|--redirect=FILE, -o|--output=FILE"

        , fail [ "-i", "bar", "-r", "bar" ]
            "Expected option(s): -o|--output=FILE"

        , pass Nothing
            [ "-i", "bar", "-r", "bar", "-o", "bar" ]
            [ "--input"    :> D.str "bar"
            , "-i"         :> D.str "bar"
            , "--redirect" :> D.str "bar"
            , "-r"         :> D.str "bar"
            , "--output"   :> D.str "bar"
            , "-o"         :> D.str "bar" ]

          -- group should be interchangable if it's only of options:
        , pass Nothing
            [ "-o", "bar", "-r", "bar", "-i", "bar" ]
            [ "--input"    :> D.str "bar"
            , "-i"         :> D.str "bar"
            , "--redirect" :> D.str "bar"
            , "-r"         :> D.str "bar"
            , "--output"   :> D.str "bar"
            , "-o"         :> D.str "bar" ]

        , pass' Nothing
            [ "-o", "bar", "-i", "bar" ]
            [ "QUX" :> "BAR" ]
            [ "--input"    :> D.str "bar"
            , "-i"         :> D.str "bar"
            , "--redirect" :> D.str "BAR"
            , "-r"         :> D.str "BAR"
            , "--output"   :> D.str "bar"
            , "-o"         :> D.str "bar" ]
        ]

    , test
        """
        usage: prog ((-i FILE) <env>) -oFILE
        options:
          -i, --input FILE
          -o, --output FILE
          -r, --redirect FILE
        """
        [ fail [] "Expected option(s): -i|--input=FILE"
          -- XXX: Would be cool to show the reason the group did not parse!
        , fail [ "-i", "bar" ] "Expected <env>"
        , pass Nothing
            [ "-i", "bar", "x", "-o", "bar" ]
            [ "--input"  :> D.str "bar"
            , "-i"       :> D.str "bar"
            , "<env>"    :> D.str "x"
            , "--output" :> D.str "bar"
            , "-o"       :> D.str "bar" ]
          -- group should NOT be interchangable if it contains non-options:
        , fail [ "-o", "bar", "x", "-i", "bar" ]
            "Expected option(s): -i|--input=FILE"
        ]

    , test
        """
        usage: prog [options]
        options:
          -o, --out FOO [env: FOO]
        """
        [ pass' Nothing
            []
            [ "FOO"    :> "BAR" ]
            [  "--out" :> D.str "BAR"
            ,  "-o"    :> D.str "BAR" ]
        ]

    , test
        """
        usage: prog [options]
        options:
          -o, --out FOO [default: "ADLER"] [env: FOO]
        """
        [ pass' Nothing
            []
            [ "FOO" :> "BAR" ]
            [  "--out" :> D.str "BAR"
            ,  "-o"    :> D.str "BAR" ]
        ]

    , test
        """
        usage: prog -a
           or: prog -b
        """
        [ pass Nothing
            [ "-a" ]
            [ "-a" :> D.bool true ]
        , pass Nothing
            [ "-b" ]
            [ "-b" :> D.bool true ]
        , pass Nothing
            []
            []
        ]

    , test
        """
        usage: prog a
           or: prog b
        """
        [ pass Nothing
            [ "a" ]
            [ "a" :> D.bool true ]
        , pass Nothing
            [ "b" ]
            [ "b" :> D.bool true ]
        , fail
            [ "a", "b" ]
            "Unmatched command: b"
        , fail
            [ "b", "a" ]
            "Unmatched command: a"
        , fail [] ""
        ]

    , test
        """
        usage: prog foo -io [-q]... -b=BAZ -f=FOZ... baz
        options:
          -i, --input
          -o, --out
          -q, --qux...
          -b, --baz BAZ [default: "ax"]
          -f, --foo FOZ...
        """
        [ pass Nothing
            [ "foo", "--out", "--input", "--qux", "--foo=ox", "baz" ]
            [ "foo"     :> D.bool true
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "--qux"   :> D.int 1
            , "-q"      :> D.int 1
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            , "baz"     :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            ]

        , pass Nothing
            [ "foo" , "--out", "-qqq", "--foo=ox", "--baz=ax", "--input", "baz" ]
            [ "foo"     :> D.bool true
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--qux"   :> D.int 3
            , "-q"      :> D.int 3
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "baz"     :> D.bool true
            ]

        , pass Nothing
            [ "foo", "-q", "-o", "--qux", "-i", "--baz=ax", "-f=ox", "baz" ]
            [ "foo"     :> D.bool true
            , "--qux"   :> D.int 2
            , "-q"      :> D.int 2
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            , "baz"     :> D.bool true
            ]

        , pass Nothing
            [ "foo", "--baz=ax", "-o", "-f=ox", "-i", "baz" ]
            [ "foo"     :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "baz"     :> D.bool true
            ]

        , pass Nothing
            [ "foo", "-o", "-i", "-bax", "-f=ox", "baz" ]
            [ "foo"     :> D.bool true
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "baz"     :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            ]

        , fail
            [ "foo" ]
            "Expected option(s): -f|--foo=FOZ..."
        , fail
            [ "foo", "-o", "-i", "-bax" ]
            "Expected option(s): -f|--foo=FOZ..."
        ]

    , test
        """
        usage: prog [foo]
        """
        [ fail [ "goo" ] "Unmatched command: goo" ]

    , test
        """
        usage: prog (foo)
        """
        [ fail [ "goo" ] "Expected foo, but got goo" ]

    , test
        """
        Usage: prog [options]
        options:
          -n
        """
        [ pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "true", "false" ]
            [ "-n" :> D.array [ D.str "true",  D.str "false" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n...
        """
        [ pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "true", "false" ]
            [ "-n" :> D.array [ D.str "true",  D.str "false" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n[=FOO]
        """
        [ pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "true", "false" ]
            [ "-n" :> D.array [ D.str "true",  D.str "false" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n[=FOO]...
        """
        [ pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "true", "false" ]
            [ "-n" :> D.array [ D.str "true",  D.str "false" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n, --noop
        """
        [ pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n"     :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ]
            , "--noop" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { stopAt: [ "--noop" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n"     :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ]
            , "--noop" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { stopAt: [ "-n", "--noop" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n"     :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ]
            , "--noop" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n ARC
        """
        [ pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: false
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        ]

    , test
        """
        Usage: prog ((((foo|bar)|qux)|wux)|-n ARC) ARGS...
        options:
          -n ARC
        """
        [ pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        ]

    , test
        """
        Usage: prog ((((foo|bar)|-n ARC)|wux))
        options:
          -n ARC
        """
        [ pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: false
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        ]

    , test
        """
        Usage: prog [-i] [-q]...
        """
        [ pass
            Nothing
            [ "-q", "-i", "-q" ]
            [ "-i" :> D.bool true
            , "-q" :> D.int 2 ]
        , pass
            Nothing
            [ "-i", "-q", "-q" ]
            [ "-i" :> D.bool true
            , "-q" :> D.int 2 ]
        , pass
            Nothing
            [ "-q", "-q", "-i" ]
            [ "-i" :> D.bool true
            , "-q" :> D.int 2 ]
        ]
  ]

  for_ testCases \(({ help, cases })) -> do
    describe help do
      for_ cases \(({ argv, env, expected, options })) ->
            let msg = either (\e -> "Should fail with \"" <> e <> "\"")
                              prettyPrintOut
                              expected
                premsg = if A.length argv > 0
                            then intercalate " " argv
                            else "(no input)"
            in it (premsg <> " -> " <> msg) do
                  vliftEff do
                    { specification } <- runEitherEff do
                      parseDocopt help { smartOptions: true }
                    validate (specification)
                             argv
                             (Env.fromFoldable env)
                             options
                             expected

    where

      prettyPrintOut :: StrMap Value -> String
      prettyPrintOut m = "\n\t" <> prettyPrintStrMap m

      prettyPrintStrMap :: StrMap Value -> String
      prettyPrintStrMap m = intercalate "\n\t" $
        StrMap.toList m <#> \(Tuple arg val) ->
          arg <> " => " <> prettyPrintValue val

      validate :: forall eff.  List Usage
                            -> Array String
                            -> Env
                            -> Maybe Options
                            -> Either String (StrMap Value)
                            -> Eff (err :: EXCEPTION | eff) Unit
      validate spec argv env options expected = do
        let result = uncurry (T.reduce spec env)
                <$> runParser
                      env
                      argv
                      (genParser spec (fromMaybe {
                        optionsFirst: false
                      , stopAt:       []
                      } options))

        case result of
          Left (e@(P.ParseError { message: msg })) ->
            either
              (\e' ->
                if (msg /= e')
                  then throwException $ error $
                    "Unexpected error:\n" <> msg
                  else return unit)
              (const $ throwException $ error $ show e)
              expected
          Right r -> do
            either
              (\e ->
                throwException $ error $
                  "Missing expected exception:"
                    <> "\n"
                    <> show e
                    <> "\n"
                    <> "\n"
                    <> "instead received output:"
                    <> "\n"
                    <> prettyPrintOut r)
              (\r' ->
                if (r /= r')
                  then throwException $ error $
                    "Unexpected output:\n"
                      <> prettyPrintOut r
                  else return unit)
              expected

module Test.Spec.CompilerSpec (parserGenSpec) where

import Prelude
import Debug.Trace
import Data.Tuple (Tuple(..))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Either (Either(..), either)
import Data.List (List(..), toList, length, fromList, singleton)
import Data.Map (Map(..))
import Data.StrMap as StrMap
import Data.StrMap (StrMap())
import Data.Tuple (uncurry)
import Data.Map as Map
import Data.Array as A
import Data.Foldable (for_, intercalate)
import Control.Monad.Eff.Exception (error, throwException)
import Text.Parsing.Parser as P

import Test.Assert (assert)
import Test.Spec (describe, it, Spec())
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff)
import Test.Support.Arguments

import Language.Docopt (parseDocopt)
import Language.Docopt.Errors
import Language.Docopt.Argument
import Language.Docopt.Value
import Language.Docopt.Usage
import Language.Docopt.Env (Env())
import Language.Docopt.Compiler (genParser, runParser)
import Language.Docopt.Argument   as D
import Language.Docopt.Env        as Env
import Language.Docopt.Trans.Flat as T
import Test.Support.Docopt        as D

type Options =  { stopAt       :: Array String
                , optionsFirst :: Boolean
                }

type Test = { help  :: String
            , cases :: Array Case
            }

type Case = { argv     :: Array String
            , env      :: Array (Tuple String String)
            , expected :: Either String (StrMap Value)
            , options  :: Maybe Options
            }

test :: String     -- ^ The help text
     -> Array Case -- ^ The array of test cases to cover
     -> Test
test help ks = { help: help, cases: ks }

pass ::  Maybe Options                -- ^ The options
      -> Array String                 -- ^ ARGV
      -> (Array (Tuple String Value)) -- ^ The expected output
      -> Case
pass opts i o = { argv:     i
                , env:      []
                , options:  opts
                , expected: Right $ StrMap.fromList $ toList o
                }

pass' :: Maybe Options                 -- ^ The options
      -> Array String                  -- ^ ARGV
      -> (Array (Tuple String String)) -- ^ The environment
      -> (Array (Tuple String Value))  -- ^ The expected output
      -> Case
pass' opts i e o = { argv:     i
                   , env:      e
                   , options:  opts
                   , expected: Right $ StrMap.fromList $ toList o
                   }

fail :: Array String -- ^ ARGV
      -> String      -- ^ The expected error message
      -> Case
fail i e = { argv: i, env: [],  expected: Left e, options: Nothing }

fail' :: Array String                  -- ^ ARGV
      -> (Array (Tuple String String)) -- ^ The environment
      -> String                        -- ^ The expected error message
      -> Case
fail' i e err = { argv: i, env: e, expected: Left err, options: Nothing }

(:>) = Tuple
infixr 0 :>

parserGenSpec = \_ -> describe "The parser generator" do
  it "" do
    pure unit

  -- Some options that will be used for these tests
  let testCases = [
      test
        "usage: prog <qux>..."
        [ pass Nothing
            [ "a", "b", "c" ]
            [ "<qux>" :> D.array [ D.str "a", D.str "b", D.str "c" ]
            ]
        , fail [ "--foo", "baz" ]
            "Expected <qux>..., but got --foo"
        , fail
            [ "a", "--foo", "-f=10" ]
            "Unmatched option: --foo"
        ]

    , test
        "usage: prog <qux>... --"
        [ pass Nothing
            [ "a", "b", "c", "--" ]
            [ "<qux>" :> D.array [ D.str "a", D.str "b", D.str "c" ]
            , "--"    :> D.array []
            ]
        , pass Nothing
            [ "a", "b", "c", "--", "--", "--" ]
            [ "<qux>" :> D.array [ D.str "a", D.str "b", D.str "c" ]
            , "--"    :> D.array [ D.str "--" , D.str "--" ]
            ]
        ]

    , test
        """
        usage: prog [options]
        options:
          -h, --host <host[:port]> [default: "http://localhost:3000"]
        """
        [ pass
            Nothing
            [ "-hhttp://localhost:5000" ]
            [ "-h"     :> D.str "http://localhost:5000"
            , "--host" :> D.str "http://localhost:5000"
            ]
        ]

    , test
        """
        usage: prog [options]
        options:
          -h, --host FOO [default: BAR] [env: HOST]
        """
        [ pass'
            Nothing
            []
            [ "HOST" :> "HOME" ]
            [ "-h"     :> D.str "HOME"
            , "--host" :> D.str "HOME"
            ]
        ]

    , test
        """
        usage: prog (-iFILE)
        options:
          -i, --input FILE
        """
        [ fail [] "Expected option(s): -i|--input=FILE"
        , pass Nothing
            [ "-i", "bar" ]
            [ "-i"      :> D.str "bar"
            , "--input" :> D.str "bar" ]
        ]

    , test
        """
        usage: prog (-iFILE) -oFILE
        options:
          -i, --input FILE
          -o, --output FILE
        """
        [ fail []
          $ "Expected option(s): -i|--input=FILE, -o|--output=FILE"

        , fail [ "-i", "bar" ]
          $ "Expected option(s): -o|--output=FILE"

        , pass Nothing
            [ "-i", "bar", "-o", "bar" ]
            [ "--input"  :> D.str "bar"
            , "-i"       :> D.str "bar"
            , "--output" :> D.str "bar"
            , "-o"       :> D.str "bar" ]

          -- group should be interchangable if it's only of options:
        , pass Nothing
            [ "-o", "bar", "-i", "bar" ]
            [ "--input"  :> D.str "bar"
            , "-i"       :> D.str "bar"
            , "--output" :> D.str "bar"
            , "-o"       :> D.str "bar" ]
        ]

    , test
        """
        usage: prog ((-iFILE) -rFILE) -oFILE
        options:
          -i, --input FILE
          -o, --output FILE
          -r, --redirect FILE [env: QUX]
        """
        [ fail []
          $ "Expected option(s): -i|--input=FILE -r|--redirect=FILE, -o|--output=FILE"

        , fail [ "-i", "bar", "-r", "bar" ]
            "Expected option(s): -o|--output=FILE"

        , pass Nothing
            [ "-i", "bar", "-r", "bar", "-o", "bar" ]
            [ "--input"    :> D.str "bar"
            , "-i"         :> D.str "bar"
            , "--redirect" :> D.str "bar"
            , "-r"         :> D.str "bar"
            , "--output"   :> D.str "bar"
            , "-o"         :> D.str "bar" ]

          -- group should be interchangable if it's only of options:
        , pass Nothing
            [ "-o", "bar", "-r", "bar", "-i", "bar" ]
            [ "--input"    :> D.str "bar"
            , "-i"         :> D.str "bar"
            , "--redirect" :> D.str "bar"
            , "-r"         :> D.str "bar"
            , "--output"   :> D.str "bar"
            , "-o"         :> D.str "bar" ]

        , pass' Nothing
            [ "-o", "bar", "-i", "bar" ]
            [ "QUX" :> "BAR" ]
            [ "--input"    :> D.str "bar"
            , "-i"         :> D.str "bar"
            , "--redirect" :> D.str "BAR"
            , "-r"         :> D.str "BAR"
            , "--output"   :> D.str "bar"
            , "-o"         :> D.str "bar" ]
        ]

    , test
        """
        usage: prog ((-i FILE) <env>) -oFILE
        options:
          -i, --input FILE
          -o, --output FILE
          -r, --redirect FILE
        """
        [ fail [] "Expected option(s): -i|--input=FILE"
          -- XXX: Would be cool to show the reason the group did not parse!
        , fail [ "-i", "bar" ] "Expected <env>"
        , pass Nothing
            [ "-i", "bar", "x", "-o", "bar" ]
            [ "--input"  :> D.str "bar"
            , "-i"       :> D.str "bar"
            , "<env>"    :> D.str "x"
            , "--output" :> D.str "bar"
            , "-o"       :> D.str "bar" ]
          -- group should NOT be interchangable if it contains non-options:
        , fail [ "-o", "bar", "x", "-i", "bar" ]
            "Expected option(s): -i|--input=FILE"
        ]

    , test
        """
        usage: prog [options]
        options:
          -o, --out FOO [env: FOO]
        """
        [ pass' Nothing
            []
            [ "FOO"    :> "BAR" ]
            [  "--out" :> D.str "BAR"
            ,  "-o"    :> D.str "BAR" ]
        ]

    , test
        """
        usage: prog [options]
        options:
          -o, --out FOO [default: "ADLER"] [env: FOO]
        """
        [ pass' Nothing
            []
            [ "FOO" :> "BAR" ]
            [  "--out" :> D.str "BAR"
            ,  "-o"    :> D.str "BAR" ]
        ]

    , test
        """
        usage: prog -a
           or: prog -b
        """
        [ pass Nothing
            [ "-a" ]
            [ "-a" :> D.bool true ]
        , pass Nothing
            [ "-b" ]
            [ "-b" :> D.bool true ]
        , pass Nothing
            []
            []
        ]

    , test
        """
        usage: prog a
           or: prog b
        """
        [ pass Nothing
            [ "a" ]
            [ "a" :> D.bool true ]
        , pass Nothing
            [ "b" ]
            [ "b" :> D.bool true ]
        , fail
            [ "a", "b" ]
            "Unmatched command: b"
        , fail
            [ "b", "a" ]
            "Unmatched command: a"
        , fail [] ""
        ]

    , test
        """
        usage: prog foo -io -q... -b=BAZ -f=FOZ... baz
        options:
          -i, --input
          -o, --out
          -q, --qux...
          -b, --baz BAZ [default: "ax"]
          -f, --foo FOZ...
        """
        [ pass Nothing
            [ "foo", "--out", "--input", "--qux", "--foo=ox", "baz" ]
            [ "foo"     :> D.bool true
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "--qux"   :> D.int 1
            , "-q"      :> D.int 1
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            , "baz"     :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            ]

        , pass Nothing
            [ "foo" , "--out", "-qqq", "--foo=ox", "--baz=ax", "--input", "baz" ]
            [ "foo"     :> D.bool true
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--qux"   :> D.int 3
            , "-q"      :> D.int 3
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "baz"     :> D.bool true
            ]

        , pass Nothing
            [ "foo", "-q", "-o", "--qux", "-i", "--baz=ax", "-f=ox", "baz" ]
            [ "foo"     :> D.bool true
            , "--qux"   :> D.int 2
            , "-q"      :> D.int 2
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            , "baz"     :> D.bool true
            ]

        , pass Nothing
            [ "foo", "--baz=ax", "-o", "-f=ox", "-i", "baz" ]
            [ "foo"     :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "baz"     :> D.bool true
            ]

        , pass Nothing
            [ "foo", "-o", "-i", "-bax", "-f=ox", "baz" ]
            [ "foo"     :> D.bool true
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "baz"     :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            ]

        , fail
            [ "foo" ]
            "Expected option(s): -f|--foo=FOZ..."
        , fail
            [ "foo", "-o", "-i", "-bax" ]
            "Expected option(s): -f|--foo=FOZ..."
        ]

    , test
        """
        usage: prog [foo]
        """
        [ fail [ "goo" ] "Unmatched command: goo" ]

    , test
        """
        usage: prog (foo)
        """
        [ fail [ "goo" ] "Expected foo, but got goo" ]

    , test
        """
        Usage: prog [options]
        options:
          -n
        """
        [ pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "true", "false" ]
            [ "-n" :> D.array [ D.str "true",  D.str "false" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n...
        """
        [ pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "true", "false" ]
            [ "-n" :> D.array [ D.str "true",  D.str "false" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n[=FOO]
        """
        [ pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "true", "false" ]
            [ "-n" :> D.array [ D.str "true",  D.str "false" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n[=FOO]...
        """
        [ pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "true", "false" ]
            [ "-n" :> D.array [ D.str "true",  D.str "false" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n, --noop
        """
        [ pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n"     :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ]
            , "--noop" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { stopAt: [ "--noop" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n"     :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ]
            , "--noop" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { stopAt: [ "-n", "--noop" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n"     :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ]
            , "--noop" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n ARC
        """
        [ pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        ]

    , test
        """
        Usage: prog ((((foo|bar)|qux)|wux)|-n ARC)
        options:
          -n ARC
        """
        [ pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        ]

    , test
        """
        Usage: prog ((((foo|bar)|-n ARC)|wux))
        options:
          -n ARC
        """
        [ pass
            (Just { stopAt: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        ]

    , test
        """
        Usage: prog [-i] [-q]...
        """
        [ pass
            Nothing
            [ "-q", "-i", "-q" ]
            [ "-i" :> D.bool true
            , "-q" :> D.int 2 ]
        , pass
            Nothing
            [ "-i", "-q", "-q" ]
            [ "-i" :> D.bool true
            , "-q" :> D.int 2 ]
        , pass
            Nothing
            [ "-q", "-q", "-i" ]
            [ "-i" :> D.bool true
            , "-q" :> D.int 2 ]
        ]
  ]

  for_ testCases \(({ help, cases })) -> do
    describe help do
      for_ cases \(({ argv, env, expected, options })) ->
            let msg = either (\e -> "Should fail with \"" <> e <> "\"")
                              prettyPrintOut
                              expected
                premsg = if A.length argv > 0
                            then intercalate " " argv
                            else "(no input)"
            in it (premsg <> " -> " <> msg) do
                  vliftEff do
                    { specification } <- runEitherEff do
                      parseDocopt help { smartOptions: true }
                    validate (specification)
                             argv
                             (Env.fromFoldable env)
                             options
                             expected

    where

      prettyPrintOut :: StrMap Value -> String
      prettyPrintOut m = "\n\t" <> prettyPrintStrMap m

      prettyPrintStrMap :: StrMap Value -> String
      prettyPrintStrMap m = intercalate "\n\t" $
        StrMap.toList m <#> \(Tuple arg val) ->
          arg <> " => " <> prettyPrintValue val

      validate :: forall eff.  List Usage
                            -> Array String
                            -> Env
                            -> Maybe Options
                            -> Either String (StrMap Value)
                            -> Eff (err :: EXCEPTION | eff) Unit
      validate spec argv env options expected = do
        let result = uncurry (T.reduce spec env)
                <$> runParser
                      env
                      argv
                      (genParser spec (fromMaybe {
                        optionsFirst: false
                      , stopAt:       []
                      } options))

        case result of
          Left (e@(P.ParseError { message: msg })) ->
            either
              (\e' ->
                if (msg /= e')
                  then throwException $ error $
                    "Unexpected error:\n" <> msg
                  else return unit)
              (const $ throwException $ error $ show e)
              expected
          Right r -> do
            either
              (\e ->
                throwException $ error $
                  "Missing expected exception:"
                    <> "\n"
                    <> show e
                    <> "\n"
                    <> "\n"
                    <> "instead received output:"
                    <> "\n"
                    <> prettyPrintOut r)
              (\r' ->
                if (r /= r')
                  then throwException $ error $
                    "Unexpected output:\n"
                      <> prettyPrintOut r
                  else return unit)
              expected