Fix collapse when deleting a cell

Fix collapse when deleting a cell

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Draftboard.Layout
  ( SplitBias(..)
  , Rect
  , Vect
  , Cell
  , Edge
  , locatorToRect
  , eqEdge
  , rectAt
  , cells
  , edges
  , findSplit
  , insertSplit
  , resizeEdge
  , resizeEdge'
  , deleteCell
  , absoluteRect
  , absoluteVect
  , absoluteCells
  , absoluteEdges
  , closestSnapRatio
  , defaultMerge
  ) where

import SlamData.Prelude
import Data.List (List(..), (:))
import Data.List as List
import Data.Rational (Rational, (%))
import Data.Rational as Rational
import Math (floor, abs)

import SlamData.Workspace.Card.Draftboard.Orientation (Orientation(..), reverse)
import SlamData.Workspace.Card.Draftboard.Pane (Pane(..), Locator(..), Cursor, runCursor, walkWithLocator, getAtWithLocator, wrap)

data SplitBias
  = SideA
  | SideB

type Rect a =
  { top ∷ a
  , left ∷ a
  , width ∷ a
  , height ∷ a
  }

type Vect a =
  { x ∷ a
  , y ∷ a
  , z ∷ a
  }

type Cell a b =
  { cursor ∷ Cursor
  , value ∷ a
  , rect ∷ Rect b
  }

type Edge a =
  { index ∷ Int
  , parent ∷ Cursor
  , orientation ∷ Orientation
  , ratio ∷ Rational
  , vect ∷ Vect a
  }

locatorToRect ∷ Locator → Rect Rational
locatorToRect (Locator _ left top width height _ _) =
  { top, left, width, height }

-- | Edges are semantically equal if their cursor and index are equal.
eqEdge ∷ ∀ a b. Edge a → Edge b → Boolean
eqEdge a b = a.parent == b.parent && a.index == b.index

-- | Calculates the rectangle for a given Cursor.
rectAt ∷ ∀ a . Cursor → Pane a → Maybe (Rect Rational)
rectAt cursor = map (locatorToRect <<< fst) <<< getAtWithLocator cursor

-- | Collects all cells with their computed locations
cells ∷ ∀ a . Pane a → List (Cell a Rational)
cells = walkWithLocator go Nil
  where
  go (Locator cursor left top width height _ _) cs (Cell value) =
    { cursor
    , value
    , rect: { top, left, width, height }
    } : cs
  go _ cs _ = cs

-- | Collects all the computed edges with their vectors. This does not include
-- | the edges for the root.
edges ∷ ∀ a . Pane a → List (Edge Rational)
edges = walkWithLocator go Nil
  where
  go _ es (Cell _) = es
  go (Locator c x y w h _ _) es (Split orn panes) =
    goEdges x y zero 0 Nil panes <> es

    where
    goEdges x y off ix acc ps =
      let
        edge = case ps of
          (r × p) : (r' × p') : _ →
            let
              vect = case orn of
                Horizontal → { x: x + r * w, y, z: h }
                Vertical   → { x, y: y + r * h, z: w }
              in
                List.singleton
                  { index: ix
                  , parent: c
                  , orientation: orn
                  , ratio: off + r
                  , vect
                  }
          _ → Nil
      in
        case ps of
          Nil → acc
          (r × p) : ps' →
            case orn of
              Horizontal →
                goEdges (r * w + x) y (off + r) (ix + 1) (edge <> acc) ps'
              Vertical →
                goEdges x (r * h + y) (off + r) (ix + 1) (edge <> acc) ps'

-- | Finds the deepest split for a given orientation and cursor.
findSplit
  ∷ ∀ a
  . Orientation
  → Cursor
  → Pane a
  → Maybe Cursor
findSplit orn cursor =
  map (List.reverse) <=< runCursor
    (case _ of
      Split orn' _ | orn' == orn → Just Nil
      _ → Nothing)
    (\orn' _ ix r →
      case r of
        Just c → Just (ix : c)
        _ | orn' == orn → Just Nil
        _ → Nothing)
    cursor

-- | Inserts a new split into a Pane at a given ratio. If the Cursor points to
-- | a Split, then the Pane at that ratio will be resized appropriately.
insertSplit
  ∷ ∀ a
  . Pane a
  → Orientation
  → Rational
  → SplitBias
  → Cursor
  → Pane a
  → Maybe (Pane a)
insertSplit pane orn ratio side = runCursor split defaultMerge
  where
  split p = Split orn case p of
    -- When splitting an existing Split of a given orientation, we need to
    -- split the Pane that is at the given ratio.
    Split orn' ps | orn' == orn →
      goSplit (\off r p' → scale r (splitAt ((ratio - off) / r) p' pane)) zero Nil ps
    _ →
      splitAt ratio p pane

  splitAt ∷ Rational → Pane a → Pane a → List (Rational × Pane a)
  splitAt r cell1 cell2 =
    case side of
      SideA → scaleOrWrap r cell2 <> scaleOrWrap (one - r) cell1
      SideB → scaleOrWrap r cell1 <> scaleOrWrap (one - r) cell2

  scaleOrWrap ∷ Rational → Pane a → List (Rational × Pane a)
  scaleOrWrap r p = case p of
    -- Cells need to be wrapped in a single Split of the opposite orientation.
    -- This ensures we can keep alternating splits.
    Cell a → List.singleton (r × wrap (reverse orn) p)
    -- If a Split has the same orientation, we want to assimilate into the
    -- existing split, so we should just scale as needed.
    Split orn' ps | orn' == orn → scale r ps
    -- If a Split has the opposite orientation, we just nest.
    _ → List.singleton (r × p)

  goSplit splice off pre Nil = List.reverse pre
  goSplit splice off pre (t@(r × p) : ps)
    | ratio >= off + r || ratio == off =
        goSplit splice (off + r) (t : pre) ps
    | otherwise =
        List.reverse pre
        <> splice off r p
        <> ps

-- | Changes the location of an edge within a Split. If the new location is
-- | passed the edges of adjacent Panes, then all Panes to that side will be
-- | scaled using the provided scaling function.
resizeEdge
  ∷ ∀ a
  . (Rational → List (Rational × Pane a) → List (Rational × Pane a))
  → Int
  → Rational
  → Cursor
  → Pane a
  → Maybe (Pane a)
resizeEdge scaleFn edge offset' cursor = map compressRoot ∘ join ∘ runCursor resize merge cursor
  where
  resize p = case p of
    Cell a → Nothing
    Split orn ps →
      Split orn ∘ resize' ps <$> goEdge 0 zero Nil ps

  resize' ps { offset, pre, post, a: r1 × p1, b: r2 × p2 } =
    case compare offset' offset of
      EQ → ps
      LT | offset - offset' >= r1 →
        let
          ratio = offset' / offset
          cell  = r2 + (offset - offset') × p2
        in
          if offset' == zero
            then cell : post
            else scaleFn ratio (List.snoc pre (r1 × p1)) <> (cell : post)
      LT →
        let
          cell1 = (r1 - (offset - offset')) × p1
          cell2 = (r2 + (offset - offset')) × p2
        in
          pre <> (cell1 : cell2 : post)
      GT | offset' - offset >= r2 →
        let
          ratio = (one - offset') / (one - offset)
          cell  = (r1 + offset' - offset) × p1
        in
          if offset' == one
            then List.snoc pre cell
            else pre <> (cell : scaleFn ratio ((r2 × p2) : post))
      GT →
        let
          cell1 = (r1 + (offset' - offset)) × p1
          cell2 = (r2 - (offset' - offset)) × p2
        in
          pre <> (cell1 : cell2 : post)

  merge orn ps ix p =
    map (defaultMerge orn ps ix) p

  goEdge i off pre (a@(r1 × p1) : b@(r2 × p2) : post)
    | edge == i =
        Just { offset: off + r1, pre: List.reverse pre, post, a, b }
    | otherwise =
        goEdge (i + 1) (off + r1) (a : pre) (b : post)
  goEdge _ _ _ _ = Nothing

-- | Scales with a default relative scaling function.
resizeEdge' ∷ ∀ a . Int → Rational → Cursor → Pane a → Maybe (Pane a)
resizeEdge' = resizeEdge scale

deleteCell ∷ ∀ a. Cursor → Pane a → Maybe (Pane a)
deleteCell cursor = map compressRoot ∘ join ∘ runCursor (const Nothing) merge cursor
  where
  merge orn ps ix = case _ of
    Nothing →
      collapse orn =<< goIx 0 ix Nil ps
    Just p →
      Just (defaultMerge orn ps ix p)

  collapse orn p =
    let
      ps = case p of
        r × Nil × Nil →
          Nothing
        r × Nil × ((r2 × p2) : post) →
          Just (((r2 + r) × p2) : post)
        r × ((r1 × p1) : pre) × Nil →
          Just (List.reverse (((r1 + r) × p1) : pre))
        r × ((r1 × p1) : pre) × ((r2 × p2) : post) →
          Just (List.reverse (((r1 + r * (1%2)) × p1) : pre)
            <> (((r2 + r * (1%2)) × p2) : post))
    in ps <#>
      case _ of
        (r × (Split orn' ps')) : Nil →
          Split orn' ps'
        ps' →
          Split orn ps'

  goIx i ix pre Nil = Nothing
  goIx i ix pre ((r × _) : post) | i == ix = Just (r × pre × post)
  goIx i ix pre (p : post) = goIx (i + 1) ix (p : pre) post

absoluteRect
  ∷ ∀ r
  . { width ∷ Number, height ∷ Number | r }
  → Rect Rational
  → Rect Number
absoluteRect s r =
  let
    top = floor (Rational.toNumber r.top * s.height)
    left = floor (Rational.toNumber r.left * s.width)
    width =
      if r.left + r.width == one
        then s.width - left
        else floor (Rational.toNumber r.width * s.width)
    height =
      if r.top + r.height == one
        then s.height - top
        else floor (Rational.toNumber r.height * s.height)
  in
    { top, left, width, height }

absoluteVect
  ∷ ∀ r
  . { width ∷ Number, height ∷ Number | r }
  → Orientation
  → Vect Rational
  → Vect Number
absoluteVect s orn v =
  let
    x = floor (Rational.toNumber v.x * s.width)
    y = floor (Rational.toNumber v.y * s.height)
    z =
      case orn of
        Horizontal →
          if v.y + v.z == one
            then s.height - y
            else floor (Rational.toNumber v.z * s.height)
        Vertical →
          if v.x + v.z == one
            then s.width - x
            else floor (Rational.toNumber v.z * s.width)
  in
    { x, y, z }

absoluteCells
  ∷ ∀ a r
  . { width ∷ Number, height ∷ Number | r }
  → List (Cell a Rational)
  → List (Cell a Number)
absoluteCells s =
  map (\c → c { rect = absoluteRect s c.rect })

absoluteEdges
  ∷ ∀ r
  . { width ∷ Number, height ∷ Number | r }
  → List (Edge Rational)
  → List (Edge Number)
absoluteEdges s =
  map (\e → e { vect = absoluteVect s e.orientation e.vect })

ratios ∷ List Rational
ratios =
  List.sort $ List.nub do
    d ← List.fromFoldable [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 12, 16 ]
    n ← List.range 0 d
    pure (n%d)

closestSnapRatio ∷ Number → Rational
closestSnapRatio r = findClosest (\b → Rational.toNumber b - r) one ratios

findClosest ∷ ∀ f a. Foldable f ⇒ (a → Number) → a → f a → a
findClosest f = foldl go
  where
  go a b
    | abs (f b) < abs (f a) = b
    | otherwise = a

scale ∷ ∀ f a. Functor f ⇒ Rational → f (Rational × a) → f (Rational × a)
scale n = map (lmap (n * _))

spliceAt ∷ ∀ a. (a → List a) → Int → List a → Maybe (List a)
spliceAt f = go Nil 0
  where
  go pre i ix (x : xs)
    | i == ix = Just (List.reverse pre <> f x <> xs)
    | otherwise = go (x : pre) (i + 1) ix xs
  go _ _ _ _ = Nothing

defaultMerge
  ∷ ∀ a
  . Orientation
  → List (Rational × Pane a)
  → Int
  → Pane a
  → Pane a
defaultMerge orn ps ix p =
  case p of
    Cell a →
      case ps of
        Nil →
          Split orn (List.singleton (one × p))
        _ : Nil →
          Split orn (List.singleton (one × p))
        _ →
          Split orn (updateSndAt (wrap (reverse orn) p) ix ps)
    Split orn' ps' | orn /= orn' →
      case ps' of
        (_ × Split _ ps'') : Nil →
          Split orn (assimilated ps'')
        _ →
          case ps of
            (_ × p') : Nil →
              p'
            _ →
              Split orn (updateSndAt p ix ps)
    Split orn' ps' →
      Split orn (assimilated ps')

  where
  assimilated ps' =
    fromMaybe ps (spliceAt (\(r × _) → assimilate orn r ps') ix ps)

assimilate
  ∷ ∀ a
  . Orientation
  → Rational
  → List (Rational × Pane a)
  → List (Rational × Pane a)
assimilate orn r ps = do
  r' × p ← ps
  case p of
    Cell _ →
      List.singleton (r * r' × wrap (reverse orn) p)
    Split orn' ps' | orn /= orn' →
      List.singleton (r * r' × compress p)
    Split orn' ps' →
      assimilate orn (r * r') ps'

compress ∷ ∀ a. Pane a → Pane a
compress p =
  case p of
    Cell a →
      p
    Split orn ps → Split orn
      case ps of
        (_ × Cell a') : Nil →
          ps
        _ →
          assimilate orn one ps

compressRoot ∷ ∀ a. Pane a → Pane a
compressRoot p =
  case p of
    Split _ ((_ × (Split _ ((_ × (Cell a)) : Nil))) : Nil) → Cell a
    Split _ ((_ × (Cell a)) : Nil) → Cell a
    _ → p

modifySndAt ∷ ∀ a b. (b → b) → Int → List (a × b) → List (a × b)
modifySndAt f ix l = fromMaybe l (List.modifyAt ix (map f) l)

updateSndAt ∷ ∀ a b. b → Int → List (a × b) → List (a × b)
updateSndAt = modifySndAt ∘ const

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Draftboard.Layout
  ( SplitBias(..)
  , Rect
  , Vect
  , Cell
  , Edge
  , locatorToRect
  , eqEdge
  , rectAt
  , cells
  , edges
  , findSplit
  , insertSplit
  , resizeEdge
  , resizeEdge'
  , deleteCell
  , absoluteRect
  , absoluteVect
  , absoluteCells
  , absoluteEdges
  , closestSnapRatio
  , defaultMerge
  ) where

import SlamData.Prelude
import Data.List (List(..), (:))
import Data.List as List
import Data.Rational (Rational, (%))
import Data.Rational as Rational
import Math (floor, abs)

import SlamData.Workspace.Card.Draftboard.Orientation (Orientation(..), reverse)
import SlamData.Workspace.Card.Draftboard.Pane (Pane(..), Locator(..), Cursor, runCursor, walkWithLocator, getAtWithLocator, wrap)

data SplitBias
  = SideA
  | SideB

type Rect a =
  { top ∷ a
  , left ∷ a
  , width ∷ a
  , height ∷ a
  }

type Vect a =
  { x ∷ a
  , y ∷ a
  , z ∷ a
  }

type Cell a b =
  { cursor ∷ Cursor
  , value ∷ a
  , rect ∷ Rect b
  }

type Edge a =
  { index ∷ Int
  , parent ∷ Cursor
  , orientation ∷ Orientation
  , ratio ∷ Rational
  , vect ∷ Vect a
  }

locatorToRect ∷ Locator → Rect Rational
locatorToRect (Locator _ left top width height _ _) =
  { top, left, width, height }

-- | Edges are semantically equal if their cursor and index are equal.
eqEdge ∷ ∀ a b. Edge a → Edge b → Boolean
eqEdge a b = a.parent == b.parent && a.index == b.index

-- | Calculates the rectangle for a given Cursor.
rectAt ∷ ∀ a . Cursor → Pane a → Maybe (Rect Rational)
rectAt cursor = map (locatorToRect <<< fst) <<< getAtWithLocator cursor

-- | Collects all cells with their computed locations
cells ∷ ∀ a . Pane a → List (Cell a Rational)
cells = walkWithLocator go Nil
  where
  go (Locator cursor left top width height _ _) cs (Cell value) =
    { cursor
    , value
    , rect: { top, left, width, height }
    } : cs
  go _ cs _ = cs

-- | Collects all the computed edges with their vectors. This does not include
-- | the edges for the root.
edges ∷ ∀ a . Pane a → List (Edge Rational)
edges = walkWithLocator go Nil
  where
  go _ es (Cell _) = es
  go (Locator c x y w h _ _) es (Split orn panes) =
    goEdges x y zero 0 Nil panes <> es

    where
    goEdges x y off ix acc ps =
      let
        edge = case ps of
          (r × p) : (r' × p') : _ →
            let
              vect = case orn of
                Horizontal → { x: x + r * w, y, z: h }
                Vertical   → { x, y: y + r * h, z: w }
              in
                List.singleton
                  { index: ix
                  , parent: c
                  , orientation: orn
                  , ratio: off + r
                  , vect
                  }
          _ → Nil
      in
        case ps of
          Nil → acc
          (r × p) : ps' →
            case orn of
              Horizontal →
                goEdges (r * w + x) y (off + r) (ix + 1) (edge <> acc) ps'
              Vertical →
                goEdges x (r * h + y) (off + r) (ix + 1) (edge <> acc) ps'

-- | Finds the deepest split for a given orientation and cursor.
findSplit
  ∷ ∀ a
  . Orientation
  → Cursor
  → Pane a
  → Maybe Cursor
findSplit orn cursor =
  map (List.reverse) <=< runCursor
    (case _ of
      Split orn' _ | orn' == orn → Just Nil
      _ → Nothing)
    (\orn' _ ix r →
      case r of
        Just c → Just (ix : c)
        _ | orn' == orn → Just Nil
        _ → Nothing)
    cursor

-- | Inserts a new split into a Pane at a given ratio. If the Cursor points to
-- | a Split, then the Pane at that ratio will be resized appropriately.
insertSplit
  ∷ ∀ a
  . Pane a
  → Orientation
  → Rational
  → SplitBias
  → Cursor
  → Pane a
  → Maybe (Pane a)
insertSplit pane orn ratio side = runCursor split defaultMerge
  where
  split p = Split orn case p of
    -- When splitting an existing Split of a given orientation, we need to
    -- split the Pane that is at the given ratio.
    Split orn' ps | orn' == orn →
      goSplit (\off r p' → scale r (splitAt ((ratio - off) / r) p' pane)) zero Nil ps
    _ →
      splitAt ratio p pane

  splitAt ∷ Rational → Pane a → Pane a → List (Rational × Pane a)
  splitAt r cell1 cell2 =
    case side of
      SideA → scaleOrWrap r cell2 <> scaleOrWrap (one - r) cell1
      SideB → scaleOrWrap r cell1 <> scaleOrWrap (one - r) cell2

  scaleOrWrap ∷ Rational → Pane a → List (Rational × Pane a)
  scaleOrWrap r p = case p of
    -- Cells need to be wrapped in a single Split of the opposite orientation.
    -- This ensures we can keep alternating splits.
    Cell a → List.singleton (r × wrap (reverse orn) p)
    -- If a Split has the same orientation, we want to assimilate into the
    -- existing split, so we should just scale as needed.
    Split orn' ps | orn' == orn → scale r ps
    -- If a Split has the opposite orientation, we just nest.
    _ → List.singleton (r × p)

  goSplit splice off pre Nil = List.reverse pre
  goSplit splice off pre (t@(r × p) : ps)
    | ratio >= off + r || ratio == off =
        goSplit splice (off + r) (t : pre) ps
    | otherwise =
        List.reverse pre
        <> splice off r p
        <> ps

-- | Changes the location of an edge within a Split. If the new location is
-- | passed the edges of adjacent Panes, then all Panes to that side will be
-- | scaled using the provided scaling function.
resizeEdge
  ∷ ∀ a
  . (Rational → List (Rational × Pane a) → List (Rational × Pane a))
  → Int
  → Rational
  → Cursor
  → Pane a
  → Maybe (Pane a)
resizeEdge scaleFn edge offset' cursor = map compressRoot ∘ join ∘ runCursor resize merge cursor
  where
  resize p = case p of
    Cell a → Nothing
    Split orn ps →
      Split orn ∘ resize' ps <$> goEdge 0 zero Nil ps

  resize' ps { offset, pre, post, a: r1 × p1, b: r2 × p2 } =
    case compare offset' offset of
      EQ → ps
      LT | offset - offset' >= r1 →
        let
          ratio = offset' / offset
          cell  = r2 + (offset - offset') × p2
        in
          if offset' == zero
            then cell : post
            else scaleFn ratio (List.snoc pre (r1 × p1)) <> (cell : post)
      LT →
        let
          cell1 = (r1 - (offset - offset')) × p1
          cell2 = (r2 + (offset - offset')) × p2
        in
          pre <> (cell1 : cell2 : post)
      GT | offset' - offset >= r2 →
        let
          ratio = (one - offset') / (one - offset)
          cell  = (r1 + offset' - offset) × p1
        in
          if offset' == one
            then List.snoc pre cell
            else pre <> (cell : scaleFn ratio ((r2 × p2) : post))
      GT →
        let
          cell1 = (r1 + (offset' - offset)) × p1
          cell2 = (r2 - (offset' - offset)) × p2
        in
          pre <> (cell1 : cell2 : post)

  merge orn ps ix p =
    map (defaultMerge orn ps ix) p

  goEdge i off pre (a@(r1 × p1) : b@(r2 × p2) : post)
    | edge == i =
        Just { offset: off + r1, pre: List.reverse pre, post, a, b }
    | otherwise =
        goEdge (i + 1) (off + r1) (a : pre) (b : post)
  goEdge _ _ _ _ = Nothing

-- | Scales with a default relative scaling function.
resizeEdge' ∷ ∀ a . Int → Rational → Cursor → Pane a → Maybe (Pane a)
resizeEdge' = resizeEdge scale

deleteCell ∷ ∀ a. Cursor → Pane a → Maybe (Pane a)
deleteCell cursor = map compressRoot ∘ join ∘ runCursor (const Nothing) merge cursor
  where
  merge orn ps ix = case _ of
    Nothing →
      Split orn <$> (collapse =<< goIx 0 ix Nil ps)
    Just p →
      Just (defaultMerge orn ps ix p)

  collapse p =
    let
      ps = case p of
        r × Nil × Nil →
          Nothing
        r × Nil × ((r2 × p2) : post) →
          Just (((r2 + r) × p2) : post)
        r × ((r1 × p1) : pre) × Nil →
          Just (List.reverse (((r1 + r) × p1) : pre))
        r × ((r1 × p1) : pre) × ((r2 × p2) : post) →
          Just (List.reverse (((r1 + r * (1%2)) × p1) : pre)
            <> (((r2 + r * (1%2)) × p2) : post))
    in ps <#>
      case _ of
        (r × (Split _ ps')) : Nil →
          ps'
        ps' →
          ps'

  goIx i ix pre Nil = Nothing
  goIx i ix pre ((r × _) : post) | i == ix = Just (r × pre × post)
  goIx i ix pre (p : post) = goIx (i + 1) ix (p : pre) post

absoluteRect
  ∷ ∀ r
  . { width ∷ Number, height ∷ Number | r }
  → Rect Rational
  → Rect Number
absoluteRect s r =
  let
    top = floor (Rational.toNumber r.top * s.height)
    left = floor (Rational.toNumber r.left * s.width)
    width =
      if r.left + r.width == one
        then s.width - left
        else floor (Rational.toNumber r.width * s.width)
    height =
      if r.top + r.height == one
        then s.height - top
        else floor (Rational.toNumber r.height * s.height)
  in
    { top, left, width, height }

absoluteVect
  ∷ ∀ r
  . { width ∷ Number, height ∷ Number | r }
  → Orientation
  → Vect Rational
  → Vect Number
absoluteVect s orn v =
  let
    x = floor (Rational.toNumber v.x * s.width)
    y = floor (Rational.toNumber v.y * s.height)
    z =
      case orn of
        Horizontal →
          if v.y + v.z == one
            then s.height - y
            else floor (Rational.toNumber v.z * s.height)
        Vertical →
          if v.x + v.z == one
            then s.width - x
            else floor (Rational.toNumber v.z * s.width)
  in
    { x, y, z }

absoluteCells
  ∷ ∀ a r
  . { width ∷ Number, height ∷ Number | r }
  → List (Cell a Rational)
  → List (Cell a Number)
absoluteCells s =
  map (\c → c { rect = absoluteRect s c.rect })

absoluteEdges
  ∷ ∀ r
  . { width ∷ Number, height ∷ Number | r }
  → List (Edge Rational)
  → List (Edge Number)
absoluteEdges s =
  map (\e → e { vect = absoluteVect s e.orientation e.vect })

ratios ∷ List Rational
ratios =
  List.sort $ List.nub do
    d ← List.fromFoldable [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 12, 16 ]
    n ← List.range 0 d
    pure (n%d)

closestSnapRatio ∷ Number → Rational
closestSnapRatio r = findClosest (\b → Rational.toNumber b - r) one ratios

findClosest ∷ ∀ f a. Foldable f ⇒ (a → Number) → a → f a → a
findClosest f = foldl go
  where
  go a b
    | abs (f b) < abs (f a) = b
    | otherwise = a

scale ∷ ∀ f a. Functor f ⇒ Rational → f (Rational × a) → f (Rational × a)
scale n = map (lmap (n * _))

spliceAt ∷ ∀ a. (a → List a) → Int → List a → Maybe (List a)
spliceAt f = go Nil 0
  where
  go pre i ix (x : xs)
    | i == ix = Just (List.reverse pre <> f x <> xs)
    | otherwise = go (x : pre) (i + 1) ix xs
  go _ _ _ _ = Nothing

defaultMerge
  ∷ ∀ a
  . Orientation
  → List (Rational × Pane a)
  → Int
  → Pane a
  → Pane a
defaultMerge orn ps ix p =
  case p of
    Cell a →
      case ps of
        Nil →
          Split orn (List.singleton (one × p))
        _ : Nil →
          Split orn (List.singleton (one × p))
        _ →
          Split orn (updateSndAt (wrap (reverse orn) p) ix ps)
    Split orn' ps' | orn /= orn' →
      case ps' of
        (_ × Split _ ps'') : Nil →
          Split orn (assimilated ps'')
        _ →
          case ps of
            (_ × p') : Nil →
              p'
            _ →
              Split orn (updateSndAt p ix ps)
    Split orn' ps' →
      Split orn (assimilated ps')

  where
  assimilated ps' =
    fromMaybe ps (spliceAt (\(r × _) → assimilate orn r ps') ix ps)

assimilate
  ∷ ∀ a
  . Orientation
  → Rational
  → List (Rational × Pane a)
  → List (Rational × Pane a)
assimilate orn r ps = do
  r' × p ← ps
  case p of
    Cell _ →
      List.singleton (r * r' × wrap (reverse orn) p)
    Split orn' ps' | orn /= orn' →
      List.singleton (r * r' × compress p)
    Split orn' ps' →
      assimilate orn (r * r') ps'

compress ∷ ∀ a. Pane a → Pane a
compress p =
  case p of
    Cell a →
      p
    Split orn ps → Split orn
      case ps of
        (_ × Cell a') : Nil →
          ps
        _ →
          assimilate orn one ps

compressRoot ∷ ∀ a. Pane a → Pane a
compressRoot p =
  case p of
    Split _ ((_ × (Split _ ((_ × (Cell a)) : Nil))) : Nil) → Cell a
    Split _ ((_ × (Cell a)) : Nil) → Cell a
    _ → p

modifySndAt ∷ ∀ a b. (b → b) → Int → List (a × b) → List (a × b)
modifySndAt f ix l = fromMaybe l (List.modifyAt ix (map f) l)

updateSndAt ∷ ∀ a b. b → Int → List (a × b) → List (a × b)
updateSndAt = modifySndAt ∘ const


Add the `gate` and `gateBy` functions (#19)

Now, a `Behavior` can be sampled on an `Event` according to a
predicate. This is pretty exciting; it's basically a dynamic
`filter`.

module FRP.Behavior
  ( Behavior
  , ABehavior
  , behavior
  , step
  , sample
  , sampleBy
  , sample_
  , gate
  , gateBy
  , unfold
  , integral
  , integral'
  , derivative
  , derivative'
  , solve
  , solve'
  , solve2
  , solve2'
  , fixB
  , animate
  ) where

import Prelude

import Control.Alt (alt)
import Control.Apply (lift2)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Unsafe (unsafePerformEff)
import Data.Filterable (filtered)
import Data.Function (applyFlipped)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid, mempty)
import Data.Tuple (Tuple(Tuple))
import FRP (FRP)
import FRP.Event (class IsEvent, Event, create, fold, sampleOn, subscribe, withLast)
import FRP.Event.Time (animationFrame)

-- | `ABehavior` is the more general type of `Behavior`, which is parameterized
-- | over some underlying `event` type.
-- |
-- | Normally, you should use `Behavior` instead, but this type
-- | can also be used with other types of events, including the ones in the
-- | `Semantic` module.
newtype ABehavior event a = ABehavior (forall b. event (a -> b) -> event b)

-- | A `Behavior` acts like a continuous function of time.
-- |
-- | We can construct a sample a `Behavior` from some `Event`, combine `Behavior`s
-- | using `Applicative`, and sample a final `Behavior` on some other `Event`.
type Behavior = ABehavior Event

instance functorABehavior :: Functor event => Functor (ABehavior event) where
  map f (ABehavior b) = ABehavior \e -> b (map (_ <<< f) e)

instance applyABehavior :: Functor event => Apply (ABehavior event) where
  apply (ABehavior f) (ABehavior a) = ABehavior \e -> a (f (compose <$> e))

instance applicativeABehavior :: Functor event => Applicative (ABehavior event) where
  pure a = ABehavior \e -> applyFlipped a <$> e

instance semigroupABehavior :: (Functor event, Semigroup a) => Semigroup (ABehavior event a) where
  append = lift2 append

instance monoidABehavior :: (Functor event, Monoid a) => Monoid (ABehavior event a) where
  mempty = pure mempty

-- | Construct a `Behavior` from its sampling function.
behavior :: forall event a. (forall b. event (a -> b) -> event b) -> ABehavior event a
behavior = ABehavior

-- | Create a `Behavior` which is updated when an `Event` fires, by providing
-- | an initial value.
step :: forall event a. IsEvent event => a -> event a -> ABehavior event a
step a e = ABehavior (sampleOn (pure a `alt` e))

-- | Create a `Behavior` which is updated when an `Event` fires, by providing
-- | an initial value and a function to combine the current value with a new event
-- | to create a new value.
unfold :: forall event a b. IsEvent event => (a -> b -> b) -> event a -> b -> ABehavior event b
unfold f e a = step a (fold f e a)

-- | Sample a `Behavior` on some `Event`.
sample :: forall event a b. ABehavior event a -> event (a -> b) -> event b
sample (ABehavior b) e = b e

-- | Sample a `Behavior` on some `Event` by providing a combining function.
sampleBy :: forall event a b c. IsEvent event => (a -> b -> c) -> ABehavior event a -> event b -> event c
sampleBy f b e = sample (map f b) (map applyFlipped e)

-- | Sample a `Behavior` on some `Event`, discarding the event's values.
sample_ :: forall event a b. IsEvent event => ABehavior event a -> event b -> event a
sample_ = sampleBy const

-- | Sample a `Behavior` on some `Event` by providing a predicate function.
gateBy :: forall event p a. IsEvent event => (p -> a -> Boolean) -> ABehavior event p -> event a -> event a
gateBy f ps xs = filtered (sampleBy (\p x -> if f p x then Just x else Nothing) ps xs)

-- | Filter an `Event` by the boolean value of a `Behavior`.
gate :: forall event a. IsEvent event => ABehavior event Boolean -> event a -> event a
gate = gateBy const

-- | Integrate with respect to some measure of time.
-- |
-- | This function approximates the integral using the trapezium rule at the
-- | implicit sampling interval.
-- |
-- | The `Semiring` `a` should be a vector field over the field `t`. To represent
-- | this, the user should provide a _grate_ which lifts a multiplication
-- | function on `t` to a function on `a`. Simple examples where `t ~ a` can use
-- | the `integral'` function instead.
integral
  :: forall event a t
   . IsEvent event
  => Field t
  => Semiring a
  => (((a -> t) -> t) -> a)
  -> a
  -> ABehavior event t
  -> ABehavior event a
  -> ABehavior event a
integral g initial t b =
    ABehavior \e ->
      let x = sample b (e $> id)
          y = withLast (sampleBy Tuple t x)
          z = fold approx y initial
      in e <*> z
  where
    approx { last: Nothing } s = s
    approx { now: Tuple t1 a1, last: Just (Tuple t0 a0) } s = s + g (\f -> f (a0 + a1) * (t1 - t0) / two)

    two :: t
    two = one + one

-- | Integrate with respect to some measure of time.
-- |
-- | This function is a simpler version of `integral` where the function being
-- | integrated takes values in the same field used to represent time.
integral'
  :: forall event t
   . IsEvent event
  => Field t
  => t
  -> ABehavior event t
  -> ABehavior event t
  -> ABehavior event t
integral' = integral (_ $ id)

-- | Differentiate with respect to some measure of time.
-- |
-- | This function approximates the derivative using a quotient of differences at the
-- | implicit sampling interval.
-- |
-- | The `Semiring` `a` should be a vector field over the field `t`. To represent
-- | this, the user should provide a grate which lifts a division
-- | function on `t` to a function on `a`. Simple examples where `t ~ a` can use
-- | the `derivative'` function.
derivative
  :: forall event a t
   . IsEvent event
  => Field t
  => Ring a
  => (((a -> t) -> t) -> a)
  -> ABehavior event t
  -> ABehavior event a
  -> ABehavior event a
derivative g t b =
    ABehavior \e ->
      let x = sample b (e $> id)
          y = withLast (sampleBy Tuple t x)
          z = map approx y
      in e <*> z
  where
    approx { last: Nothing } = zero
    approx { now: Tuple t1 a1, last: Just (Tuple t0 a0) } = g (\f -> f (a1 - a0) / (t1 - t0))

-- | Differentiate with respect to some measure of time.
-- |
-- | This function is a simpler version of `derivative` where the function being
-- | differentiated takes values in the same field used to represent time.
derivative'
  :: forall event t
   . IsEvent event
  => Field t
  => ABehavior event t
  -> ABehavior event t
  -> ABehavior event t
derivative' = derivative (_ $ id)

-- | Compute a fixed point
fixB :: forall a. a -> (ABehavior Event a -> ABehavior Event a) -> ABehavior Event a
fixB a f = behavior \s -> unsafePerformEff do
  { event, push } <- create
  let b = f (step a event)
  subscribe (sample_ b s) push
  pure (sampleOn event s)

-- | Solve a first order differential equation of the form
-- |
-- | ```
-- | da/dt = f a
-- | ```
-- |
-- | by integrating once (specifying the initial conditions).
-- |
-- | For example, the exponential function with growth rate `⍺`:
-- |
-- | ```purescript
-- | exp = solve' 1.0 Time.seconds (⍺ * _)
-- | ```
solve
  :: forall t a
   . Field t
  => Semiring a
  => (((a -> t) -> t) -> a)
  -> a
  -> Behavior t
  -> (Behavior a -> Behavior a)
  -> Behavior a
solve g a0 t f = fixB a0 \b -> integral g a0 t (f b)

-- | Solve a first order differential equation.
-- |
-- | This function is a simpler version of `solve` where the function being
-- | integrated takes values in the same field used to represent time.
solve'
  :: forall a
   . Field a
  => a
  -> Behavior a
  -> (Behavior a -> Behavior a)
  -> Behavior a
solve' = solve (_ $ id)

-- | Solve a second order differential equation of the form
-- |
-- | ```
-- | d^2a/dt^2 = f a (da/dt)
-- | ```
-- |
-- | by integrating twice (specifying the initial conditions).
-- |
-- | For example, an (damped) oscillator:
-- |
-- | ```purescript
-- | oscillate = solve2' 1.0 0.0 Time.seconds (\x dx -> -⍺ * x - δ * dx)
-- | ```
solve2
  :: forall t a
   . Field t
  => Semiring a
  => (((a -> t) -> t) -> a)
  -> a
  -> a
  -> Behavior t
  -> (Behavior a -> Behavior a -> Behavior a)
  -> Behavior a
solve2 g a0 da0 t f =
  fixB a0 \b ->
    integral g a0 t
      (fixB da0 \db ->
        integral g da0 t (f b db))

-- | Solve a second order differential equation.
-- |
-- | This function is a simpler version of `solve2` where the function being
-- | integrated takes values in the same field used to represent time.
solve2'
  :: forall a
   . Field a
  => a
  -> a
  -> Behavior a
  -> (Behavior a -> Behavior a -> Behavior a)
  -> Behavior a
solve2' = solve2 (_ $ id)

-- | Animate a `Behavior` by providing a rendering function.
animate
  :: forall scene eff
   . ABehavior Event scene
  -> (scene -> Eff (frp :: FRP | eff) Unit)
  -> Eff (frp :: FRP | eff) Unit
animate scene render = subscribe (sample_ scene animationFrame) render

module FRP.Behavior
  ( Behavior
  , ABehavior
  , behavior
  , step
  , sample
  , sampleBy
  , sample_
  , unfold
  , integral
  , integral'
  , derivative
  , derivative'
  , solve
  , solve'
  , solve2
  , solve2'
  , fixB
  , animate
  ) where

import Prelude

import Control.Alt (alt)
import Control.Apply (lift2)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Unsafe (unsafePerformEff)
import Data.Function (applyFlipped)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid, mempty)
import Data.Tuple (Tuple(Tuple))
import FRP (FRP)
import FRP.Event (class IsEvent, Event, create, fold, sampleOn, subscribe, withLast)
import FRP.Event.Time (animationFrame)

-- | `ABehavior` is the more general type of `Behavior`, which is parameterized
-- | over some underlying `event` type.
-- |
-- | Normally, you should use `Behavior` instead, but this type
-- | can also be used with other types of events, including the ones in the
-- | `Semantic` module.
newtype ABehavior event a = ABehavior (forall b. event (a -> b) -> event b)

-- | A `Behavior` acts like a continuous function of time.
-- |
-- | We can construct a sample a `Behavior` from some `Event`, combine `Behavior`s
-- | using `Applicative`, and sample a final `Behavior` on some other `Event`.
type Behavior = ABehavior Event

instance functorABehavior :: Functor event => Functor (ABehavior event) where
  map f (ABehavior b) = ABehavior \e -> b (map (_ <<< f) e)

instance applyABehavior :: Functor event => Apply (ABehavior event) where
  apply (ABehavior f) (ABehavior a) = ABehavior \e -> a (f (compose <$> e))

instance applicativeABehavior :: Functor event => Applicative (ABehavior event) where
  pure a = ABehavior \e -> applyFlipped a <$> e

instance semigroupABehavior :: (Functor event, Semigroup a) => Semigroup (ABehavior event a) where
  append = lift2 append

instance monoidABehavior :: (Functor event, Monoid a) => Monoid (ABehavior event a) where
  mempty = pure mempty

-- | Construct a `Behavior` from its sampling function.
behavior :: forall event a. (forall b. event (a -> b) -> event b) -> ABehavior event a
behavior = ABehavior

-- | Create a `Behavior` which is updated when an `Event` fires, by providing
-- | an initial value.
step :: forall event a. IsEvent event => a -> event a -> ABehavior event a
step a e = ABehavior (sampleOn (pure a `alt` e))

-- | Create a `Behavior` which is updated when an `Event` fires, by providing
-- | an initial value and a function to combine the current value with a new event
-- | to create a new value.
unfold :: forall event a b. IsEvent event => (a -> b -> b) -> event a -> b -> ABehavior event b
unfold f e a = step a (fold f e a)

-- | Sample a `Behavior` on some `Event`.
sample :: forall event a b. ABehavior event a -> event (a -> b) -> event b
sample (ABehavior b) e = b e

-- | Sample a `Behavior` on some `Event` by providing a combining function.
sampleBy :: forall event a b c. IsEvent event => (a -> b -> c) -> ABehavior event a -> event b -> event c
sampleBy f b e = sample (map f b) (map applyFlipped e)

-- | Sample a `Behavior` on some `Event`, discarding the event's values.
sample_ :: forall event a b. IsEvent event => ABehavior event a -> event b -> event a
sample_ = sampleBy const

-- | Integrate with respect to some measure of time.
-- |
-- | This function approximates the integral using the trapezium rule at the
-- | implicit sampling interval.
-- |
-- | The `Semiring` `a` should be a vector field over the field `t`. To represent
-- | this, the user should provide a _grate_ which lifts a multiplication
-- | function on `t` to a function on `a`. Simple examples where `t ~ a` can use
-- | the `integral'` function instead.
integral
  :: forall event a t
   . IsEvent event
  => Field t
  => Semiring a
  => (((a -> t) -> t) -> a)
  -> a
  -> ABehavior event t
  -> ABehavior event a
  -> ABehavior event a
integral g initial t b =
    ABehavior \e ->
      let x = sample b (e $> id)
          y = withLast (sampleBy Tuple t x)
          z = fold approx y initial
      in e <*> z
  where
    approx { last: Nothing } s = s
    approx { now: Tuple t1 a1, last: Just (Tuple t0 a0) } s = s + g (\f -> f (a0 + a1) * (t1 - t0) / two)

    two :: t
    two = one + one

-- | Integrate with respect to some measure of time.
-- |
-- | This function is a simpler version of `integral` where the function being
-- | integrated takes values in the same field used to represent time.
integral'
  :: forall event t
   . IsEvent event
  => Field t
  => t
  -> ABehavior event t
  -> ABehavior event t
  -> ABehavior event t
integral' = integral (_ $ id)

-- | Differentiate with respect to some measure of time.
-- |
-- | This function approximates the derivative using a quotient of differences at the
-- | implicit sampling interval.
-- |
-- | The `Semiring` `a` should be a vector field over the field `t`. To represent
-- | this, the user should provide a grate which lifts a division
-- | function on `t` to a function on `a`. Simple examples where `t ~ a` can use
-- | the `derivative'` function.
derivative
  :: forall event a t
   . IsEvent event
  => Field t
  => Ring a
  => (((a -> t) -> t) -> a)
  -> ABehavior event t
  -> ABehavior event a
  -> ABehavior event a
derivative g t b =
    ABehavior \e ->
      let x = sample b (e $> id)
          y = withLast (sampleBy Tuple t x)
          z = map approx y
      in e <*> z
  where
    approx { last: Nothing } = zero
    approx { now: Tuple t1 a1, last: Just (Tuple t0 a0) } = g (\f -> f (a1 - a0) / (t1 - t0))

-- | Differentiate with respect to some measure of time.
-- |
-- | This function is a simpler version of `derivative` where the function being
-- | differentiated takes values in the same field used to represent time.
derivative'
  :: forall event t
   . IsEvent event
  => Field t
  => ABehavior event t
  -> ABehavior event t
  -> ABehavior event t
derivative' = derivative (_ $ id)

-- | Compute a fixed point
fixB :: forall a. a -> (ABehavior Event a -> ABehavior Event a) -> ABehavior Event a
fixB a f = behavior \s -> unsafePerformEff do
  { event, push } <- create
  let b = f (step a event)
  subscribe (sample_ b s) push
  pure (sampleOn event s)

-- | Solve a first order differential equation of the form
-- |
-- | ```
-- | da/dt = f a
-- | ```
-- |
-- | by integrating once (specifying the initial conditions).
-- |
-- | For example, the exponential function with growth rate `⍺`:
-- |
-- | ```purescript
-- | exp = solve' 1.0 Time.seconds (⍺ * _)
-- | ```
solve
  :: forall t a
   . Field t
  => Semiring a
  => (((a -> t) -> t) -> a)
  -> a
  -> Behavior t
  -> (Behavior a -> Behavior a)
  -> Behavior a
solve g a0 t f = fixB a0 \b -> integral g a0 t (f b)

-- | Solve a first order differential equation.
-- |
-- | This function is a simpler version of `solve` where the function being
-- | integrated takes values in the same field used to represent time.
solve'
  :: forall a
   . Field a
  => a
  -> Behavior a
  -> (Behavior a -> Behavior a)
  -> Behavior a
solve' = solve (_ $ id)

-- | Solve a second order differential equation of the form
-- |
-- | ```
-- | d^2a/dt^2 = f a (da/dt)
-- | ```
-- |
-- | by integrating twice (specifying the initial conditions).
-- |
-- | For example, an (damped) oscillator:
-- |
-- | ```purescript
-- | oscillate = solve2' 1.0 0.0 Time.seconds (\x dx -> -⍺ * x - δ * dx)
-- | ```
solve2
  :: forall t a
   . Field t
  => Semiring a
  => (((a -> t) -> t) -> a)
  -> a
  -> a
  -> Behavior t
  -> (Behavior a -> Behavior a -> Behavior a)
  -> Behavior a
solve2 g a0 da0 t f =
  fixB a0 \b ->
    integral g a0 t
      (fixB da0 \db ->
        integral g da0 t (f b db))

-- | Solve a second order differential equation.
-- |
-- | This function is a simpler version of `solve2` where the function being
-- | integrated takes values in the same field used to represent time.
solve2'
  :: forall a
   . Field a
  => a
  -> a
  -> Behavior a
  -> (Behavior a -> Behavior a -> Behavior a)
  -> Behavior a
solve2' = solve2 (_ $ id)

-- | Animate a `Behavior` by providing a rendering function.
animate
  :: forall scene eff
   . ABehavior Event scene
  -> (scene -> Eff (frp :: FRP | eff) Unit)
  -> Eff (frp :: FRP | eff) Unit
animate scene render = subscribe (sample_ scene animationFrame) render


Add `Parity`

Add `Parity`

module Data.Int
  ( fromNumber
  , ceil
  , floor
  , round
  , toNumber
  , fromString
  , Radix
  , radix
  , binary
  , octal
  , decimal
  , hexadecimal
  , base36
  , fromStringAs
  , toStringAs
  , Parity(..)
  , parity
  , even
  , odd
  , pow
  ) where

import Prelude

import Data.Int.Bits ((.&.))
import Data.Maybe (Maybe(..), fromMaybe)
import Global (infinity)

import Math as Math

-- | Creates an `Int` from a `Number` value. The number must already be an
-- | integer and fall within the valid range of values for the `Int` type
-- | otherwise `Nothing` is returned.
fromNumber :: Number -> Maybe Int
fromNumber = fromNumberImpl Just Nothing

foreign import fromNumberImpl
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Number
  -> Maybe Int

-- | Convert a `Number` to an `Int`, by taking the closest integer equal to or
-- | less than the argument. Values outside the `Int` range are clamped, `NaN`
-- | and `Infinity` values return 0.
floor :: Number -> Int
floor = unsafeClamp <<< Math.floor

-- | Convert a `Number` to an `Int`, by taking the closest integer equal to or
-- | greater than the argument. Values outside the `Int` range are clamped,
-- | `NaN` and `Infinity` values return 0.
ceil :: Number -> Int
ceil = unsafeClamp <<< Math.ceil

-- | Convert a `Number` to an `Int`, by taking the nearest integer to the
-- | argument. Values outside the `Int` range are clamped, `NaN` and `Infinity`
-- | values return 0.
round :: Number -> Int
round = unsafeClamp <<< Math.round

-- | Convert an integral `Number` to an `Int`, by clamping to the `Int` range.
-- | This function will return 0 if the input is `NaN` or an `Infinity`.
unsafeClamp :: Number -> Int
unsafeClamp x
  | x == infinity = 0
  | x == -infinity = 0
  | x >= toNumber top = top
  | x <= toNumber bottom = bottom
  | otherwise = fromMaybe 0 (fromNumber x)

-- | Converts an `Int` value back into a `Number`. Any `Int` is a valid `Number`
-- | so there is no loss of precision with this function.
foreign import toNumber :: Int -> Number

-- | Reads an `Int` from a `String` value. The number must parse as an integer
-- | and fall within the valid range of values for the `Int` type, otherwise
-- | `Nothing` is returned.
fromString :: String -> Maybe Int
fromString = fromStringAs (Radix 10)

-- | A type for describing whether an integer is even or odd.
data Parity = Even | Odd

derive instance eqParity :: Eq Parity
derive instance ordParity :: Ord Parity

-- | Returns whether an `Int` is `Even` or `Odd`.
-- |
-- | ``` purescript
-- | parity 0 == Even
-- | parity 1 == Odd
-- | ```
parity :: Int -> Parity
parity n = if even n then Even else Odd

-- | Returns whether an `Int` is an even number.
-- |
-- | ``` purescript
-- | even 0 == true
-- | even 1 == false
-- | ```
even :: Int -> Boolean
even x = x .&. 1 == 0

-- | The negation of `even`.
-- |
-- | ``` purescript
-- | odd 0 == false
-- | odd 1 == true
-- | ```
odd :: Int -> Boolean
odd x = x .&. 1 /= 0

-- | The number of unique digits (including zero) used to represent integers in
-- | a specific base.
newtype Radix = Radix Int

-- | The base-2 system.
binary :: Radix
binary = Radix 2

-- | The base-8 system.
octal :: Radix
octal = Radix 8

-- | The base-10 system.
decimal :: Radix
decimal = Radix 10

-- | The base-16 system.
hexadecimal :: Radix
hexadecimal = Radix 16

-- | The base-36 system.
base36 :: Radix
base36 = Radix 36

-- | Create a `Radix` from a number between 2 and 36.
radix :: Int -> Maybe Radix
radix n | n >= 2 && n <= 36 = Just (Radix n)
        | otherwise         = Nothing

-- | Like `fromString`, but the integer can be specified in a different base.
-- |
-- | Example:
-- | ``` purs
-- | fromStringAs binary      "100" == Just 4
-- | fromStringAs hexadecimal "ff"  == Just 255
-- | ```
fromStringAs :: Radix -> String -> Maybe Int
fromStringAs = fromStringAsImpl Just Nothing

-- | Raise an Int to the power of another Int.
foreign import pow :: Int -> Int -> Int

foreign import fromStringAsImpl
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Radix
  -> String
  -> Maybe Int

foreign import toStringAs :: Radix -> Int -> String

module Data.Int
  ( fromNumber
  , ceil
  , floor
  , round
  , toNumber
  , fromString
  , Radix
  , radix
  , binary
  , octal
  , decimal
  , hexadecimal
  , base36
  , fromStringAs
  , toStringAs
  , even
  , odd
  , pow
  ) where

import Prelude

import Data.Int.Bits ((.&.))
import Data.Maybe (Maybe(..), fromMaybe)
import Global (infinity)

import Math as Math

-- | Creates an `Int` from a `Number` value. The number must already be an
-- | integer and fall within the valid range of values for the `Int` type
-- | otherwise `Nothing` is returned.
fromNumber :: Number -> Maybe Int
fromNumber = fromNumberImpl Just Nothing

foreign import fromNumberImpl
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Number
  -> Maybe Int

-- | Convert a `Number` to an `Int`, by taking the closest integer equal to or
-- | less than the argument. Values outside the `Int` range are clamped, `NaN`
-- | and `Infinity` values return 0.
floor :: Number -> Int
floor = unsafeClamp <<< Math.floor

-- | Convert a `Number` to an `Int`, by taking the closest integer equal to or
-- | greater than the argument. Values outside the `Int` range are clamped,
-- | `NaN` and `Infinity` values return 0.
ceil :: Number -> Int
ceil = unsafeClamp <<< Math.ceil

-- | Convert a `Number` to an `Int`, by taking the nearest integer to the
-- | argument. Values outside the `Int` range are clamped, `NaN` and `Infinity`
-- | values return 0.
round :: Number -> Int
round = unsafeClamp <<< Math.round

-- | Convert an integral `Number` to an `Int`, by clamping to the `Int` range.
-- | This function will return 0 if the input is `NaN` or an `Infinity`.
unsafeClamp :: Number -> Int
unsafeClamp x
  | x == infinity = 0
  | x == -infinity = 0
  | x >= toNumber top = top
  | x <= toNumber bottom = bottom
  | otherwise = fromMaybe 0 (fromNumber x)

-- | Converts an `Int` value back into a `Number`. Any `Int` is a valid `Number`
-- | so there is no loss of precision with this function.
foreign import toNumber :: Int -> Number

-- | Reads an `Int` from a `String` value. The number must parse as an integer
-- | and fall within the valid range of values for the `Int` type, otherwise
-- | `Nothing` is returned.
fromString :: String -> Maybe Int
fromString = fromStringAs (Radix 10)

-- | Returns whether an `Int` is an even number.
-- |
-- | ``` purescript
-- | even 0 == true
-- | even 1 == false
-- | ```
even :: Int -> Boolean
even x = x .&. 1 == 0

-- | The negation of `even`.
-- |
-- | ``` purescript
-- | odd 0 == false
-- | odd 1 == false
-- | ```
odd :: Int -> Boolean
odd x = x .&. 1 /= 0

-- | The number of unique digits (including zero) used to represent integers in
-- | a specific base.
newtype Radix = Radix Int

-- | The base-2 system.
binary :: Radix
binary = Radix 2

-- | The base-8 system.
octal :: Radix
octal = Radix 8

-- | The base-10 system.
decimal :: Radix
decimal = Radix 10

-- | The base-16 system.
hexadecimal :: Radix
hexadecimal = Radix 16

-- | The base-36 system.
base36 :: Radix
base36 = Radix 36

-- | Create a `Radix` from a number between 2 and 36.
radix :: Int -> Maybe Radix
radix n | n >= 2 && n <= 36 = Just (Radix n)
        | otherwise         = Nothing

-- | Like `fromString`, but the integer can be specified in a different base.
-- |
-- | Example:
-- | ``` purs
-- | fromStringAs binary      "100" == Just 4
-- | fromStringAs hexadecimal "ff"  == Just 255
-- | ```
fromStringAs :: Radix -> String -> Maybe Int
fromStringAs = fromStringAsImpl Just Nothing

-- | Raise an Int to the power of another Int.
foreign import pow :: Int -> Int -> Int

foreign import fromStringAsImpl
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Radix
  -> String
  -> Maybe Int

foreign import toStringAs :: Radix -> Int -> String


Simplify cartesian product

Simplify cartesian product

module Helpers where

import Control.Apply ((<*>))
import Control.Monad.Eff (Eff)
import Data.Foldable (foldl, traverse_)
import Data.List (List(..), (:))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Prelude (Unit, id, map, (#))
import RxJS.Observable (Observable, combineLatest, just)

maybeToArr :: forall a. Maybe a -> Array a
maybeToArr m = case m of
  (Just val) -> [val]
  Nothing -> []

forEachMaybe :: forall e. Maybe (Eff e Unit) -> Eff e Unit
forEachMaybe m = traverse_ id (maybeToArr m)

tupleMaybes :: forall a b. Maybe a -> Maybe b -> Maybe (Tuple a b)
tupleMaybes ma mb = (ma # map Tuple) <*> mb

combineLatestAll :: forall a. List (Observable a) -> Observable (List a)
combineLatestAll list = foldl (\acc cur -> combineLatest (\x y -> y : x) acc cur) (just Nil) list

module Helpers where

import Control.Bind (bind)
import Control.Monad.Eff (Eff)
import Data.Foldable (foldl, traverse_)
import Data.List (List(..), (:))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Prelude (Unit, id, map)
import RxJS.Observable (Observable, combineLatest, just)

maybeToArr :: forall a. Maybe a -> Array a
maybeToArr m = case m of
  (Just val) -> [val]
  Nothing -> []

forEachMaybe :: forall e. Maybe (Eff e Unit) -> Eff e Unit
forEachMaybe m = traverse_ id (maybeToArr m)

tupleMaybes :: forall a b. Maybe a -> Maybe b -> Maybe (Tuple a b)
tupleMaybes ma mb =
  bind ma (\a -> map (\b -> Tuple a b) mb)

combineLatestAll :: forall a. List (Observable a) -> Observable (List a)
combineLatestAll list = foldl (\acc cur -> combineLatest (\x y -> y : x) acc cur) (just Nil) list


#1575 WIP - breadcrumbs de-BS

#1575 WIP - breadcrumbs de-BS

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.FileSystem.Breadcrumbs.Component
  ( State
  , Breadcrumb
  , rootBreadcrumb
  , mkBreadcrumbs
  , Query(..)
  , component
  ) where

import SlamData.Prelude

import Data.List (List(..), (:), reverse)
import Data.Path.Pathy (rootDir, runDirName, dirName, parentDir)

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

import SlamData.Monad (Slam)
import SlamData.Common.Sort (Sort(..))
import SlamData.FileSystem.Routing (browseURL)
import SlamData.FileSystem.Routing.Salt (Salt(..))

import Utils.Path (DirPath)

type State =
  { breadcrumbs ∷ List Breadcrumb
  , sort ∷ Sort
  , salt ∷ Salt
  }

type Breadcrumb =
  { name ∷ String
  , link ∷ DirPath
  }

rootBreadcrumb ∷ Breadcrumb
rootBreadcrumb =
  { name: "Home"
  , link: rootDir
  }

mkBreadcrumbs ∷ DirPath → Sort → Salt → State
mkBreadcrumbs path sort salt =
  { breadcrumbs: reverse $ go Nil path
  , sort: sort
  , salt: salt
  }
  where
  go ∷ List Breadcrumb → DirPath → List Breadcrumb
  go result p =
    let result' = { name: maybe "" runDirName (dirName p), link: p } : result
    in case parentDir p of
      Just dir → go result' dir
      Nothing → rootBreadcrumb : result

data Query a = Set State a

type Input =
  { path ∷ DirPath
  , sort ∷ Sort
  , salt ∷ Salt
  }

component ∷ H.Component HH.HTML Query Input Void Slam
component =
  H.component
    { initialState: const { breadcrumbs: Nil, sort: Asc, salt: Salt "" }
    , render
    , eval
    , receiver
    }

render ∷ State → H.ComponentHTML Query
render r =
  HH.ol
    [ HP.classes [ HH.ClassName "breadcrumb" ] ]
    $ foldl (\views model → view model <> views) [ ] r.breadcrumbs
  where
  view b =
    [ HH.li_
        [ HH.a
            [ HP.href (browseURL Nothing r.sort r.salt b.link) ]
            [ HH.text b.name ]
        ]
    ]

receiver ∷ Input → Maybe (Query Unit)
receiver { path, sort, salt } =
  Just $ H.action $ Set $ mkBreadcrumbs path sort salt

eval ∷ Query ~> H.ComponentDSL State Query Void Slam
eval (Set st next) = do
  H.put st
  pure next

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.FileSystem.Breadcrumbs.Component
  ( State
  , Breadcrumb
  , rootBreadcrumb
  , mkBreadcrumbs
  , Query(..)
  , component
  ) where

import SlamData.Prelude

import Data.List (List(..), (:), reverse)
import Data.Path.Pathy (rootDir, runDirName, dirName, parentDir)

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B

import SlamData.Monad (Slam)
import SlamData.Common.Sort (Sort(..))
import SlamData.FileSystem.Routing (browseURL)
import SlamData.FileSystem.Routing.Salt (Salt(..))

import Utils.Path (DirPath)

type State =
  { breadcrumbs ∷ List Breadcrumb
  , sort ∷ Sort
  , salt ∷ Salt
  }

type Breadcrumb =
  { name ∷ String
  , link ∷ DirPath
  }

rootBreadcrumb ∷ Breadcrumb
rootBreadcrumb =
  { name: "Home"
  , link: rootDir
  }

mkBreadcrumbs ∷ DirPath → Sort → Salt → State
mkBreadcrumbs path sort salt =
  { breadcrumbs: reverse $ go Nil path
  , sort: sort
  , salt: salt
  }
  where
  go ∷ List Breadcrumb → DirPath → List Breadcrumb
  go result p =
    let result' = { name: maybe "" runDirName (dirName p), link: p } : result
    in case parentDir p of
      Just dir → go result' dir
      Nothing → rootBreadcrumb : result

data Query a = Set State a

type Input =
  { path ∷ DirPath
  , sort ∷ Sort
  , salt ∷ Salt
  }

component ∷ H.Component HH.HTML Query Input Void Slam
component =
  H.component
    { initialState: const { breadcrumbs: Nil, sort: Asc, salt: Salt "" }
    , render
    , eval
    , receiver
    }

render ∷ State → H.ComponentHTML Query
render r =
  HH.ol
    [ HP.classes [ B.breadcrumb, B.colXs7 ] ]
    $ foldl (\views model → view model <> views) [ ] r.breadcrumbs
  where
  view b =
    [ HH.li_
        [ HH.a
            [ HP.href (browseURL Nothing r.sort r.salt b.link) ]
            [ HH.text b.name ]
        ]
    ]

receiver ∷ Input → Maybe (Query Unit)
receiver { path, sort, salt } =
  Just $ H.action $ Set $ mkBreadcrumbs path sort salt

eval ∷ Query ~> H.ComponentDSL State Query Void Slam
eval (Set st next) = do
  H.put st
  pure next


Fix localeCompare test

Fix localeCompare test

module Test.Data.String where

import Data.String
import Debug.Trace
import Control.Monad.Eff
import Test.QuickCheck

main = do

  trace "charAt should return the character at the specified index"
  assert $ charAt 0 "abcd" == "a"
  assert $ charAt 1 "abcd" == "b"

  trace "charCodeAt should return the character at the specified index"
  print $ charCodeAt 0 "abcd" == 97
  print $ charCodeAt 1 "abcd" == 98

  trace "fromCharCode should return a character for a char code"
  assert $ fromCharCode 97 == "a"
  assert $ fromCharCode 98 == "b"

  trace "indexOf should return the index for a substring"
  assert $ indexOf "b" "abc" == 1
  assert $ indexOf "q" "abc" == -1

  trace "indexOf' should return the index for a substring starting from an offset"
  assert $ indexOf' "b" 2 "abcb" == 3
  assert $ indexOf' "q" 2 "abcb" == -1

  trace "lastIndexOf should return the last index for a substring"
  assert $ lastIndexOf "a" "abca" == 3
  assert $ lastIndexOf "q" "abca" == -1

  trace "lastIndexOf' should return the last index for a substring starting from an offset"
  assert $ lastIndexOf' "a" 1 "abca" == 0
  assert $ lastIndexOf' "q" 1 "abca" == -1

  trace "length should return the length of a string"
  assert $ length "" == 0
  assert $ length "a" == 1
  assert $ length "abdc" == 4

  trace "localeCompare should perform a locale-sensitive comparison"
  print $ localeCompare "a" "c" < 0
  print $ localeCompare "a" "a" == 0
  print $ localeCompare "c" "a" > 0

  trace "replace should replace one substring with another"
  assert $ replace "bar" "baz" "foobar" == "foobaz"

  trace "take should keep the specified number of characters and drop the rest"
  assert $ take 2 "abcd" == "ab"

  trace "drop should drop the specified number of characters from the start of a string and keep the rest"
  assert $ drop 2 "abcd" == "cd"

  trace "split should split a string on a substring"
  assert $ split "," "a,b,c,d" == ["a", "b", "c", "d"]

  trace "toLower should transform a string to lower-case"
  assert $ toLower "ABCD" == "abcd"

  trace "toUpper should transform a string to upper-case"
  assert $ toUpper "abcd" == "ABCD"

  trace "trim should remove leading and trailing whitespace"
  assert $ trim " abc" == "abc"
  assert $ trim " abc " == "abc"
  assert $ trim "abc" == "abc"

  trace "joinWith should join a list of strings with a separator string"
  assert $ joinWith "," ["a", "b", "c", "d"] == "a,b,c,d"
  assert $ joinWith " " ["p", "q", "r"] == "p q r"

assert :: Boolean -> QC {}
assert = quickCheck' 1

module Test.Data.String where

import Data.String
import Debug.Trace
import Control.Monad.Eff
import Test.QuickCheck

main = do

  trace "charAt should return the character at the specified index"
  assert $ charAt 0 "abcd" == "a"
  assert $ charAt 1 "abcd" == "b"

  trace "charCodeAt should return the character at the specified index"
  print $ charCodeAt 0 "abcd" == 97
  print $ charCodeAt 1 "abcd" == 98

  trace "fromCharCode should return a character for a char code"
  assert $ fromCharCode 97 == "a"
  assert $ fromCharCode 98 == "b"

  trace "indexOf should return the index for a substring"
  assert $ indexOf "b" "abc" == 1
  assert $ indexOf "q" "abc" == -1

  trace "indexOf' should return the index for a substring starting from an offset"
  assert $ indexOf' "b" 2 "abcb" == 3
  assert $ indexOf' "q" 2 "abcb" == -1

  trace "lastIndexOf should return the last index for a substring"
  assert $ lastIndexOf "a" "abca" == 3
  assert $ lastIndexOf "q" "abca" == -1

  trace "lastIndexOf' should return the last index for a substring starting from an offset"
  assert $ lastIndexOf' "a" 1 "abca" == 0
  assert $ lastIndexOf' "q" 1 "abca" == -1

  trace "length should return the length of a string"
  assert $ length "" == 0
  assert $ length "a" == 1
  assert $ length "abdc" == 4

  trace "localeCompare should perform a locale-sensitive comparison"
  assert $ indexOf "b" "abc" == 1
  assert $ indexOf "q" "abc" == -1

  trace "replace should replace one substring with another"
  assert $ replace "bar" "baz" "foobar" == "foobaz"

  trace "take should keep the specified number of characters and drop the rest"
  assert $ take 2 "abcd" == "ab"

  trace "drop should drop the specified number of characters from the start of a string and keep the rest"
  assert $ drop 2 "abcd" == "cd"

  trace "split should split a string on a substring"
  assert $ split "," "a,b,c,d" == ["a", "b", "c", "d"]

  trace "toLower should transform a string to lower-case"
  assert $ toLower "ABCD" == "abcd"

  trace "toUpper should transform a string to upper-case"
  assert $ toUpper "abcd" == "ABCD"

  trace "trim should remove leading and trailing whitespace"
  assert $ trim " abc" == "abc"
  assert $ trim " abc " == "abc"
  assert $ trim "abc" == "abc"

  trace "joinWith should join a list of strings with a separator string"
  assert $ joinWith "," ["a", "b", "c", "d"] == "a,b,c,d"
  assert $ joinWith " " ["p", "q", "r"] == "p q r"

assert :: Boolean -> QC {}
assert = quickCheck' 1


Clean up requiredness check

Clean up requiredness check

-- | Input Parser Generator for Docopt
-- |
-- | > Given a un-ambigious specification as input, generate a parser that can
-- | > be applied to user input.
-- |
-- | ===

module Language.Docopt.ParserGen.Parser (
    genUsageParser
  , Parser()
  ) where

import Prelude
import Control.Plus (empty)
import Debug.Trace
import Control.Monad.State (State(), evalState)
import Control.Apply ((*>), (<*))
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList, filter, reverse, concat)
import Control.Alt ((<|>))
import Control.Lazy (defer)
import Data.Foldable (foldl, intercalate, for_, all)
import Data.String (fromCharArray, stripPrefix)
import qualified Data.List as L
import qualified Data.List.Unsafe as LU
import qualified Data.Array as A
import qualified Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Tuple (Tuple(..), fst)
import Data.Monoid (mempty)
import Data.Map (Map())
import Control.Monad.Reader (Reader(), ask)
import Data.Map as Map
import Data.StrMap (StrMap())
import Control.Monad.Trans (lift)

import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt.Env      as Env
import Language.Docopt.Errors   as D
import Language.Docopt.Value    as D
import Language.Docopt.Argument as D
import Language.Docopt.Usage    as D
import Language.Docopt.Env      as D
import Language.Docopt.Option   as O

import Language.Docopt.ParserGen.Token
import Language.Docopt.ParserGen.ValueMapping
import Language.Docopt.Parser.Base (alphaNum, space, getInput, debug)

type Parser a = P.ParserT (List Token) (Reader D.Env) a

--------------------------------------------------------------------------------
-- Input Token Parser ----------------------------------------------------------
--------------------------------------------------------------------------------

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> Parser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case test tok of
        Just a ->
          let nextpos = pos -- neglect pos (for now)
          in
            { consumed: true
            , input:    xs
            , result:   Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "expected token, met EOF"

data Acc a
  = Free (Parser a)
  | Pending (Parser a) (List D.Argument)

eoa :: Parser D.Value
eoa = token go P.<?> "--"
  where
    go (EOA xs) = Just (D.ArrayValue (fromList xs))
    go _        = Nothing

command :: String -> Parser D.Value
command n = token go P.<?> "command " ++ show n
  where
    go (Lit s) | s == n = Just (D.BoolValue true)
    go _                = Nothing

positional :: String -> Parser D.Value
positional n = token go P.<?> "positional argument " ++ show n
  where
    go (Lit v) = Just (D.StringValue v)
    go _       = Nothing

type HasConsumedArg = Boolean
data OptParse = OptParse D.Value (Maybe Token) HasConsumedArg

longOption :: O.Name -> (Maybe O.Argument) -> Parser D.Value
longOption n a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos (for now)
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    takesArg = isJust a

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | takesArg && (n' == n)
      = case v of
          Just s ->
            return $ OptParse (D.StringValue s) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s)  Nothing true
            _            -> OptParse (D.BoolValue true) Nothing false

    -- case 2:
    -- The name is an exact match and takes no argument
    go (LOpt n' _) _ | (not takesArg) && (n' == n)
      = return $ OptParse (D.BoolValue true) Nothing false

    -- case 3:
    -- The name is a substring of the input and no explicit argument has been
    -- provdided.
    go (LOpt n' Nothing) atok | takesArg
      = case stripPrefix n n' of
          Just s -> return $ OptParse (D.StringValue s) Nothing false
          _      -> Left "Invalid substring"

    go _ _ = Left "Invalid token"

shortOption :: Char -> (Maybe O.Argument) -> Parser D.Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    takesArg = isJust a

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && takesArg && (A.length xs == 0)
      = case v of
          Just val -> return $ OptParse (D.StringValue val) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s) Nothing true
            _ -> OptParse (D.BoolValue true)
                          Nothing
                          false

    -- case 2:
    -- The leading flag matches, there are stacked options, no explicit
    -- argument has been passed and the option takes an argument.
    go (SOpt f' xs v) _ | (f' == f) && takesArg && (A.length xs > 0)
      = do
        let a = fromCharArray xs ++ maybe "" id v
        return $ OptParse (D.StringValue a)
                          Nothing
                          false

    -- case 3:
    -- The leading flag matches, there are stacked options, the option takes
    -- no argument and an explicit argument has not been provided.
    go (SOpt f' xs v) _ | (f' == f) && (not takesArg) && (A.length xs > 0)
      = return $ OptParse (D.BoolValue true)
                          (Just $ SOpt (AU.head xs) (AU.tail xs) v)
                          false

    -- case 4:
    -- The leading flag matches, there are no stacked options and the option
    -- takes no argument - total consumption!
    go (SOpt f' xs _) _ | (f' == f) && (not takesArg) && (A.length xs == 0)
      = return $ OptParse (D.BoolValue true)
                          Nothing
                          false

    go a b = Left $ "Invalid token " ++ show a ++ " (input: " ++ show b ++ ")"

eof :: Parser Unit
eof = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return $ case s of
    Nil -> { consumed: false, input: s, result: Right unit, position: pos }
    _   -> P.parseFailed s pos $
              "Trailing input: "
            ++ (intercalate ", " $ prettyPrintToken <$> s)

-- | Generate a parser for a single program usage.
genUsageParser :: D.Usage -> Parser (Tuple D.Branch (List ValueMapping))
genUsageParser (D.Usage xs) = do
  P.choice $ xs <#> \x -> Tuple x <$> genBranchParser x
  <* eof

-- | Generate a parser for a single usage branch
genBranchParser :: D.Branch -> Parser (List (Tuple D.Argument D.Value))
genBranchParser (D.Branch xs) = do
  either
    (\_   -> P.fail "Failed to generate parser")
    (\acc -> case acc of
      Free p       -> p
      Pending p xs -> do
        a  <- p
        as <- genExhaustiveParser xs
        return (a ++ as))
    (foldM step (Free $ pure empty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    genExhaustiveParser :: List D.Argument
                        -> Parser (List (Tuple D.Argument D.Value))
    genExhaustiveParser Nil = pure empty
    genExhaustiveParser ps  = do
      draw ps (length ps)
      where
        -- iterate over `ps` until a match `x` is found, then, recursively
        -- apply `draw` until the parser fails, with a modified `ps`.
        draw :: List D.Argument
             -> Int
             -> Parser (List (Tuple D.Argument D.Value))

        draw pss@(Cons p ps') n | n >= 0 = (do
          xs <- genParser p

          -- verify the arguments for parsed set of options
          -- when an option takes anything but a bool value, i.e. it is not
          -- a switch, an explicit argument *must* be provided.
          let ys = fst <$> filter
                    (\(Tuple a v) -> (D.takesArgument a)
                                  && (not $ D.isFlag a)
                                  && (D.isBoolValue v))
                      xs
          if (length ys > 0)
            then P.fail $ "Missing required arguments for "
                        ++ intercalate ", " (D.prettyPrintArg <$> ys)
            else return unit

          xss <- if D.isRepeatable p
                      then draw pss (length pss)
                      else draw (ps') (length ps')
          return $ xs ++ xss
        ) <|> (defer \_ -> draw (ps' ++ singleton p) (n - 1))

        draw ps' n | (length ps' > 0) && (n < 0) = do
          env <- lift ask
          let missing = filter (\o -> not $ D.isRepeatable  o
                                         || D.hasDefault    o
                                         || D.hasEnvBacking o env
                               )
                               $ reverse ps'
          if (length missing > 0)
            then P.fail $
              "Missing required options: "
                ++ intercalate ", " (D.prettyPrintArg <$> missing)
            else return empty

        draw _ _ = return empty

    -- Options always transition to the `Pending state`
    step (Free p) x@(D.Option _) = Right $ Pending p (singleton x)
    step (Free p) x@(D.Group _ bs _) | isFree x
      = Right $ Pending p (singleton x)

    -- Any other argument causes immediate evaluation
    step (Free p) x = Right $ Free do
      a  <- p
      as <- genParser x
      return $ a ++ as

    -- Options always keep accumulating
    step (Pending p xs) x@(D.Option _) = Right $ Pending p (x:xs)

    -- Any non-options always leaves the pending state
    step (Pending p xs) y = Right $
      Free do
        a   <- p
        as  <- genExhaustiveParser xs
        ass <- genParser y
        return (a ++ as ++ ass)

    -- Parser generator for a single `Argument`
    genParser :: D.Argument -> Parser (List (Tuple D.Argument D.Value))

    -- Generate a parser for a `Command` argument
    genParser x@(D.Command n) = (do
      singleton <<< Tuple x <$> do
        command n
      ) P.<?> "command: " ++ (show $ D.prettyPrintArg x)

    -- Generate a parser for a `EOA` argument
    genParser x@(D.EOA) = (do
      singleton <<< Tuple x <$> do
        eoa <|> (return $ D.ArrayValue []) -- XXX: Fix type
      ) P.<?> "end of arguments: \"--\""

    -- Generate a parser for a `Stdin` argument
    genParser x@(D.Stdin) = (do
      singleton <<< Tuple x <$> do
        -- stdin always succeeds, as it is not actually an argument on argv.
        -- XXX: Should docopt check `process.stdin.isTTY` at this stage, or
        --      even at all?
        return (D.BoolValue true)
      ) P.<?> "stdin: \"-\""

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) = (do
      if r then (some go) else (singleton <$> go)
      ) P.<?> "positional argument: " ++ (show $ D.prettyPrintArg x)
      where go = Tuple x <$> (positional n)

    -- Generate a parser for a `Option` argument
    genParser x@(D.Option (O.Option o)) = (do
      if o.repeatable then (some go) else (singleton <$> go)
      ) P.<?> "option: " ++ (show $ D.prettyPrintArg x)
      where
        go = do
          P.choice $ P.try <$> [
            Tuple x <$> (mkLoptParser o.name o.arg)
          , Tuple x <$> (mkSoptParser o.flag o.arg)
          ]

        mkLoptParser (Just n) a = longOption n a
        mkLoptParser Nothing _  = P.fail "no long name"

        mkSoptParser (Just f) a = shortOption f a
        mkSoptParser Nothing _  = P.fail "no flag"

    -- Generate a parser for a argument `Group`
    genParser x@(D.Group optional bs repeated) = do
      concat <$>
        let mod    = if optional then P.option empty else \p -> p
            parser = if repeated then many go else singleton <$> go
         in mod parser
      where go = if length bs > 0
                    then P.choice $ P.try <<< genBranchParser <$> bs
                    else return empty

    isFree :: D.Argument -> Boolean
    isFree (D.Option _)     = true
    isFree (D.Group _ bs _) = all (\(D.Branch b) -> all isFree b) bs
    isFree _                = false

-- | Input Parser Generator for Docopt
-- |
-- | > Given a un-ambigious specification as input, generate a parser that can
-- | > be applied to user input.
-- |
-- | ===

module Language.Docopt.ParserGen.Parser (
    genUsageParser
  , Parser()
  ) where

import Prelude
import Control.Plus (empty)
import Debug.Trace
import Control.Monad.State (State(), evalState)
import Control.Apply ((*>), (<*))
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.List (List(..), foldM, (:), singleton, some, toList, delete, length
                 , head, many, tail, fromList, filter, reverse, concat)
import Control.Alt ((<|>))
import Control.Lazy (defer)
import Data.Foldable (foldl, intercalate, for_, all)
import Data.String (fromCharArray, stripPrefix)
import qualified Data.List as L
import qualified Data.List.Unsafe as LU
import qualified Data.Array as A
import qualified Data.Array.Unsafe as AU
import Data.Array (uncons)
import Data.Tuple (Tuple(..), fst)
import Data.Monoid (mempty)
import Data.Map (Map())
import Control.Monad.Reader (Reader(), ask)
import Data.Map as Map
import Data.StrMap (StrMap())
import Control.Monad.Trans (lift)

import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt.Env      as Env
import Language.Docopt.Errors   as D
import Language.Docopt.Value    as D
import Language.Docopt.Argument as D
import Language.Docopt.Usage    as D
import Language.Docopt.Env      as D
import Language.Docopt.Option   as O

import Language.Docopt.ParserGen.Token
import Language.Docopt.ParserGen.ValueMapping
import Language.Docopt.Parser.Base (alphaNum, space, getInput, debug)

type Parser a = P.ParserT (List Token) (Reader D.Env) a

--------------------------------------------------------------------------------
-- Input Token Parser ----------------------------------------------------------
--------------------------------------------------------------------------------

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> Parser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case test tok of
        Just a ->
          let nextpos = pos -- neglect pos (for now)
          in
            { consumed: true
            , input:    xs
            , result:   Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "expected token, met EOF"

data Acc a
  = Free (Parser a)
  | Pending (Parser a) (List D.Argument)

eoa :: Parser D.Value
eoa = token go P.<?> "--"
  where
    go (EOA xs) = Just (D.ArrayValue (fromList xs))
    go _        = Nothing

command :: String -> Parser D.Value
command n = token go P.<?> "command " ++ show n
  where
    go (Lit s) | s == n = Just (D.BoolValue true)
    go _                = Nothing

positional :: String -> Parser D.Value
positional n = token go P.<?> "positional argument " ++ show n
  where
    go (Lit v) = Just (D.StringValue v)
    go _       = Nothing

type HasConsumedArg = Boolean
data OptParse = OptParse D.Value (Maybe Token) HasConsumedArg

longOption :: O.Name -> (Maybe O.Argument) -> Parser D.Value
longOption n a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos (for now)
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    takesArg = isJust a

    -- case 1:
    -- The name is an exact match
    go (LOpt n' v) atok | takesArg && (n' == n)
      = case v of
          Just s ->
            return $ OptParse (D.StringValue s) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s)  Nothing true
            _            -> OptParse (D.BoolValue true) Nothing false

    -- case 2:
    -- The name is an exact match and takes no argument
    go (LOpt n' _) _ | (not takesArg) && (n' == n)
      = return $ OptParse (D.BoolValue true) Nothing false

    -- case 3:
    -- The name is a substring of the input and no explicit argument has been
    -- provdided.
    go (LOpt n' Nothing) atok | takesArg
      = case stripPrefix n n' of
          Just s -> return $ OptParse (D.StringValue s) Nothing false
          _      -> Left "Invalid substring"

    go _ _ = Left "Invalid token"

shortOption :: Char -> (Maybe O.Argument) -> Parser D.Value
shortOption f a = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons tok xs ->
      case go tok (head xs) of
        Left e -> P.parseFailed toks pos e
        Right (OptParse v newtok hasConsumedArg) ->
          { consumed: maybe true (const false) newtok
          , input:    (maybe empty singleton newtok) ++
                      (if hasConsumedArg then (LU.tail xs) else xs)
          , result:   Right v
          , position: pos -- ignore pos
          }
    _ -> P.parseFailed toks pos "expected token, met EOF"

  where
    takesArg = isJust a

    -- case 1:
    -- The leading flag matches, there are no stacked options, and an explicit
    -- argument may have been passed.
    go (SOpt f' xs v) atok | (f' == f) && takesArg && (A.length xs == 0)
      = case v of
          Just val -> return $ OptParse (D.StringValue val) Nothing false
          _  -> return case atok of
            Just (Lit s) -> OptParse (D.StringValue s) Nothing true
            _ -> OptParse (D.BoolValue true)
                          Nothing
                          false

    -- case 2:
    -- The leading flag matches, there are stacked options, no explicit
    -- argument has been passed and the option takes an argument.
    go (SOpt f' xs v) _ | (f' == f) && takesArg && (A.length xs > 0)
      = do
        let a = fromCharArray xs ++ maybe "" id v
        return $ OptParse (D.StringValue a)
                          Nothing
                          false

    -- case 3:
    -- The leading flag matches, there are stacked options, the option takes
    -- no argument and an explicit argument has not been provided.
    go (SOpt f' xs v) _ | (f' == f) && (not takesArg) && (A.length xs > 0)
      = return $ OptParse (D.BoolValue true)
                          (Just $ SOpt (AU.head xs) (AU.tail xs) v)
                          false

    -- case 4:
    -- The leading flag matches, there are no stacked options and the option
    -- takes no argument - total consumption!
    go (SOpt f' xs _) _ | (f' == f) && (not takesArg) && (A.length xs == 0)
      = return $ OptParse (D.BoolValue true)
                          Nothing
                          false

    go a b = Left $ "Invalid token " ++ show a ++ " (input: " ++ show b ++ ")"

eof :: Parser Unit
eof = P.ParserT $ \(P.PState { input: s, position: pos }) ->
  return $ case s of
    Nil -> { consumed: false, input: s, result: Right unit, position: pos }
    _   -> P.parseFailed s pos $
              "Trailing input: "
            ++ (intercalate ", " $ prettyPrintToken <$> s)

-- | Generate a parser for a single program usage.
genUsageParser :: D.Usage -> Parser (Tuple D.Branch (List ValueMapping))
genUsageParser (D.Usage xs) = do
  P.choice $ xs <#> \x -> Tuple x <$> genBranchParser x
  <* eof

-- | Generate a parser for a single usage branch
genBranchParser :: D.Branch -> Parser (List (Tuple D.Argument D.Value))
genBranchParser (D.Branch xs) = do
  either
    (\_   -> P.fail "Failed to generate parser")
    (\acc -> case acc of
      Free p       -> p
      Pending p xs -> do
        a  <- p
        as <- genExhaustiveParser xs
        return (a ++ as))
    (foldM step (Free $ pure empty) xs)
  where

    -- Given a list of arguments, try parse them all in any order.
    -- The only requirement is that all input is consumed in the end.
    genExhaustiveParser :: List D.Argument
                        -> Parser (List (Tuple D.Argument D.Value))
    genExhaustiveParser Nil = pure empty
    genExhaustiveParser ps  = do
      draw ps (length ps)
      where
        -- iterate over `ps` until a match `x` is found, then, recursively
        -- apply `draw` until the parser fails, with a modified `ps`.
        draw :: List D.Argument
             -> Int
             -> Parser (List (Tuple D.Argument D.Value))

        draw pss@(Cons p ps') n | n >= 0 = (do
          xs <- genParser p

          -- verify the arguments for parsed set of options
          -- when an option takes anything but a bool value, i.e. it is not
          -- a switch, an explicit argument *must* be provided.
          let ys = fst <$> filter
                    (\(Tuple a v) -> (D.takesArgument a)
                                  && (not $ D.isFlag a)
                                  && (D.isBoolValue v))
                      xs
          if (length ys > 0)
            then P.fail $ "Missing required arguments for "
                        ++ intercalate ", " (D.prettyPrintArg <$> ys)
            else return unit

          xss <- if D.isRepeatable p
                      then draw pss (length pss)
                      else draw (ps') (length ps')
          return $ xs ++ xss
        ) <|> (defer \_ -> draw (ps' ++ singleton p) (n - 1))

        draw ps' n | (length ps' > 0) && (n < 0) = do
          env <- lift ask
          let rest = filter
                      (\p -> (not $ D.isRepeatable p)
                          && (not $ D.hasDefault p)
                          && (not $ D.hasEnvBacking p env))
                      (reverse ps')
          if (length rest > 0)
            then P.fail $
              "Missing required options: "
                ++ intercalate ", " (D.prettyPrintArg <$> rest)
            else return empty

        draw _ _ = return empty

    -- Options always transition to the `Pending state`
    step (Free p) x@(D.Option _) = Right $ Pending p (singleton x)
    step (Free p) x@(D.Group _ bs _) | isFree x
      = Right $ Pending p (singleton x)

    -- Any other argument causes immediate evaluation
    step (Free p) x = Right $ Free do
      a  <- p
      as <- genParser x
      return $ a ++ as

    -- Options always keep accumulating
    step (Pending p xs) x@(D.Option _) = Right $ Pending p (x:xs)

    -- Any non-options always leaves the pending state
    step (Pending p xs) y = Right $
      Free do
        a   <- p
        as  <- genExhaustiveParser xs
        ass <- genParser y
        return (a ++ as ++ ass)

    -- Parser generator for a single `Argument`
    genParser :: D.Argument -> Parser (List (Tuple D.Argument D.Value))

    -- Generate a parser for a `Command` argument
    genParser x@(D.Command n) = (do
      singleton <<< Tuple x <$> do
        command n
      ) P.<?> "command: " ++ (show $ D.prettyPrintArg x)

    -- Generate a parser for a `EOA` argument
    genParser x@(D.EOA) = (do
      singleton <<< Tuple x <$> do
        eoa <|> (return $ D.ArrayValue []) -- XXX: Fix type
      ) P.<?> "end of arguments: \"--\""

    -- Generate a parser for a `Stdin` argument
    genParser x@(D.Stdin) = (do
      singleton <<< Tuple x <$> do
        -- stdin always succeeds, as it is not actually an argument on argv.
        -- XXX: Should docopt check `process.stdin.isTTY` at this stage, or
        --      even at all?
        return (D.BoolValue true)
      ) P.<?> "stdin: \"-\""

    -- Generate a parser for a `Positional` argument
    genParser x@(D.Positional n r) = (do
      if r then (some go) else (singleton <$> go)
      ) P.<?> "positional argument: " ++ (show $ D.prettyPrintArg x)
      where go = Tuple x <$> (positional n)

    -- Generate a parser for a `Option` argument
    genParser x@(D.Option (O.Option o)) = (do
      if o.repeatable then (some go) else (singleton <$> go)
      ) P.<?> "option: " ++ (show $ D.prettyPrintArg x)
      where
        go = do
          P.choice $ P.try <$> [
            Tuple x <$> (mkLoptParser o.name o.arg)
          , Tuple x <$> (mkSoptParser o.flag o.arg)
          ]

        mkLoptParser (Just n) a = longOption n a
        mkLoptParser Nothing _  = P.fail "no long name"

        mkSoptParser (Just f) a = shortOption f a
        mkSoptParser Nothing _  = P.fail "no flag"

    -- Generate a parser for a argument `Group`
    genParser x@(D.Group optional bs repeated) = do
      concat <$>
        let mod    = if optional then P.option empty else \p -> p
            parser = if repeated then many go else singleton <$> go
         in mod parser
      where go = if length bs > 0
                    then P.choice $ P.try <<< genBranchParser <$> bs
                    else return empty

    isFree :: D.Argument -> Boolean
    isFree (D.Option _)     = true
    isFree (D.Group _ bs _) = all (\(D.Branch b) -> all isFree b) bs
    isFree _                = false


Added more tests

Added more tests

module Test.Main where

import Test.Unit
import SearchEngine

main = runTest do

  test "Empty Index Search tests" do
    let index = createIndex []
    assert "Empty index with empty string" $ search index "" == []
    assert "Empty index with non-empty string" $ search index "Foo" == []

  test "One word Index Search tests" $ do
    let index = createIndex ["Hello"]
    assert "Search with empty string" $ search index "" == []
    assert "Search with non existing word" $ search index "Foo" == []
    assert "Search with existing word" $ search index "Hello" == [1]

  test "One line Index Search tests" $ do
    let index = createIndex ["Welcome to the world"]
    assert "Search with empty string" $ search index "" == []
    assert "Search with non existing word" $ search index "Foo" == []
    assert "Search with existing word" $ search index "Welcome" == [1]
    assert "Search with existing words" $ search index "welcome world" == [1]

  test "Many lines Index Search tests" $ do
    let index = createIndex ["Back to the Future", "The Future is now"]
    assert "Search with empty string" $ search index "" == []
    assert "Search with single word" $ search index "future" == [2, 1]
    assert "Search with more words" $ search index "Back future" == [1]
    assert "Search with other words" $ search index "Future now" == [2]